diff options
author | David Waern <david.waern@gmail.com> | 2010-04-10 10:46:14 +0000 |
---|---|---|
committer | David Waern <david.waern@gmail.com> | 2010-04-10 10:46:14 +0000 |
commit | a2a41c8b812cbc55d4541cec3285ee32f863a227 (patch) | |
tree | 786745653693708cd8fe1cf11a981b8d6dabafff /src/Haddock | |
parent | 6f47cab6685dd30c9795fe56eb947cd94c7255ee (diff) |
Fix #112
No link was generated for 'Addr#' in a doc comment. The reason was simply that
the identifier didn't parse. We were using parseIdentifier from the GHC API,
with a parser state built from 'defaultDynFlags'. If we pass the dynflags of
the module instead, the right options are turned on on while parsing the
identifer (in this case -XMagicHash), and the parse succeeds.
Diffstat (limited to 'src/Haddock')
-rw-r--r-- | src/Haddock/Interface.hs | 3 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 43 | ||||
-rw-r--r-- | src/Haddock/Interface/LexParseRn.hs | 24 | ||||
-rw-r--r-- | src/Haddock/Interface/ParseModuleHeader.hs | 9 | ||||
-rw-r--r-- | src/Haddock/Lex.x | 28 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 3 |
6 files changed, 58 insertions, 52 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 33a2f7de..477bf09d 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -153,7 +153,8 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { ghcExportedNames = modInfoExports modInfo, ghcDefinedNames = map getName $ modInfoTyThings modInfo, ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, - ghcInstances = modInfoInstances modInfo + ghcInstances = modInfoInstances modInfo, + ghcDynFlags = dynflags } where mbOpts = haddockOptions dynflags diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 7a0a2e16..4af90017 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -42,7 +42,8 @@ createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface ghcMod flags modMap instIfaceMap = do - let mdl = ghcModule ghcMod + let mdl = ghcModule ghcMod + dflags = ghcDynFlags ghcMod -- The pattern-match should not fail, because createInterface is only -- done on loaded modules. @@ -53,9 +54,10 @@ createInterface ghcMod flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader + + (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre (ghcMbDocHdr ghcMod) - decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod)) + decls0 <- liftErrMsg $ declInfos dflags gre (topDecls (ghcGroup ghcMod)) let instances = ghcInstances ghcMod localInsts = filter (nameIsLocalOrFrom mdl . getName) instances @@ -71,7 +73,7 @@ createInterface ghcMod flags modMap instIfaceMap = do liftErrMsg $ warnAboutFilteredDecls mdl decls0 exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap - opts exports ignoreExps instances instIfaceMap + opts exports ignoreExps instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -168,22 +170,22 @@ mkDeclMap decls = Map.fromList . concat $ , not (isDocD d), not (isInstD d) ] -declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] -declInfos gre decls = +declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] +declInfos dflags gre decls = forM decls $ \(parent@(L _ d), mbDocString) -> do - mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment + mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbDocString fnArgsDoc <- fmap (Map.mapMaybe id) $ Traversable.forM (getDeclFnArgDocs d) $ - \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc let subs_ = subordinates d subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do - mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment + mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr subFnArgsDoc <- fmap (Map.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc return (subName, (mbSubDoc, subFnArgsDoc)) return (parent, (mbDoc, fnArgsDoc), subs) @@ -431,10 +433,11 @@ mkExportItems -> Bool -- --ignore-all-exports flag -> [Instance] -> InstIfaceMap + -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems modMap this_mod gre exported_names decls declMap - opts maybe_exps ignore_all_exports _ instIfaceMap + opts maybe_exps ignore_all_exports _ instIfaceMap dflags | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) @@ -442,7 +445,7 @@ mkExportItems modMap this_mod gre exported_names decls declMap everything_local_exported = -- everything exported - liftErrMsg $ fullContentsOfThisModule gre decls + liftErrMsg $ fullContentsOfThisModule dflags gre decls lookupExport (IEVar x) = declWith x @@ -451,15 +454,15 @@ mkExportItems modMap this_mod gre exported_names decls declMap lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = fullContentsOf m lookupExport (IEGroup lev docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) (\docStr -> - ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ])) @@ -618,7 +621,7 @@ mkExportItems modMap this_mod gre exported_names decls declMap fullContentsOf modname - | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls + | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls | otherwise = case Map.lookup m modMap of Just iface @@ -666,14 +669,14 @@ mkExportItems modMap this_mod gre exported_names decls declMap -- (For more information, see Trac #69) -fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name] -fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls +fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name] +fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem decls where mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr + mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr + mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr return $ fmap ExportDoc mbDoc mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs [] diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 02fd4bc7..5b1dd8b5 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -31,20 +31,20 @@ import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment -lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockCommentList hty gre docStrs = do - docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs +lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) +lexParseRnHaddockCommentList dflags hty gre docStrs = do + docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs let docs = catMaybes docMbs let doc = foldl docAppend DocEmpty docs case doc of DocEmpty -> return Nothing _ -> return (Just doc) -lexParseRnHaddockComment :: HaddockCommentType -> +lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockComment hty gre (HsDocString fs) = do +lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do let str = unpackFS fs - let toks = tokenise str (0,0) -- TODO: real position + let toks = tokenise dflags str (0,0) -- TODO: real position let parse = case hty of NormalHaddockComment -> parseParas DocSectionComment -> parseString @@ -54,19 +54,19 @@ lexParseRnHaddockComment hty gre (HsDocString fs) = do return Nothing Just doc -> return (Just (rnDoc gre doc)) -lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnMbHaddockComment _ _ Nothing = return Nothing -lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d +lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) +lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing +lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d -- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -lexParseRnHaddockModHeader gre mbStr = do +lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +lexParseRnHaddockModHeader dflags gre mbStr = do let failure = (emptyHaddockModInfo, Nothing) case mbStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs - case parseModuleHeader str of + case parseModuleHeader dflags str of Left mess -> do tell ["haddock module header parse failed: " ++ mess] return failure diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index 2bdd30a7..c28effad 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -17,6 +17,7 @@ import Haddock.Lex import Haddock.Parse import RdrName +import DynFlags import Data.Char @@ -26,8 +27,8 @@ import Data.Char -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, Doc RdrName) -parseModuleHeader str0 = +parseModuleHeader :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName) +parseModuleHeader dflags str0 = let getKey :: String -> String -> (Maybe String,String) getKey key str = case parseKey key str of @@ -47,14 +48,14 @@ parseModuleHeader str0 = description1 = case descriptionOpt of Nothing -> Right Nothing -- TODO: pass real file position - Just description -> case parseString $ tokenise description (0,0) of + Just description -> case parseString $ tokenise dflags description (0,0) of Nothing -> Left ("Cannot parse Description: " ++ description) Just doc -> Right (Just doc) in case description1 of Left mess -> Left mess -- TODO: pass real file position - Right docOpt -> case parseParas $ tokenise str8 (0,0) of + Right docOpt -> case parseParas $ tokenise dflags str8 (0,0) of Nothing -> Left "Cannot parse header documentation paragraphs" Just doc -> Right (HaddockModInfo { hmi_description = docOpt, diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index fca2bf7f..e59b10ea 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -138,10 +138,10 @@ tokenPos t = let AlexPn _ line col = snd t in (line, col) -- Alex support stuff type StartCode = Int -type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> [LToken] +type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken] -tokenise :: String -> (Int, Int) -> [LToken] -tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks +tokenise :: DynFlags -> String -> (Int, Int) -> [LToken] +tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks where posn = AlexPn 0 line col @@ -150,41 +150,41 @@ tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-tra AlexEOF -> [] AlexError _ -> error "lexical error" AlexSkip inp' _ -> go inp' sc - AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) + AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags -- NB. we add a final \n to the string, (see comment in the beginning of line -- production above). eofHack str = str++"\n" andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont +andBegin act new_sc = \pos str _ cont dflags -> act pos str new_sc cont dflags token :: Token -> Action -token t = \pos _ sc cont -> (t, pos) : cont sc +token t = \pos _ sc cont _ -> (t, pos) : cont sc strtoken, strtokenNL :: (String -> Token) -> Action -strtoken t = \pos str sc cont -> (t str, pos) : cont sc -strtokenNL t = \pos str sc cont -> (t (filter (/= '\r') str), pos) : cont sc +strtoken t = \pos str sc cont _ -> (t str, pos) : cont sc +strtokenNL t = \pos str sc cont _ -> (t (filter (/= '\r') str), pos) : cont sc -- ^ We only want LF line endings in our internal doc string format, so we -- filter out all CRs. begin :: StartCode -> Action -begin sc = \_ _ _ cont -> cont sc +begin sc = \_ _ _ cont _ -> cont sc -- ----------------------------------------------------------------------------- -- Lex a string as a Haskell identifier ident :: Action -ident pos str sc cont = - case strToHsQNames id of +ident pos str sc cont dflags = + case strToHsQNames dflags id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str) -strToHsQNames :: String -> Maybe [RdrName] -strToHsQNames str0 = +strToHsQNames :: DynFlags -> String -> Maybe [RdrName] +strToHsQNames dflags str0 = let buffer = unsafePerformIO (stringToStringBuffer str0) - pstate = mkPState buffer noSrcLoc defaultDynFlags + pstate = mkPState buffer noSrcLoc dflags result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 610f958c..39209b17 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -156,7 +156,8 @@ data GhcModule = GhcModule { ghcExportedNames :: [Name], ghcDefinedNames :: [Name], ghcNamesInScope :: [Name], - ghcInstances :: [Instance] + ghcInstances :: [Instance], + ghcDynFlags :: DynFlags } |