Teach haddock about line pragmas and add accurate source code links

Teach haddock about C and Haskell style line pragmas. Extend the lexer/parser's
source location tracking to include the file name as well as line/column. This
way each AST item that is tagged with a SrcLoc gets the original file name too.

Use this original file name to add source links to each exported item, in the
same visual style as the wiki links. Note that the per-export source links are
to the defining module rather than whichever module haddock pretends it is
exported from. This is what we want for source code links. The source code link
URL can also contain the name of the export so one could implement jumping to
the actual location of the function in the file if it were linked to an html
version of the source rather than just plain text. The name can be selected
with the %N wild card.

So for linking to the raw source code one might use:
--source=http://darcs/haskell.org/foo/%F

Or for linking to html syntax highlighted code:
--source=http://darcs/haskell.org/foo/%M.html#%N

9 files changed, 238 insertions, 177 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 420eab26..b04ee3c2 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -148,7 +148,8 @@ spliceSrcURL :: Interface -> String -> String
 spliceSrcURL iface url = run url
   where run "" = ""
         run ('%':'M':rest) = modl_str ++ run rest
-        run ('%':'F':rest) = iface_filename iface ++ run rest
+        run ('%':'N':rest) = run rest
+        run ('%':'F':rest) = iface_orig_filename iface ++ run rest
 	run (c:rest) = c : run rest
 	
 	modl_str = case iface_module iface of { Module m -> 
@@ -492,13 +493,13 @@ ppHtmlModule odir doctitle
 	    pageHeader mdl iface doctitle
 		maybe_source_url maybe_wiki_url
 		maybe_contents_url maybe_index_url </> s15 </>
-	    ifaceToHtml mdl maybe_wiki_url iface </> s15 </>
+	    ifaceToHtml maybe_source_url maybe_wiki_url iface </> s15 </>
 	    footer
          )
   writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html)
 
-ifaceToHtml :: String -> Maybe String -> Interface -> HtmlTable
-ifaceToHtml _ maybe_wiki_url iface 
+ifaceToHtml :: Maybe String -> Maybe String -> Interface -> HtmlTable
+ifaceToHtml maybe_source_url maybe_wiki_url iface
   = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
   where 
 	exports = numberSectionHeadings (iface_exports iface)
@@ -526,7 +527,7 @@ ifaceToHtml _ maybe_wiki_url iface
 	  = (tda [theclass "section1"] << toHtml "Synopsis") </>
 	    s15 </>
             (tda [theclass "body"] << vanillaTable <<
-  	        abovesSep s8 (map (processExport True Nothing)
+  	        abovesSep s8 (map (processExport True linksInfo)
 			(filter forSummary exports))
 	    )
 
@@ -538,10 +539,8 @@ ifaceToHtml _ maybe_wiki_url iface
 		   ExportGroup _ _ _ : _ -> Html.emptyTable
 		   _ -> tda [ theclass "section1" ] << toHtml "Documentation"
 
-	bdy  = map (processExport False wiki_info) exports
-	wiki_info = case maybe_wiki_url of
-		      Nothing -> Nothing
-		      Just wiki_url -> Just (wiki_url, iface_module iface)
+	bdy  = map (processExport False linksInfo) exports
+	linksInfo = (maybe_source_url, maybe_wiki_url, iface)
 
 ppModuleContents :: [ExportItem] -> HtmlTable
 ppModuleContents exports
@@ -577,14 +576,14 @@ numberSectionHeadings exports = go 1 exports
 	go n (other:es)
 	  = other : go n es
 
--- The base URL for wiki links, and the current module
-type WikiInfo = Maybe (String, Module)
+-- The URL for source and wiki links, and the current module
+type LinksInfo = (Maybe String, Maybe String, Interface)
 
-processExport :: Bool -> WikiInfo -> ExportItem -> HtmlTable
+processExport :: Bool -> LinksInfo -> ExportItem -> HtmlTable
 processExport _ _ (ExportGroup lev id0 doc)
   = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
-processExport summary wiki (ExportDecl x decl insts)
-  = doDecl summary wiki x decl insts
+processExport summary links (ExportDecl x decl insts)
+  = doDecl summary links x decl insts
 processExport summmary _ (ExportNoDecl _ y [])
   = declBox (ppHsQName y)
 processExport summmary _ (ExportNoDecl _ y subs)
@@ -609,36 +608,36 @@ ppDocGroup lev doc
 -- -----------------------------------------------------------------------------
 -- Converting declarations to HTML
 
-declWithDoc :: Bool -> WikiInfo -> HsName -> Maybe Doc -> Html -> HtmlTable
-declWithDoc True  _    _  _          html_decl = declBox html_decl
-declWithDoc False wiki nm Nothing    html_decl = topDeclBox wiki nm html_decl
-declWithDoc False wiki nm (Just doc) html_decl = 
-		topDeclBox wiki nm html_decl </> docBox (docToHtml doc)
+declWithDoc :: Bool -> LinksInfo -> SrcLoc -> HsName -> Maybe Doc -> Html -> HtmlTable
+declWithDoc True  _     _   _  _          html_decl = declBox html_decl
+declWithDoc False links loc nm Nothing    html_decl = topDeclBox links loc nm html_decl
+declWithDoc False links loc nm (Just doc) html_decl = 
+		topDeclBox links loc nm html_decl </> docBox (docToHtml doc)
 
-doDecl :: Bool -> WikiInfo -> HsQName -> HsDecl -> [InstHead] -> HtmlTable
-doDecl summary wiki x d instances = do_decl d
+doDecl :: Bool -> LinksInfo -> HsQName -> HsDecl -> [InstHead] -> HtmlTable
+doDecl summary links x d instances = do_decl d
   where
-     do_decl (HsTypeSig _ [nm] ty doc) 
-	= ppFunSig summary wiki nm ty doc
+     do_decl (HsTypeSig loc [nm] ty doc) 
+	= ppFunSig summary links loc nm ty doc
 
-     do_decl (HsForeignImport _ _ _ _ n ty doc)
-	= ppFunSig summary wiki n ty doc
+     do_decl (HsForeignImport loc _ _ _ n ty doc)
+	= ppFunSig summary links loc n ty doc
 
-     do_decl (HsTypeDecl _ nm args ty doc)
-	= declWithDoc summary wiki nm doc (
+     do_decl (HsTypeDecl loc nm args ty doc)
+	= declWithDoc summary links loc nm doc (
 	      hsep ([keyword "type", ppHsBinder summary nm]
 		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
 
      do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
-	= ppHsDataDecl summary wiki instances True{-is newtype-} x
+	= ppHsDataDecl summary links instances True{-is newtype-} x
 		(HsDataDecl loc ctx nm args [con] drv doc)
 	  -- print it as a single-constructor datatype
 
      do_decl d0@(HsDataDecl{})
-	= ppHsDataDecl summary wiki instances False{-not newtype-} x d0
+	= ppHsDataDecl summary links instances False{-not newtype-} x d0
 
      do_decl d0@(HsClassDecl{})
-	= ppHsClassDecl summary wiki instances x d0
+	= ppHsClassDecl summary links instances x d0
 
      do_decl (HsDocGroup _ lev str)
 	= if summary then Html.emptyTable 
@@ -653,7 +652,7 @@ ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppHsType ty
 -- -----------------------------------------------------------------------------
 -- Data & newtype declarations
 
-ppShortDataDecl :: Bool -> WikiInfo -> Bool -> HsDecl -> Html
+ppShortDataDecl :: Bool -> LinksInfo -> Bool -> HsDecl -> Html
 ppShortDataDecl summary _ is_newty 
 	(HsDataDecl _ _ nm args [con] _ _doc) =
    ppHsDataHeader summary is_newty nm args      
@@ -661,10 +660,10 @@ ppShortDataDecl summary _ is_newty
 ppShortDataDecl summary _ is_newty
 	(HsDataDecl _ _ nm args [] _ _doc) = 
    ppHsDataHeader summary is_newty nm args
-ppShortDataDecl summary wiki is_newty
-	(HsDataDecl _ _ nm args cons _ _doc) = 
+ppShortDataDecl summary links is_newty
+	(HsDataDecl loc _ nm args cons _ _doc) = 
    vanillaTable << (
-	(if summary then declBox else topDeclBox wiki nm)
+	(if summary then declBox else topDeclBox links loc nm)
           (ppHsDataHeader summary is_newty nm args) </>
 	tda [theclass "body"] << vanillaTable << (
 	  aboves (zipWith do_constr ('=':repeat '|') cons)
@@ -675,10 +674,10 @@ ppShortDataDecl _ _ _ d =
     error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d
 
 -- The rest of the cases:
-ppHsDataDecl :: Ord key => Bool	-> WikiInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
-ppHsDataDecl summary wiki instances is_newty 
-     x decl@(HsDataDecl _ _ nm args cons _ doc)
-  | summary = declWithDoc summary wiki nm doc (ppShortDataDecl summary wiki is_newty decl)
+ppHsDataDecl :: Ord key => Bool	-> LinksInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
+ppHsDataDecl summary links instances is_newty 
+     x decl@(HsDataDecl loc _ nm args cons _ doc)
+  | summary = declWithDoc summary links loc nm doc (ppShortDataDecl summary links is_newty decl)
 
   | otherwise
         = dataheader </> 
@@ -688,7 +687,7 @@ ppHsDataDecl summary wiki instances is_newty
 		instances_bit
             )
   where
-	dataheader = topDeclBox wiki nm (ppHsDataHeader False is_newty nm args)
+	dataheader = topDeclBox links loc nm (ppHsDataHeader False is_newty nm args)
 
 	constr_table
 	 	| any isRecDecl cons  = spacedTable5
@@ -835,15 +834,15 @@ ppFds fds =
 	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
 			       hsep (map ppHsName vars2)
 
-ppShortClassDecl :: Bool -> WikiInfo -> HsDecl -> HtmlTable
-ppShortClassDecl summary wiki (HsClassDecl _ ctxt nm tvs fds decls _) = 
+ppShortClassDecl :: Bool -> LinksInfo -> HsDecl -> HtmlTable
+ppShortClassDecl summary links (HsClassDecl loc ctxt nm tvs fds decls _) = 
   if null decls
-    then (if summary then declBox else topDeclBox wiki nm) hdr
-    else (if summary then declBox else topDeclBox wiki nm) (hdr <+> keyword "where")
+    then (if summary then declBox else topDeclBox links loc nm) hdr
+    else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")
 	    </> 
            (tda [theclass "body"] << 
 	     vanillaTable << 
-	       aboves [ ppFunSig summary wiki n ty doc 
+	       aboves [ ppFunSig summary links loc n ty doc 
 		      | HsTypeSig _ [n] ty doc <- decls
 		      ]
           )
@@ -853,10 +852,10 @@ ppShortClassDecl summary wiki (HsClassDecl _ ctxt nm tvs fds decls _) =
 ppShortClassDecl _ _ d =
     error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d
 
-ppHsClassDecl :: Ord key => Bool -> WikiInfo -> [InstHead] -> key -> HsDecl -> HtmlTable
-ppHsClassDecl summary wiki instances orig_c
-	decl@(HsClassDecl _ ctxt nm tvs fds decls doc)
-  | summary = ppShortClassDecl summary wiki decl
+ppHsClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead] -> key -> HsDecl -> HtmlTable
+ppHsClassDecl summary links instances orig_c
+	decl@(HsClassDecl loc ctxt nm tvs fds decls doc)
+  | summary = ppShortClassDecl summary links decl
 
   | otherwise
         = classheader </>
@@ -866,8 +865,8 @@ ppHsClassDecl summary wiki instances orig_c
 
    where 
 	classheader
-	   | null decls = topDeclBox wiki nm hdr
-	   | otherwise  = topDeclBox wiki nm (hdr <+> keyword "where")
+	   | null decls = topDeclBox links loc nm hdr
+	   | otherwise  = topDeclBox links loc nm (hdr <+> keyword "where")
 
 	hdr = ppClassHdr summary ctxt nm tvs fds
 
@@ -880,7 +879,7 @@ ppHsClassDecl summary wiki instances orig_c
 	   | otherwise  = 
 		s8 </> meth_hdr </>
 		tda [theclass "body"] << vanillaTable << (
-	       		abovesSep s8 [ ppFunSig summary wiki n ty doc0
+	       		abovesSep s8 [ ppFunSig summary links loc n ty doc0
 			             | HsTypeSig _ [n] ty doc0 <- decls
 			             ]
 			)
@@ -907,13 +906,13 @@ ppInstHead (ctxt,asst) =  ppHsContext ctxt <+> darrow <+> ppHsAsst asst
 -- ----------------------------------------------------------------------------
 -- Type signatures
 
-ppFunSig :: Bool -> WikiInfo -> HsName -> HsType -> Maybe Doc -> HtmlTable
-ppFunSig summary wiki nm ty0 doc
+ppFunSig :: Bool -> LinksInfo -> SrcLoc -> HsName -> HsType -> Maybe Doc -> HtmlTable
+ppFunSig summary links loc nm ty0 doc
   | summary || no_arg_docs ty0 = 
-      declWithDoc summary wiki nm doc (ppTypeSig summary nm ty0)
+      declWithDoc summary links loc nm doc (ppTypeSig summary nm ty0)
 
   | otherwise   = 
-	topDeclBox wiki nm (ppHsBinder False nm) </>
+	topDeclBox links loc nm (ppHsBinder False nm) </>
 	(tda [theclass "body"] << vanillaTable <<  (
 	   do_args dcolon ty0 </>
 	   (if (isJust doc) 
@@ -1157,18 +1156,38 @@ declBox :: Html -> HtmlTable
 declBox html = tda [theclass "decl"] << html
 
 -- a box for top level documented names
--- it adds a wiki link at the right hand side of the box
-topDeclBox :: Maybe (String, Module) -> HsName -> Html -> HtmlTable
-topDeclBox Nothing name html = declBox html
-topDeclBox (Just (base_url, Module mod)) name html =
+-- it adds a source and wiki link at the right hand side of the box
+topDeclBox :: LinksInfo -> SrcLoc -> HsName -> Html -> HtmlTable
+topDeclBox (Nothing, Nothing, _) srcloc name html = declBox html
+topDeclBox (maybe_src_url, maybe_wiki_url, iface) (SrcLoc _ _ fname) name html =
   tda [theclass "topdecl"] <<
   (        table ! [theclass "declbar"] <<
-	    ((tda [theclass "declname"] << html) <->
-             (tda [theclass "declbut"] << link))
+	    ((tda [theclass "declname"] << html)
+             <-> srcLink
+             <-> wikiLink)
   )
-  where link = anchor ! [href url] << toHtml "Comments"
-        url = pathJoin [base_url, mod] ++ nameAnchor
-        nameAnchor = '#' : escapeStr (hsNameStr name)
+  where srcLink =
+          case maybe_src_url of
+            Nothing  -> Html.emptyTable
+            Just url -> tda [theclass "declbut"] <<
+                          (anchor ! [href (spliceURL url)]
+                            << toHtml "Source")
+        wikiLink =
+          case maybe_wiki_url of
+            Nothing  -> Html.emptyTable
+            Just url -> tda [theclass "declbut"] <<
+                          (anchor ! [href (spliceURL url)]
+                            << toHtml "Comments")
+  
+        spliceURL url = run url
+          where run "" = ""
+                run ('%':'M':rest) = mod ++ run rest
+                run ('%':'N':rest) = escapeStr (hsNameStr name) ++ run rest
+                run ('%':'F':rest) = fname ++ run rest
+	        run (c:rest) = c : run rest
+
+        Module mod = iface_module iface
+        mod' = map (\x -> if x == '.' then '/' else x) mod
 
 -- a box for displaying an 'argument' (some code which has text to the
 -- right of it).  Wrapping is not allowed in these boxes, whereas it is
diff --git a/src/HaddockLex.x b/src/HaddockLex.x
index 1044d64a..f5e40942 100644
--- a/src/HaddockLex.x
+++ b/src/HaddockLex.x
@@ -142,7 +142,7 @@ ident str sc cont =
 
 strToHsQNames :: String -> Maybe [HsQName]
 strToHsQNames str0
- = case lexer (\t -> returnP t) str0 (SrcLoc 1 1) 1 1 [] of
+ = case lexer (\t -> returnP t) str0 (SrcLoc 1 1 "") 1 1 "" [] of
 	Ok _ (VarId str)
 	   -> Just [ UnQual (HsVarName (HsIdent str)) ]
         Ok _ (QVarId (mod0,str))
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index f005332c..990d2408 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -25,6 +25,11 @@ data Interface
 	iface_filename :: FilePath,
 		-- ^ the filename that contains the source code for this module
 
+	iface_orig_filename :: FilePath,
+		-- ^ the original filename for this module, which may be
+                -- different to the 'iface_filename' (for example the original
+                -- file may have had a .lhs or .hs.pp extension).
+
 	iface_module :: Module,
 
 	iface_package :: Maybe String,
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index d9c4635f..47ee75f5 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -218,45 +218,49 @@ tAB_LENGTH = 8
 
 
 lexer :: (Token -> P a) -> P a
-lexer cont input (SrcLoc _ x0) y0 col =
+lexer cont input (SrcLoc _ x0 _) y0 col f =
         if col == 0
-           then tab y0 x0  True  input
-           else tab y0 col False input -- throw away old x
+           then tab y0 x0  f True  input
+           else tab y0 col f False input -- throw away old x
   where
    	-- move past whitespace and comments
-        tab y x _ [] = 
-        	cont EOF [] (SrcLoc y x) col y
-        tab y x bol ('\t':s) =
-        	tab y (nextTab x) bol s
-        tab y _ _  ('\n':s) =
-                newLine cont s y
-
-        tab y _ True ('#':s)
+        tab y x f _ [] = 
+        	cont EOF [] (SrcLoc y x f) y col f
+        tab y x f bol ('\t':s) =
+        	tab y (nextTab x) f bol s
+        tab y _ f _  ('\n':s) =
+                newLine cont s y f
+
+        tab y _ f True ('#':s)
             | "pragma GCC set_debug_pwd" `isPrefixOf` s
-            = newLine cont (tail $ dropWhile (/= '\n') s) y
+            = newLine cont (tail $ dropWhile (/= '\n') s) y f
+
+	tab y x f True ('#':' ':s@(d:_))
+	    | isDigit d = parseLinePragma tab y f s
 
 	-- single-line comments
-        tab y x bol s@('-':'-':' ':c:_) | doc c = 
-	 	is_a_token bol s y x
-        tab y _ _ ('-':'-':s) | null s || not (isSymbol (head (dropWhile (== '-') s)))  =
-        	newLine cont (drop 1 (dropWhile (/= '\n') s)) y
+        tab y x f bol s@('-':'-':' ':c:_) | doc c = 
+	 	is_a_token bol s y x f
+        tab y _ f _ ('-':'-':s) | null s || not (isSymbol (head (dropWhile (== '-') s)))  =
+        	newLine cont (drop 1 (dropWhile (/= '\n') s)) y f
 
-	-- multi-line nested comments
-	tab y x bol s@('{':'-':c:_) | doc c && c /= '#' = 
-		is_a_token bol s y x
-	tab y x bol s@('{':'-':' ':c:_) | doc c = 
-		is_a_token bol s y x
-        tab y x bol ('{':'-':s) = nestedComment tab y x bol s
+	-- multi-line nested comments and pragmas
+	tab y x f bol ('{':'-':'#':s) = pragma tab y (x+3) f bol s
+	tab y x f bol s@('{':'-':c:_) | doc c = 
+		is_a_token bol s y x f
+	tab y x f bol s@('{':'-':' ':c:_) | doc c = 
+		is_a_token bol s y x f
+        tab y x f bol ('{':'-':s) = nestedComment (\y x -> tab y x f) y (x+2) bol s
 
-        tab y x bol (c:s)
-        	| isWhite c = tab y (x+1) bol s
-        	| otherwise = is_a_token bol (c:s) y x
+        tab y x f bol (c:s)
+        	| isWhite c = tab y (x+1) f bol s
+        	| otherwise = is_a_token bol (c:s) y x f
 
- 	is_a_token bol s y x
-	   | bol       = lexBOL   cont s (SrcLoc y x) y x
-	   | otherwise = lexToken cont s (SrcLoc y x) y x
+ 	is_a_token bol s y x f
+	   | bol       = lexBOL   cont s (SrcLoc y x f) y x f
+	   | otherwise = lexToken cont s (SrcLoc y x f) y x f
 
-	newLine _ s y =  tab (y+1) 1 True s
+	newLine _ s y f =  tab (y+1) 1 f True s
 
 	doc '|' = True
 	doc '/' = True
@@ -273,19 +277,19 @@ nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)
 -- insert virtual semicolons or close braces due to layout.
 
 lexBOL :: (Token -> P a) -> P a
-lexBOL cont s loc y x context =
+lexBOL cont s loc y x f context =
         if need_close_curly then 
                 -- trace "layout: inserting '}'\n" $
         	-- Set col to 0, indicating that we're still at the
         	-- beginning of the line, in case we need a semi-colon too.
         	-- Also pop the context here, so that we don't insert
         	-- another close brace before the parser can pop it.
-        	cont VRightCurly s loc y 0 (tail context)
+        	cont VRightCurly s loc y 0 f (tail context)
         else if need_semi_colon then
                 --trace "layout: inserting ';'\n" $
-        	cont SemiColon s loc y x context
+        	cont SemiColon s loc y x f context
         else
-        	lexToken cont s loc y x context
+        	lexToken cont s loc y x f context
  where
         need_close_curly =
         	case context of
@@ -303,7 +307,7 @@ lexBOL cont s loc y x context =
 lexToken :: (Token -> P a) -> P a
 --lexToken _    [] loc _ _ =
 --    error $ "Internal error: empty input in lexToken at " ++ show loc
-lexToken cont s0 loc y x =
+lexToken cont s0 loc y x f =
    -- trace ("lexer: y="++show y++" x="++show x++"\n") $ 
    case s0 of
         []            -> error $ "Internal error: empty input in lexToken at "
@@ -330,20 +334,20 @@ lexToken cont s0 loc y x =
                                []       -> error "Internal error: empty context in lexToken"
 
         '?':s:ss  
-	  | isIdentInitial s -> lexToken ( \ (VarId x) -> cont (IPVarId x)) (s:ss) loc y x
-        '\'':s -> lexChar cont s loc y (x+1)
-        '\"':s{-"-} -> lexString cont s loc y (x+1)
+	  | isIdentInitial s -> lexToken ( \ (VarId x) -> cont (IPVarId x)) (s:ss) loc y x f
+        '\'':s -> lexChar cont s loc y (x+1) f
+        '\"':s{-"-} -> lexString cont s loc y (x+1) f
 
         '0':'x':c:s | isHexDigit c -> 
 	   let (num, rest) = span isHexDigit (c:s)
 	       [(i,_)] = readHex num
 	   in
-	   afterNum cont i rest loc y (x+length num)
+	   afterNum cont i rest loc y (x+length num) f
         '0':'o':c:s | isOctDigit c -> 
 	   let (num, rest) = span isOctDigit (c:s)
 	       [(i,_)] = readOct num
 	   in
-	   afterNum cont i rest loc y (x+length num)
+	   afterNum cont i rest loc y (x+length num) f
 
         c:s | isIdentInitial c ->
         	let 
@@ -355,7 +359,7 @@ lexToken cont s0 loc y x =
         		Just keyword -> forward l_id keyword rest
         		Nothing      -> forward l_id (VarId id0) rest
 
-          | isUpper c -> lexCon "" cont (c:s) loc y x
+          | isUpper c -> lexCon "" cont (c:s) loc y x f
           | isSymbol c ->
         	let
         	    (symtail, rest) = span isSymbol s
@@ -368,42 +372,42 @@ lexToken cont s0 loc y x =
         			':' -> forward l_sym (ConSym sym) rest
         			_   -> forward l_sym (VarSym sym) rest
 
-          | isDigit c -> lexNum cont c s loc y x
+          | isDigit c -> lexNum cont c s loc y x f
 
           | otherwise ->
         	parseError ("illegal character \'" ++ show c ++ "\'\n") 
-        		  s loc y x
+        		  s loc y x f
 
-  where forward n t str = cont t str loc y (x+n)
+  where forward n t str = cont t str loc y (x+n) f
 
 	-- this is all terribly ugly, sorry :(
-	do_doc ('|':s) nested  = multi nested DocCommentNext  cont s loc y x
-	do_doc ('/':s) nested  = multi nested DocCommentNext  cont s loc y x
-	do_doc ('^':s) nested  = multi nested DocCommentPrev  cont s loc y x
-	do_doc ('$':s) nested  = multi nested DocCommentNamed cont s loc y x
-	do_doc ('#':s) nested  = multi nested DocOptions      cont s loc y x
+	do_doc ('|':s) nested  = multi nested DocCommentNext  cont s loc y x f
+	do_doc ('/':s) nested  = multi nested DocCommentNext  cont s loc y x f
+	do_doc ('^':s) nested  = multi nested DocCommentPrev  cont s loc y x f
+	do_doc ('$':s) nested  = multi nested DocCommentNamed cont s loc y x f
+	do_doc ('#':s) nested  = multi nested DocOptions      cont s loc y x f
 	do_doc ('*':s) nested  = section 1 s
 	  where section n ('*':s1) = section (n+1) s1
 		section n s1 
-		 | nested    = nestedDocComment  (DocSection n) cont s1 loc y x
-		 | otherwise = oneLineDocComment (DocSection n) cont s1 loc y x
+		 | nested    = nestedDocComment  (DocSection n) cont s1 loc y x f
+		 | otherwise = oneLineDocComment (DocSection n) cont s1 loc y x f
 	do_doc _       _ = error "Internal error: HsLexer.do_doc"
         
 
-multi :: Num a => Bool -> ([Char] -> b)
-      -> (b -> [Char] -> c -> a -> Int -> d)
-      -> [Char] -> c -> a -> Int -> d
+multi :: Bool -> ([Char] -> b)
+      -> (b -> [Char] -> c -> Int -> Int -> d)
+      -> [Char] -> c -> Int -> Int -> d
 multi True  = nestedDocComment
 multi False = multiLineDocComment
 
-afterNum :: Num a => (Token -> [Char] -> b -> c -> a -> d)
-	 -> Integer -> [Char] -> b -> c -> a -> d
-afterNum cont i ('#':s) loc y x = cont (PrimInt i) s loc y (x+1)
-afterNum cont i s loc y x = cont (IntTok i) s loc y x
+afterNum :: Num a => (Token -> [Char] -> b -> c -> a -> d -> e)
+	 -> Integer -> [Char] -> b -> c -> a -> d -> e
+afterNum cont i ('#':s) loc y x f = cont (PrimInt i) s loc y (x+1) f
+afterNum cont i s loc y x f = cont (IntTok i) s loc y x f
 
-lexNum :: (Token -> [Char] -> a -> b -> Int -> c)
-       -> Char -> [Char] -> a -> b -> Int -> c
-lexNum cont c0 s0 loc y x = 
+lexNum :: (Token -> [Char] -> a -> b -> Int -> c -> d)
+       -> Char -> [Char] -> a -> b -> Int -> c -> d
+lexNum cont c0 s0 loc y x fname = 
   let (num, after_num) = span isDigit (c0:s0)
   in
   case after_num of
@@ -433,11 +437,11 @@ lexNum cont c0 s0 loc y x =
 	    x' = x + length f
 
 	in case after_exp of -- glasgow exts only
-		'#':'#':s -> cont (PrimDouble f) s loc y x'
-		'#':s     -> cont (PrimFloat f)  s loc y x'
-		s         -> cont (FloatTok f)   s loc y x'
+		'#':'#':s -> cont (PrimDouble f) s loc y x' fname
+		'#':s     -> cont (PrimFloat f)  s loc y x' fname
+		s         -> cont (FloatTok f)   s loc y x' fname
 
-    _ -> afterNum cont (parseInteger 10 num) after_num loc y (x + length num)
+    _ -> afterNum cont (parseInteger 10 num) after_num loc y (x + length num) fname
 
 		
 -- GHC extension: allow trailing '#'s in an identifier. 
@@ -455,11 +459,11 @@ slurphashes [] i = (reverse i, [])
 slurphashes ('#':cs) i = slurphashes cs ('#':i)
 slurphashes s i = (reverse i, s)
 
-lexCon :: [Char] -> (Token -> String -> a -> b -> Int -> c)
-       -> String -> a -> b -> Int -> c
-lexCon qual cont s0 loc y x =
+lexCon :: [Char] -> (Token -> String -> a -> b -> Int -> c -> d)
+       -> String -> a -> b -> Int -> c -> d
+lexCon qual cont s0 loc y x f =
   let
-    forward n t s = cont t s loc y (x+n)
+    forward n t s = cont t s loc y (x+n) f
 
     (con, rest) = slurpIdent s0
     l_con = length con
@@ -485,7 +489,7 @@ lexCon qual cont s0 loc y x =
 	   _ -> forward (l_con+1+l_id) (QVarId (qual', id0)) rest1
 
      | isUpper c1 ->	-- qualified conid?
-	lexCon qual' cont (c1:s1) loc y (x+l_con+1)
+	lexCon qual' cont (c1:s1) loc y (x+l_con+1) f
 
      | isSymbol c1 ->	-- qualified symbol?
 	let
@@ -505,28 +509,28 @@ lexCon qual cont s0 loc y x =
 
 
 lexChar :: (Token -> P a) -> P a
-lexChar cont s0 loc0 y x = case s0 of
-                    '\\':s1 -> (escapeChar s1 `thenP` \(e,s,i) _ _ _ _ ->
-                               charEnd e s loc0 y (x+i)) s1 loc0 y x
-                    c:s     -> charEnd c s loc0 y (x+1)
+lexChar cont s0 loc0 y x f = case s0 of
+                    '\\':s1 -> (escapeChar s1 `thenP` \(e,s,i) _ _ _ _ _ ->
+                               charEnd e s loc0 y (x+i) f) s1 loc0 y x f
+                    c:s     -> charEnd c s loc0 y (x+1) f
                     []      -> error "Internal error: lexChar"
 
-  where charEnd c ('\'':'#':s) = \loc y0 x0 -> cont (PrimChar c) s loc y0 (x0+2)
-	charEnd c ('\'':s) = \loc y0 x0 -> cont (Character c) s loc y0 (x0+1)
+  where charEnd c ('\'':'#':s) = \loc y0 x0 f0 -> cont (PrimChar c) s loc y0 (x0+2) f0
+	charEnd c ('\'':s) = \loc y0 x0 f0 -> cont (Character c) s loc y0 (x0+1) f0
         charEnd _ s = parseError "Improperly terminated character constant" s
 
 lexString :: (Token -> P a) -> P a
-lexString cont s0 loc y0 x0 = loop "" s0 x0 y0
+lexString cont s0 loc y0 x0 f0 = loop "" s0 x0 y0 f0
   where
-     loop e s1 x y = case s1 of
-            '\\':'&':s  -> loop e s (x+2) y
-            '\\':c:s | isSpace c -> stringGap e s (x+2) y
+     loop e s1 x y f = case s1 of
+            '\\':'&':s  -> loop e s (x+2) y f
+            '\\':c:s | isSpace c -> stringGap e s (x+2) y f
         	     | otherwise -> (escapeChar (c:s) `thenP` \(e',s2,i) _ _ _ _ ->
-        		             loop (e':e) s2 (x+i) y) s loc y x
-            '\"':'#':s  -> cont (PrimString (reverse e)) s loc y (x+2)
-            '\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1)
-            c:s		-> loop (c:e) s (x+1) y
-            []          -> parseError "Improperly terminated string" s1 loc y x
+        		             loop (e':e) s2 (x+i) y) s loc y x f
+            '\"':'#':s  -> cont (PrimString (reverse e)) s loc y (x+2) f
+            '\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1) f
+            c:s		-> loop (c:e) s (x+1) y f
+            []          -> parseError "Improperly terminated string" s1 loc y x f
 
      stringGap e s1 x y = case s1 of
         	'\n':s -> stringGap e s 1 (y+1)
@@ -617,8 +621,35 @@ cntrl :: String -> P (Char,String,Int)
 cntrl (c:s) | c >= '@' && c <= '_' = returnP (chr (ord c - ord '@'), s,2)
 cntrl _                            = parseError "Illegal control character"
 
-nestedComment :: Num a => (a -> Int -> Bool -> [Char] -> b)
-	      -> a -> Int -> Bool -> [Char] -> b
+
+pragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
+       -> Int -> Int -> FilePath -> Bool -> [Char] -> b
+pragma cont y x f bol s0 =
+   case span (==' ') s0 of
+      (_, 'L':'I':'N':'E':' ':s) -> parseLinePragma cont y f s
+      (_, 'l':'i':'n':'e':' ':s) -> parseLinePragma cont y f s
+      (sp,s) -> nestedComment (\y x -> cont y x f) y (x+length sp) bol s
+
+parseLinePragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
+                -> Int -> FilePath -> [Char] -> b
+parseLinePragma cont y fname s0 =
+		cont y' 1 fname' True (drop 1 (dropWhile (/= '\n') s0))
+
+  where  s1            = dropWhite s0
+         (lineStr, s2) = span isDigit s1
+         y'            = case reads lineStr of
+	                   ((y',_):_) -> y'
+			   _          -> y
+         s3            = dropWhite s2
+	 fnameStr      = takeWhile (\c -> c /= '"') (tail s3)
+         fname'        | null s3 || head s3 /= '"' = fname
+                       -- try and get more sharing of file name strings
+                       | fnameStr == fname         = fname
+                       | otherwise                 = fnameStr
+         dropWhite = dropWhile (\c -> c == ' ' || c == '\t')
+
+nestedComment :: (Int -> Int -> Bool -> [Char] -> b)
+	      -> Int -> Int -> Bool -> [Char] -> b
 nestedComment cont y x bol s0 =
    case s0 of
       '-':'}':s -> cont y (x+2) bol s
@@ -628,9 +659,9 @@ nestedComment cont y x bol s0 =
       _:s       -> nestedComment cont y (x+1) bol s
       []        -> error "Internal error: nestedComment"
 
-nestedDocComment :: Num a => ([Char] -> b)
-		 -> (b -> [Char] -> c -> a -> Int -> d)
-                 -> [Char] -> c -> a -> Int -> d
+nestedDocComment :: ([Char] -> b)
+		 -> (b -> [Char] -> c -> Int -> Int -> d)
+                 -> [Char] -> c -> Int -> Int -> d
 nestedDocComment f0 cont0 s0 loc y0 x0 = go f0 cont0 "" y0 x0 s0
  where
   go f cont acc y1 x1 s1 = 
diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs
index 748fbad1..f1423f6f 100644
--- a/src/HsParseMonad.lhs
+++ b/src/HsParseMonad.lhs
@@ -27,14 +27,15 @@ type P a
      -> SrcLoc			-- location of last token read
      -> Int			-- current line
      -> Int			-- current column
+     -> FilePath		-- current original filename
      -> ParseState		-- layout info.
      -> ParseResult a
 
 thenP :: P a -> (a -> P b) -> P b
-m `thenP` k = \i l n c s0 -> 
-	case m i l n c s0 of 
+m `thenP` k = \i l n c f s0 -> 
+	case m i l n c f s0 of 
 	    Failed s -> Failed s
-	    Ok s' a -> case k a of k' -> k' i l n c s'
+	    Ok s' a -> case k a of k' -> k' i l n c f s'
 
 thenP_ :: P a -> P b -> P b
 m `thenP_` k = m `thenP` \_ -> k
@@ -47,24 +48,24 @@ mapP f (a:as) =
      returnP (b:bs)
 
 returnP :: a -> P a
-returnP a = \_ _ _ _ s -> Ok s a
+returnP a = \_ _ _ _ _ s -> Ok s a
 
 failP :: String -> P a
-failP err = \_ _ _ _ _ -> Failed err
+failP err = \_ _ _ _ _ _ -> Failed err
 
 getSrcLoc :: P SrcLoc
-getSrcLoc = \_ l _ _ s -> Ok s l
+getSrcLoc = \_ l _ _ _ s -> Ok s l
 
 getContext :: P [LexContext]
-getContext = \_ _ _ _ s -> Ok s s
+getContext = \_ _ _ _ _ s -> Ok s s
 
 pushContext :: LexContext -> P ()
 pushContext ctxt = 
 --trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
-	\_ _ _ _ s -> Ok (ctxt:s) ()
+	\_ _ _ _ _ s -> Ok (ctxt:s) ()
 
 popContext :: P ()
-popContext = \_ _ _ _ stk ->
+popContext = \_ _ _ _ _ stk ->
       case stk of
    	(_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ 
             Ok s ()
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index 5498cfd3..58f7f763 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -43,8 +43,8 @@ import Ratio
 
 \begin{code}
 parseError :: String -> P a
-parseError s = \r (SrcLoc y x) -> 
-    failP (show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x)
+parseError s = \r (SrcLoc y x f) -> 
+    failP (show f ++ ": " ++ show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x f)
 
 splitTyConApp :: HsType -> P (HsName,[HsType])
 splitTyConApp t0 = split t0 []
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 21561e0a..b62f1cae 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -149,12 +149,12 @@ Reserved Ids
 Module Header
 
 > module :: { HsModule }
-> 	: optdoc 'module' modid maybeexports 'where' body
+> 	: optdoc 'module' srcloc modid maybeexports 'where' body
 >	    { case $1 of { (opts,info,doc) ->
->	      HsModule $3 $4 (reverse (fst $6)) (snd $6)
+>	      HsModule $3 $4 $5 (reverse (fst $7)) (snd $7)
 >		opts info doc } }
->	| body
->	    { HsModule main_mod Nothing (reverse (fst $1)) (snd $1)
+>	| body srcloc
+>	    { HsModule $2 main_mod Nothing (reverse (fst $1)) (snd $1)
 >		Nothing emptyModuleInfo Nothing }
 
 > optdoc :: { (Maybe String,ModuleInfo,Maybe Doc) }
@@ -951,7 +951,7 @@ Layout
 >	: vccurly		{ () } -- context popped in lexer.
 >	| error			{% popContext }
 
-> layout_on  :: { () }	:	{% getSrcLoc `thenP` \(SrcLoc r c) ->
+> layout_on  :: { () }	:	{% getSrcLoc `thenP` \(SrcLoc r c f) ->
 >				   pushContext (Layout c) }
 
 -----------------------------------------------------------------------------
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 82f89da9..cb5ec11e 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -41,7 +41,7 @@ module HsSyn (
 
 import Char (isSpace)
 
-data SrcLoc = SrcLoc Int Int -- (Line, Indentation)
+data SrcLoc = SrcLoc !Int !Int FilePath -- (Line, Indentation, FileName)
   deriving (Eq,Ord,Show)
 
 newtype Module = Module String
@@ -80,7 +80,7 @@ instance Show HsIdentifier where
    showsPrec _ (HsSymbol s) = showString s
    showsPrec _ (HsSpecial s) = showString s
 
-data HsModule = HsModule Module (Maybe [HsExportSpec])
+data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec])
                         [HsImportDecl] [HsDecl] 
 			(Maybe String)		-- the doc options
 			ModuleInfo      	-- the info (portability etc.)
diff --git a/src/Main.hs b/src/Main.hs
index 70c2dd58..1f76fe47 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -334,7 +334,7 @@ parse_file file = do
     (openFile file ReadMode)
     (\h -> hClose h)
     (\h -> do stuff <- hGetContents h 
-	      case parse stuff (SrcLoc 1 1) 1 0 [] of
+	      case parse stuff (SrcLoc 1 1 file) 1 0 file [] of
 	        Ok _ e -> return e
 	        Failed err -> die (file ++ ':':err ++ "\n")
     )
@@ -425,7 +425,8 @@ mkInterfacePhase1
    -> ErrMsgM Interface			-- the "interface" of the module
 
 mkInterfacePhase1 flags verbose mod_map filename package
-	(HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do  
+	(HsModule (SrcLoc _ _ orig_filename) mdl exps imps decls
+                  maybe_opts maybe_info maybe_doc) = do
 
   let
       no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
@@ -466,7 +467,7 @@ mkInterfacePhase1 flags verbose mod_map filename package
 	| no_implicit_prelude || any is_prel_import imps = imps
 	| otherwise = HsImportDecl loc prelude_mod False Nothing Nothing : imps
 	where 
-		loc = SrcLoc 0 0
+		loc = SrcLoc 0 0 ""
 	 	is_prel_import (HsImportDecl _ mdl0 _ _ _ ) = mdl0 == prelude_mod
   -- in
 
@@ -542,6 +543,7 @@ mkInterfacePhase1 flags verbose mod_map filename package
 
   return (Interface { 
 		   iface_filename     = filename,
+                   iface_orig_filename= orig_filename,
 		   iface_module	      = mdl,
 		   iface_package      = package,
 		   iface_env          = name_env,
@@ -1182,12 +1184,12 @@ sortModules mdls = mapM for_each_scc sccs
 
 	edges :: [((HsModule,FilePath), Module, [Module])]
 	edges = [ ((hsmod,file), mdl, get_imps impdecls)
-		| (hsmod@(HsModule mdl _ impdecls _ _ _ _), file) <- mdls
+		| (hsmod@(HsModule _ mdl _ impdecls _ _ _ _), file) <- mdls
 		]
 
         get_imps impdecls  = [ imp | HsImportDecl _ imp _ _ _ <- impdecls  ]
 
-	get_mods hsmodules = [ mdl | HsModule mdl _ _ _ _ _ _ <- hsmodules ]
+	get_mods hsmodules = [ mdl | HsModule _ mdl _ _ _ _ _ _ <- hsmodules ]
 
 	for_each_scc (AcyclicSCC hsmodule) = return hsmodule
 	for_each_scc (CyclicSCC  hsmodules) = 
@@ -1351,6 +1353,7 @@ to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) =
    Interface { 
       iface_module	 = mdl,
       iface_filename     = "",
+      iface_orig_filename= "",
       iface_package      = package,
       iface_env          = Map.fromList env,
       iface_sub          = Map.fromList sub,
@@ -1369,6 +1372,7 @@ to_interface2 (mdl,descriptionOpt,package, hide, env, sub) =
    Interface { 
       iface_module	 = mdl,
       iface_filename     = "",
+      iface_orig_filename= "",
       iface_package      = package,
       iface_env          = 
 	Map.fromList [(n,Qual mdl n) | (n,mdl) <- env],
@@ -1388,6 +1392,7 @@ nullVersion_to_interface (mdl, package, hide, env, reexported, sub) =
    Interface { 
       iface_module	 = mdl,
       iface_filename     = "",
+      iface_orig_filename= "",
       iface_package      = package,
       iface_env          = Map.fromList env,
       iface_sub          = Map.fromList sub,