aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs48
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs6
3 files changed, 45 insertions, 30 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index deef7ad3..a35e2053 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -46,7 +46,6 @@ import Data.Traversable
import Avail hiding (avail)
import qualified Avail
-import qualified Packages
import qualified Module
import qualified SrcLoc
import ConLike (ConLike(..))
@@ -55,13 +54,14 @@ import HscTypes
import Name
import NameSet
import NameEnv
+import Packages ( lookupModuleInAllPackages, PackageName(..) )
import Bag
import RdrName
import TcRnTypes
-import FastString (concatFS)
+import FastString ( concatFS, unpackFS )
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
-import HsDecls ( getConDetails )
+import HsDecls ( getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -85,12 +85,22 @@ createInterface tm flags modMap instIfaceMap = do
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
!exportedNames = modInfoExportsWithSelectors mi
+ (pkgNameFS, _) = modulePackageInfo dflags flags mdl
+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
(TcGblEnv { tcg_rdr_env = gre
, tcg_warns = warnings
, tcg_exports = all_exports
}, md) = tm_internals_ tm
+ -- The 'pkgName' is necessary to decide what package to mention in "@since"
+ -- annotations. Not having it is not fatal though.
+ --
+ -- Cabal can be trusted to pass the right flags, so this warning should be
+ -- mostly encountered when running Haddock outside of Cabal.
+ when (isNothing pkgName) $
+ liftErrMsg $ tell [ "Warning: Package name is not available." ]
+
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
(group_, imports, mayExports, mayDocHeader) <-
@@ -103,7 +113,7 @@ createInterface tm flags modMap instIfaceMap = do
opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
-- Process the top-level module header documentation.
- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
let declsWithDocs = topDecls group_
@@ -130,13 +140,13 @@ createInterface tm flags modMap instIfaceMap = do
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
maps@(!docMap, !argMap, !declMap, _) <-
- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
+ liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-- The MAIN functionality: compute the export items which will
-- each be the actual documentation of this module.
- exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre
+ exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre
exportedNames decls maps fixMap unrestrictedImportedMods
splices exports all_exports instIfaceMap dflags
@@ -190,6 +200,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+
-- | Given all of the @import M as N@ declarations in a package,
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
@@ -266,7 +277,7 @@ lookupModuleDyn ::
lookupModuleDyn _ (Just pkgId) mdlName =
Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
- case Packages.lookupModuleInAllPackages dflags mdlName of
+ case lookupModuleInAllPackages dflags mdlName of
(m,_):_ -> m
[] -> Module.mkModule Module.mainUnitId mdlName
@@ -346,11 +357,12 @@ type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap)
-- find its names, its subordinates, and its doc strings. Process doc strings
-- into 'Doc's.
mkMaps :: DynFlags
+ -> Maybe Package -- this package
-> GlobalRdrEnv
-> [Name]
-> [(LHsDecl GhcRn, [HsDocString])]
-> ErrMsgM Maps
-mkMaps dflags gre instances decls = do
+mkMaps dflags pkgName gre instances decls = do
(a, b, c) <- unzip3 <$> traverse mappings decls
pure ( f' (map (nubByName fst) a)
, f (filterMapping (not . M.null) b)
@@ -377,8 +389,8 @@ mkMaps dflags gre instances decls = do
declDoc :: [HsDocString] -> Map Int HsDocString
-> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
declDoc strs m = do
- doc' <- processDocStrings dflags gre strs
- m' <- traverse (processDocStringParas dflags gre) m
+ doc' <- processDocStrings dflags pkgName gre strs
+ m' <- traverse (processDocStringParas dflags pkgName gre) m
pure (doc', m')
(doc, args) <- declDoc docStrs (typeDocs decl)
@@ -605,12 +617,13 @@ collectDocs = go Nothing []
mkExportItems
:: Bool -- is it a signature
-> IfaceMap
+ -> Maybe Package -- this package
-> Module -- this module
-> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
+ -> [LHsDecl GhcRn] -- renamed source declarations
-> Maps
-> FixMap
-> M.Map ModuleName [ModuleName]
@@ -621,12 +634,12 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem GhcRn]
mkExportItems
- is_sig modMap thisMod semMod warnings gre exportedNames decls
+ is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
maps fixMap unrestricted_imp_mods splices exportList allExports
instIfaceMap dflags =
case exportList of
Nothing ->
- fullModuleContents is_sig modMap thisMod semMod warnings gre
+ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre
exportedNames decls maps fixMap splices instIfaceMap dflags
allExports
Just exports -> liftM concat $ mapM lookupExport exports
@@ -636,14 +649,14 @@ mkExportItems
return [ExportGroup lev "" doc]
lookupExport (IEDoc docStr, _) = liftErrMsg $ do
- doc <- processDocStringParas dflags gre docStr
+ doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
lookupExport (IEDocNamed str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
- doc <- processDocStringParas dflags gre docStr
+ doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
lookupExport (IEModuleContents (L _ mod_name), _)
@@ -962,6 +975,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
fullModuleContents :: Bool -- is it a signature
-> IfaceMap
+ -> Maybe Package -- this package
-> Module -- this module
-> Module -- semantic module
-> WarningMap
@@ -975,7 +989,7 @@ fullModuleContents :: Bool -- is it a signature
-> DynFlags
-> Avails
-> ErrMsgGhc [ExportItem GhcRn]
-fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames
+fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
let availEnv = availsToNameEnv (nubAvails avails)
(concat . concat) `fmap` (for decls $ \decl -> do
@@ -984,7 +998,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames
doc <- liftErrMsg (processDocString dflags gre docStr)
return [[ExportGroup lev "" doc]]
(L _ (DocD (DocCommentNamed _ docStr))) -> do
- doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
return [[ExportDoc doc]]
(L _ (ValD valDecl))
| name:_ <- collectHsBindBinders valDecl
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 1269df3f..9a978f9f 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -33,34 +33,35 @@ import RdrName
import EnumSet
import RnEnv (dataTcOccs)
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
+processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
-processDocStrings dflags gre strs = do
- mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
+processDocStrings dflags pkg gre strs = do
+ mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs
case mdoc of
-- We check that we don't have any version info to render instead
-- of just checking if there is no comment: there may not be a
-- comment but we still want to pass through any meta data.
- MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
+ MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing
x -> pure (Just x)
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
-processDocStringParas dflags gre (HsDocString fs) =
- overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString
+ -> ErrMsgM (MDoc Name)
+processDocStringParas dflags pkg gre (HsDocString fs) =
+ overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre (HsDocString fs) =
rename dflags gre $ parseString dflags (unpackFS fs)
-processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
-processModuleHeader dflags gre safety mayStr = do
+processModuleHeader dflags pkgName gre safety mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
- (hmi, doc) = parseModuleHeader dflags str
+ (hmi, doc) = parseModuleHeader dflags pkgName str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
Nothing -> pure Nothing
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 6690c22d..050901b6 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -24,8 +24,8 @@ import RdrName
-- 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 :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName)
-parseModuleHeader dflags str0 =
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader dflags pkgName str0 =
let
getKey :: String -> String -> (Maybe String,String)
getKey key str = case parseKey key str of
@@ -52,7 +52,7 @@ parseModuleHeader dflags str0 =
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags str9)
+ }, parseParas dflags pkgName str9)
-- | This function is how we read keys.
--
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:40:19 +0000