aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs43
-rw-r--r--src/Haddock/Interface/LexParseRn.hs24
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs9
3 files changed, 40 insertions, 36 deletions
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,
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 01:46:43 +0000