aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface/Create.hs')
-rw-r--r--src/Haddock/Interface/Create.hs75
1 files changed, 35 insertions, 40 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index e2cc9959..1513349f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -72,28 +72,23 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- (info, mbDoc) <- do
- (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
- return (i, addModuleWarning warnings d)
+ (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
- (docMap0, argMap, subMap, declMap) <-
+ maps@(docMap, argMap, subMap, declMap) <-
liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
- let docMap = addWarnings warnings gre exportedNames docMap0
- maps = (docMap, argMap, subMap, declMap)
-
- exports0 = fmap (reverse . map unLoc) mayExports
+ let exports0 = fmap (reverse . map unLoc) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
liftErrMsg $ warnAboutFilteredDecls mdl decls
- exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
+ exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports
instances instIfaceMap dflags
let visibleNames = mkVisibleNames exportItems opts
@@ -117,8 +112,8 @@ createInterface tm flags modMap instIfaceMap = do
ifaceMod = mdl,
ifaceOrigFilename = msHsFilePath ms,
ifaceInfo = info,
- ifaceDoc = Documentation mbDoc,
- ifaceRnDoc = Documentation Nothing,
+ ifaceDoc = Documentation mbDoc (moduleWarning warnings),
+ ifaceRnDoc = Documentation Nothing Nothing,
ifaceOptions = opts,
ifaceDocMap = docMap,
ifaceArgMap = argMap,
@@ -169,25 +164,23 @@ lookupModuleDyn dflags Nothing mdlName =
-------------------------------------------------------------------------------
--- | Add warnings to documentation. If there is a warning for an identifier
--- with no documentation, create a piece of documentation that just contains
--- the warning.
-addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name
-addWarnings NoWarnings _ _ dm = dm
-addWarnings (WarnAll _) _ _ dm = dm
-addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm
+-- FIXME: simplify
+lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id)
+lookupWarning NoWarnings _ _ = Nothing
+lookupWarning (WarnAll _) _ _ = Nothing
+lookupWarning (WarnSome ws) gre name = M.lookup name wm
where
wm = M.fromList
[ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
+ , let n = gre_name elt, n == name ]
-addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
-addModuleWarning ws =
+moduleWarning :: Warnings -> Maybe (Doc id)
+moduleWarning ws =
case ws of
- NoWarnings -> id
- WarnSome _ -> id
- WarnAll w -> let d = warnToDoc w in Just . maybe d (d <>)
+ NoWarnings -> Nothing
+ WarnSome _ -> Nothing
+ WarnAll w -> Just (warnToDoc w)
warnToDoc :: WarningTxt -> Doc id
@@ -459,6 +452,7 @@ collectDocs = go Nothing []
mkExportItems
:: IfaceMap
-> Module -- this module
+ -> Warnings
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
-> [LHsDecl Name]
@@ -469,10 +463,10 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod gre exportedNames decls0
+ modMap thisMod warnings gre exportedNames decls0
(maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
case optExports of
- Nothing -> fullModuleContents dflags gre maps decls
+ Nothing -> fullModuleContents dflags warnings gre maps decls
Just exports -> liftM concat $ mapM lookupExport exports
where
decls = filter (not . isInstD . unLoc) decls0
@@ -483,7 +477,7 @@ mkExportItems
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
lookupExport (IEGroup lev docStr) = liftErrMsg $
ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
@@ -559,7 +553,7 @@ mkExportItems
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
return [ mkExportDecl t decl (noDocForDecl, subs_) ]
Just iface ->
- return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
@@ -579,9 +573,9 @@ mkExportItems
findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
| m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n docMap argMap subMap)
+ (ds, lookupDocs n warnings gre docMap argMap subMap)
| Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+ (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
| otherwise = ([], (noDocForDecl, []))
where
m = nameModule n
@@ -606,15 +600,15 @@ hiValExportItem name doc = do
-- | Lookup docs for a declaration from maps.
-lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs n docMap argMap subMap =
+lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings gre docMap argMap subMap =
let lookupArgDoc x = M.findWithDefault M.empty x argMap in
let doc = (lookupDoc n, lookupArgDoc n) in
let subs = M.findWithDefault [] n subMap in
let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
(doc, subDocs)
where
- lookupDoc = Documentation . (`M.lookup` docMap)
+ lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name)
-- | Return all export items produced by an exported module. That is, we're
@@ -633,6 +627,7 @@ lookupDocs n docMap argMap subMap =
moduleExports :: Module -- ^ Module A
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
+ -> Warnings
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
-> [LHsDecl Name] -- ^ All the declarations in A
@@ -640,8 +635,8 @@ moduleExports :: Module -- ^ Module A
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps
- | m == thisMod = fullModuleContents dflags gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
+ | m == thisMod = fullModuleContents dflags warnings gre maps decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -679,8 +674,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
+fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
-- A type signature can have multiple names, like:
@@ -705,12 +700,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
mkExportItem (L _ (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
- let (doc, _) = lookupDocs name docMap argMap subMap in
+ let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in
fmap Just (hiValExportItem name doc)
| otherwise = return Nothing
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
- let (doc, subs) = lookupDocs name docMap argMap subMap in
+ let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [])
| otherwise = return Nothing
@@ -774,7 +769,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
where
- hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d
+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 11:57:15 +0000