diff options
| -rw-r--r-- | src/HaddockHtml.hs | 147 | ||||
| -rw-r--r-- | src/HaddockLex.x | 2 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 5 | ||||
| -rw-r--r-- | src/HsLexer.lhs | 209 | ||||
| -rw-r--r-- | src/HsParseMonad.lhs | 19 | ||||
| -rw-r--r-- | src/HsParseUtils.lhs | 4 | ||||
| -rw-r--r-- | src/HsParser.ly | 10 | ||||
| -rw-r--r-- | src/HsSyn.lhs | 4 | ||||
| -rw-r--r-- | src/Main.hs | 15 |
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, |