aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs200
-rw-r--r--src/Haddock/Interface/LexParseRn.hs1
-rw-r--r--src/Haddock/Interface/Rename.hs3
3 files changed, 128 insertions, 76 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 580aaa83..06d97265 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -34,7 +34,9 @@ import GHC hiding (flags)
import HscTypes
import Name
import Bag
-import RdrName (GlobalRdrEnv)
+import RdrName
+import TcRnTypes (tcg_warns)
+import FastString (unpackFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -49,6 +51,7 @@ createInterface tm flags modMap instIfaceMap = do
dflags = ms_hspp_opts ms
instances = modInfoInstances mi
exportedNames = modInfoExports mi
+ warnings = tcg_warns . fst . tm_internals_ $ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -68,16 +71,21 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+ (info, mbDoc) <- do
+ (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+ return (i, addModuleWarning warnings d)
let declsWithDocs = topDecls group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
- maps@(docMap, argMap, subMap, declMap) <-
+ (docMap0, argMap, subMap, declMap) <-
liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
- let exports0 = fmap (reverse . map unLoc) mayExports
+ let docMap = addWarnings warnings gre exportedNames docMap0
+ maps = (docMap, argMap, subMap, declMap)
+
+ exports0 = fmap (reverse . map unLoc) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
@@ -90,18 +98,16 @@ createInterface tm flags modMap instIfaceMap = do
let visibleNames = mkVisibleNames exportItems opts
-- Measure haddock documentation coverage.
- let
- prunedExportItems0 = pruneExportItems exportItems
- haddockable = 1 + length exportItems -- module + exports
- haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
- coverage = (haddockable, haddocked)
+ let prunedExportItems0 = pruneExportItems exportItems
+ haddockable = 1 + length exportItems -- module + exports
+ haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+ coverage = (haddockable, haddocked)
-- Prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
- let
- prunedExportItems
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
+ let prunedExportItems
+ | OptPrune `elem` opts = prunedExportItems0
+ | otherwise = exportItems
return Interface {
ifaceMod = mdl,
@@ -126,6 +132,40 @@ createInterface tm flags modMap instIfaceMap = do
-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+
+-- | 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 mappend) dm wm
+ where
+ wm = M.fromList
+ [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+
+
+addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
+addModuleWarning ws =
+ case ws of
+ NoWarnings -> id
+ WarnSome _ -> id
+ WarnAll w -> let d = warnToDoc w in Just . maybe d (mappend d)
+
+
+warnToDoc :: WarningTxt -> Doc id
+warnToDoc w = case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " msg
+ (WarningTxt msg) -> format "Warning: " msg
+ where
+ format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
+
+
+-------------------------------------------------------------------------------
-- Doc options
--
-- Haddock options that are embedded in the source file
@@ -160,43 +200,44 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
-mkMaps :: DynFlags -> GlobalRdrEnv -> [Instance] -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps
+mkMaps :: DynFlags
+ -> GlobalRdrEnv
+ -> [Instance]
+ -> [Name]
+ -> [(LHsDecl Name, [HsDocString])]
+ -> ErrMsgM Maps
mkMaps dflags gre instances exports decls = do
- maps <- mapM f decls
- let mergeMaps (a,b,c,d) (x,y,z,w) =
- (M.unionWith mappend a x, M.unionWith mappend b y,
- M.unionWith mappend c z, M.unionWith mappend d w)
- let emptyMaps = (M.empty, M.empty, M.empty, M.empty)
- return (foldl' mergeMaps emptyMaps maps)
+ (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls
+ let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith mappend . concat
+ return (f dm, f am, f sm, f cm)
where
- instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
-
- f :: (LHsDecl Name, [HsDocString]) -> ErrMsgM Maps
- f (decl@(L _ d), docs) = do
- mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
- argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs d) $
- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
+ mappings (ldecl@(L _ decl), docs) = do
+ doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
+ argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $
+ lexParseRnHaddockComment dflags NormalHaddockComment gre
- let subs_ = subordinates d
- let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_
+ let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ]
- (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do
+ (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do
mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr
subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $
- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
- return ((name, mbSubDoc), (name, subFnArgsDoc)))
+ lexParseRnHaddockComment dflags NormalHaddockComment gre
+ return ((n, mbSubDoc), (n, subFnArgsDoc)))
- let subNames = map fst subDocs
+ let names = case decl of
+ -- See note [2].
+ InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap)
+ _ -> filter (`elem` exports) (getMainDeclBinder decl)
- let names = case d of
- InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2].
- _ -> filter (`elem` exports) (getMainDeclBinder d)
+ let subNames = map fst subDocs
+ dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ]
+ am = [ (n, argDocs) | n <- names ] ++ subArgMap
+ sm = [ (n, subNames) | n <- names ]
+ cm = [ (n, [ldecl]) | n <- names ++ subNames ]
+ return (dm, am, sm, cm)
- let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs))
- let argMap' = M.fromList [ (n, argDocs) | n <- names ] `mappend` M.fromList subArgMap
- let subMap' = M.fromList [ (n, subNames) | n <- names ]
- let dclMap' = M.fromList [ (n, [decl]) | n <- names ++ subNames ]
- return (docMap', argMap', subMap', dclMap')
+ instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
-- Note [2]:
@@ -393,18 +434,10 @@ mkExportItems
(maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags gre maps decls
- Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
+ Just exports -> liftM concat $ mapM lookupExport exports
where
decls = filter (not . isInstD . unLoc) decls0
- -- A type signature can have multiple names, like:
- -- foo, bar :: Types..
- -- When going throug the exported names we have to take care to detect such
- -- situations and remove the duplicates.
- commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =
- getMainDeclBinder sig1 == getMainDeclBinder sig2
- commaDeclared _ _ = False
-
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
@@ -433,13 +466,12 @@ mkExportItems
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
- let (doc, subs) = exportDecl t docMap argMap subMap in
case findDecl t of
- [L _ (ValD _)] -> do
+ ([L _ (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem t doc
return [export]
- ds | decl : _ <- filter (not . isValD . unLoc) ds ->
+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
in case () of
_
@@ -461,21 +493,20 @@ mkExportItems
return []
-- normal case
- | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ]
+ | otherwise -> return [ mkExportDecl t newDecl docs_ ]
where
- -- Since a single signature might refer to many names, we
- -- need to filter the ones that are actually exported. This
- -- requires modifying the type signatures to "hide" the
- -- names that are not exported.
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
newDecl = case decl of
(L loc (SigD sig)) ->
- L loc . SigD . fromJust $ filterSigNames isExported sig
+ L loc . SigD . fromJust $ filterSigNames (== t) sig
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
_ -> decl
-- Declaration from another package
- [] -> do
+ ([], _) -> do
mayDecl <- hiDecl t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
@@ -489,7 +520,7 @@ mkExportItems
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
return [ mkExportDecl t decl (noDocForDecl, subs_) ]
Just iface -> do
- return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
@@ -506,13 +537,15 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> [LHsDecl Name]
- findDecl name
- | mdl == thisMod = maybe [] id (M.lookup name declMap)
- | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface))
- | otherwise = []
+ 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)
+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+ (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+ | otherwise = ([], (noDocForDecl, []))
where
- mdl = nameModule name
+ m = nameModule n
hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
@@ -533,12 +566,14 @@ hiValExportItem name doc = do
Just decl -> return (ExportDecl decl doc [] [])
-exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-exportDecl name docMap argMap subMap =
- let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
- let doc = (M.lookup name docMap, lookupArgMap name) in
- let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
- (doc, subs)
+-- | Lookup docs for a declaration from maps.
+lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n docMap argMap subMap =
+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+ let doc = (M.lookup n docMap, lookupArgDoc n) in
+ let subs = M.findWithDefault [] n subMap in
+ let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in
+ (doc, subDocs)
-- | Return all export items produced by an exported module. That is, we're
@@ -605,8 +640,21 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
- liftM catMaybes $ mapM mkExportItem decls
+ liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ --
+ -- We go through the list of declarations and expand type signatures, so
+ -- that every type signature has exactly one name!
+ expandSig :: [LHsDecl name] -> [LHsDecl name]
+ expandSig = foldr f []
+ where
+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f x xs = x : xs
+
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
return $ fmap (ExportGroup lev "") mbDoc
@@ -616,12 +664,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, _) = exportDecl name docMap argMap subMap in
+ let (doc, _) = lookupDocs name docMap argMap subMap in
fmap Just (hiValExportItem name doc)
| otherwise = return Nothing
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
- let (doc, subs) = exportDecl name docMap argMap subMap in
+ let (doc, subs) = lookupDocs name docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [])
| otherwise = return Nothing
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index f70c5953..ebd2b8fc 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -108,6 +108,7 @@ rename gre = rn
a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
-- If an id can refer to multiple things, we give precedence to type
-- constructors.
+ DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
DocMonospaced doc -> DocMonospaced (rn doc)
DocUnorderedList docs -> DocUnorderedList (map rn docs)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 691dafbc..582c2ccd 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -169,6 +169,9 @@ renameDoc d = case d of
return (DocIdentifier x')
DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
DocModule str -> return (DocModule str)
+ DocWarning doc -> do
+ doc' <- renameDoc doc
+ return (DocWarning doc')
DocEmphasis doc -> do
doc' <- renameDoc doc
return (DocEmphasis doc')
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-04 00:32:44 +0000