aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHtml.hs147
-rw-r--r--src/HaddockLex.x2
-rw-r--r--src/HaddockTypes.hs5
-rw-r--r--src/HsLexer.lhs209
-rw-r--r--src/HsParseMonad.lhs19
-rw-r--r--src/HsParseUtils.lhs4
-rw-r--r--src/HsParser.ly10
-rw-r--r--src/HsSyn.lhs4
-rw-r--r--src/Main.hs15
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,
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 20:39:17 +0000