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/AttachInstances.hs19
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs161
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs60
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs15
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs44
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs20
6 files changed, 202 insertions, 117 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 286907e5..bf50ded3 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -19,7 +19,6 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
-import Control.Applicative
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
@@ -70,7 +69,7 @@ attachInstances expInfo ifaces instIfaceMap = do
attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -92,7 +91,11 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )
+ fam_insts = [ ( synifyFamInst i opaque
+ , doc
+ , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ , nameModule_maybe n
+ )
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
, let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
@@ -100,14 +103,18 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
]
- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
+ cls_insts = [ ( synifyInstHead i
+ , instLookup instDocMap n iface ifaceMap instIfaceMap
+ , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ , nameModule_maybe n
+ )
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
]
-- fam_insts but with failing type fams filtered out
- cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]
- famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]
+ cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
+ famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]
in do
dfs <- getDynFlags
let mkBug = (text "haddock-bug:" <+>) . text
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 78b5c36d..78242990 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,10 +54,11 @@ import HscTypes
import Name
import NameSet
import NameEnv
+import Packages ( lookupModuleInAllPackages, PackageName(..) )
import Bag
import RdrName
import TcRnTypes
-import FastString (fastStringToByteString)
+import FastString ( unpackFS, fastStringToByteString)
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( getConArgs )
@@ -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
@@ -160,7 +170,7 @@ createInterface tm flags modMap instIfaceMap = do
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
- tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+ tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm
return $! Interface {
ifaceMod = mdl
@@ -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
@@ -314,16 +325,17 @@ mkDocOpts mbOpts flags mdl = do
[] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
xs -> liftM catMaybes (mapM parseOption xs)
Nothing -> return []
- hm <- if Flag_HideModule (moduleString mdl) `elem` flags
- then return $ OptHide : opts
- else return opts
- ie <- if Flag_IgnoreAllExports `elem` flags
- then return $ OptIgnoreExports : hm
- else return hm
- se <- if Flag_ShowExtensions (moduleString mdl) `elem` flags
- then return $ OptShowExtensions : ie
- else return ie
- return se
+ pure (foldl go opts flags)
+ where
+ mdlStr = moduleString mdl
+
+ -- Later flags override earlier ones
+ go os m | m == Flag_HideModule mdlStr = OptHide : os
+ | m == Flag_ShowModule mdlStr = filter (/= OptHide) os
+ | m == Flag_ShowAllModules = filter (/= OptHide) os
+ | m == Flag_IgnoreAllExports = OptIgnoreExports : os
+ | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os
+ | otherwise = os
parseOption :: String -> ErrMsgM (Maybe DocOption)
parseOption "hide" = return (Just OptHide)
@@ -345,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)
@@ -376,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 (declTypeDocs decl)
@@ -515,7 +528,8 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+topDecls =
+ filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
@@ -575,7 +589,6 @@ filterDecls = filter (isHandled . unL . fst)
isHandled (DocD {}) = True
isHandled _ = False
-
-- | Go through all class declarations and filter their sub-declarations
filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
@@ -620,12 +633,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]
@@ -636,13 +650,14 @@ 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 exportedNames
- decls maps fixMap splices instIfaceMap dflags allExports
+ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre
+ exportedNames decls maps fixMap splices instIfaceMap dflags
+ allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
@@ -650,14 +665,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), _)
@@ -976,9 +991,11 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
fullModuleContents :: Bool -- is it a signature
-> IfaceMap
+ -> Maybe Package -- this package
-> Module -- this module
-> Module -- semantic module
-> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
-> [Name] -- exported names (orig)
-> [LHsDecl GhcRn] -- renamed source declarations
-> Maps
@@ -988,23 +1005,29 @@ fullModuleContents :: Bool -- is it a signature
-> DynFlags
-> Avails
-> ErrMsgGhc [ExportItem GhcRn]
-fullModuleContents is_sig modMap thisMod semMod warnings 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
- for (getMainDeclBinder (unLoc decl)) $ \nm -> do
- case lookupNameEnv availEnv nm of
- Just avail
- | L _ (ValD _ valDecl) <- decl
- , (name:_) <- collectHsBindBinders valDecl
- , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
- -> pure []
-
- | otherwise
- -> availExportItem is_sig modMap thisMod
- semMod warnings exportedNames maps fixMap
- splices instIfaceMap dflags avail
- Nothing -> pure [])
+ case decl of
+ (L _ (DocD _ (DocGroup lev docStr))) -> do
+ doc <- liftErrMsg (processDocString dflags gre docStr)
+ return [[ExportGroup lev "" doc]]
+ (L _ (DocD _ (DocCommentNamed _ docStr))) -> do
+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
+ return [[ExportDoc doc]]
+ (L _ (ValD _ valDecl))
+ | name:_ <- collectHsBindBinders valDecl
+ , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
+ -> return []
+ _ ->
+ for (getMainDeclBinder (unLoc decl)) $ \nm -> do
+ case lookupNameEnv availEnv nm of
+ Just avail ->
+ availExportItem is_sig modMap thisMod
+ semMod warnings exportedNames maps fixMap
+ splices instIfaceMap dflags avail
+ Nothing -> pure [])
where
isSigD (L _ SigD{}) = True
isSigD _ = False
@@ -1061,19 +1084,32 @@ extractDecl declMap name decl
FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
, feqn_rhs = defn }}))) ->
- SigD noExt <$> extractRecSel name n tys (dd_cons defn)
- InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) ->
- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
- <- insts
- -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
- , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
- , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
- , L _ n <- ns
- , extFieldOcc n == name
- ]
- in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
- _ -> error "internal: extractDecl (ClsInstD)"
+ if isDataConName name
+ then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn)
+ else SigD noExt <$> extractRecSel name n tys (dd_cons defn)
+ InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
+ | isDataConName name ->
+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
+ FamEqn { feqn_rhs = dd
+ }
+ })) <- insts
+ , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
+ ]
+ in case matches of
+ [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0)))
+ _ -> error "internal: extractDecl (ClsInstD)"
+ | otherwise ->
+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+ <- insts
+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
+ , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
+ , L _ n <- ns
+ , extFieldOcc n == name
+ ]
+ in case matches of
+ [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
+ _ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
@@ -1153,12 +1189,12 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
-mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule
-> ErrMsgGhc (Maybe [RichToken])
-mkMaybeTokenizedSrc flags tm
+mkMaybeTokenizedSrc dflags flags tm
| Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
Just src -> do
- tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+ tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src))
return $ Just tokens
Nothing -> do
liftErrMsg . tell . pure $ concat
@@ -1171,12 +1207,15 @@ mkMaybeTokenizedSrc flags tm
where
summary = pm_mod_summary . tm_parsed_module $ tm
-mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc ms src = do
+mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken]
+mkTokenizedSrc dflags ms src = do
-- make sure to read the whole file at once otherwise
-- we run out of file descriptors (see #495)
rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
- return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))
+ let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc)
+ return $ Hyperlinker.enrich src tokens
+ where
+ filepath = msHsFilePath ms
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index ce1dbc62..731f2a35 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -18,50 +18,48 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import Data.IntSet (toList)
import Data.List
import Documentation.Haddock.Doc (metaDocConcat)
import DynFlags (languageExtensions)
import qualified GHC.LanguageExtensions as LangExt
-import FastString
import GHC
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import Name
-import Outputable ( showPpr )
+import Outputable ( showPpr, showSDoc )
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 hds =
- overDocF (rename dflags gre) $ parseParas dflags (unpackHDS hds)
+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
+processDocStringParas dflags pkg gre hds =
+ overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre hds =
rename dflags gre $ parseString dflags (unpackHDS hds)
-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 _ hds) -> do
let str = unpackHDS hds
- (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
@@ -104,7 +102,9 @@ rename dflags gre = rn
-- We found no names in the env so we start guessing.
[] ->
case choices of
+ -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
[] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
-- diverge here from the old way where we would default
@@ -113,16 +113,16 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> pure (outOfScope dflags a)
+ a:_ -> outOfScope dflags a
-- There is only one name in the environment that matches so
-- use it.
[a] -> pure (DocIdentifier a)
+
-- But when there are multiple names available, default to
-- type constructors: somewhat awfully GHC returns the
-- values in the list positionally.
- a:b:_ | isTyConName a -> pure (DocIdentifier a)
- | otherwise -> pure (DocIdentifier b)
+ a:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -144,6 +144,7 @@ rename dflags gre = rn
DocEmpty -> pure (DocEmpty)
DocString str -> pure (DocString str)
DocHeader (Header l t) -> DocHeader . Header l <$> rn t
+ DocTable t -> DocTable <$> traverse rn t
-- | Wrap an identifier that's out of scope (i.e. wasn't found in
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
@@ -153,12 +154,29 @@ rename dflags gre = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a)
outOfScope dflags x =
case x of
- Unqual occ -> monospaced occ
- Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
- Orig _ occ -> monospaced occ
- Exact name -> monospaced name -- Shouldn't happen since x is out of scope
+ Unqual occ -> warnAndMonospace occ
+ Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
+ Orig _ occ -> warnAndMonospace occ
+ Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
where
+ warnAndMonospace a = do
+ tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope."]
+ pure (monospaced a)
monospaced a = DocMonospaced (DocString (showPpr dflags a))
+
+-- | Warn about an ambiguous identifier.
+ambiguous :: DynFlags -> RdrName -> Name -> [Name] -> ErrMsgM (Doc Name)
+ambiguous dflags x dflt names = do
+ tell [msg]
+ pure (DocIdentifier dflt)
+ where
+ msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") names ++
+ " You may be able to disambiguate the identifier by qualifying it or\n" ++
+ " by hiding some imports.\n" ++
+ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ x_str = '\'' : showPpr dflags x ++ "'"
+ defnLoc = showSDoc dflags . pprNameDefnLoc
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 768a31ce..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
@@ -37,21 +37,22 @@ parseModuleHeader dflags str0 =
(copyrightOpt,str3) = getKey "Copyright" str2
(licenseOpt,str4) = getKey "License" str3
(licenceOpt,str5) = getKey "Licence" str4
- (maintainerOpt,str6) = getKey "Maintainer" str5
- (stabilityOpt,str7) = getKey "Stability" str6
- (portabilityOpt,str8) = getKey "Portability" str7
+ (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5
+ (maintainerOpt,str7) = getKey "Maintainer" str6
+ (stabilityOpt,str8) = getKey "Stability" str7
+ (portabilityOpt,str9) = getKey "Portability" str8
in (HaddockModInfo {
hmi_description = parseString dflags <$> descriptionOpt,
hmi_copyright = copyrightOpt,
- hmi_license = licenseOpt `mplus` licenceOpt,
+ hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt,
hmi_maintainer = maintainerOpt,
hmi_stability = stabilityOpt,
hmi_portability = portabilityOpt,
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags str8)
+ }, parseParas dflags pkgName str9)
-- | This function is how we read keys.
--
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e3e4e987..c07f8300 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -22,6 +22,8 @@ import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
import Outputable ( panic )
+import RdrName (RdrName(Exact))
+import PrelNames (eqTyCon_RDR)
import Control.Applicative
import Control.Monad hiding (mapM)
@@ -60,11 +62,18 @@ renameInterface dflags renamingEnv warnings iface =
(missingNames1 ++ missingNames2 ++ missingNames3
++ missingNames4 ++ missingNames5)
- -- filter out certain built in type constructors using their string
- -- representation. TODO: use the Name constants from the GHC API.
--- strings = filter (`notElem` ["()", "[]", "(->)"])
--- (map pretty missingNames)
- strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
+ -- Filter out certain built in type constructors using their string
+ -- representation.
+ --
+ -- Note that since the renamed AST represents equality constraints as
+ -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
+ -- manually filter out 'eqTyCon_RDR' (aka @~@).
+ strings = [ pretty dflags n
+ | n <- missingNames
+ , not (isSystemName n)
+ , not (isBuiltInSyntax n)
+ , Exact n /= eqTyCon_RDR
+ ]
in do
-- report things that we couldn't link to. Only do this for non-hidden
@@ -263,11 +272,22 @@ renameType t = case t of
HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a
(XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
- HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b
- HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b
- HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
- HsAppsTy _ _ -> error "renameType: HsAppsTy"
+ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsSpliceTy _ s -> renameHsSpliceTy s
+ HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsAppsTy _ _ -> error "renameType: HsAppsTy"
+
+-- | Rename splices, but _only_ those that turn out to be for types.
+-- I think this is actually safe for our possible inputs:
+--
+-- * the input is from after GHC's renamer, so should have an 'HsSpliced'
+-- * the input is typechecked, and only 'HsSplicedTy' should get through that
+--
+renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)
+renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t
+renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy"
+renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
@@ -644,11 +664,11 @@ renameWc rn_thing (HsWC { hswc_body = thing })
renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
-renameDocInstance (inst, idoc, L l n) = do
+renameDocInstance (inst, idoc, L l n, m) = do
inst' <- renameInstHead inst
n' <- rename n
idoc' <- mapM renameDoc idoc
- return (inst', idoc',L l n')
+ return (inst', idoc', L l n', m)
renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 092a2f4e..2fcb495c 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -29,23 +29,23 @@ import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a
-specialize specs = go
+specialize specs = go spec_map0
where
- go :: forall x. Data x => x -> x
- go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+ go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
+ go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
strip_kind_sig :: HsType name -> HsType name
strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
- specialize_ty_var :: HsType GhcRn -> HsType GhcRn
- specialize_ty_var (HsTyVar _ _ (L _ name'))
+ specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
+ specialize_ty_var spec_map (HsTyVar _ _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
- specialize_ty_var typ = typ
- -- This is a tricky recursive definition that is guaranteed to terminate
- -- because a type binder cannot be instantiated with a type that depends
- -- on that binder. i.e. @a -> Maybe a@ is invalid
- spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]
+ specialize_ty_var _ typ = typ
+
+ -- This is a tricky recursive definition. By adding in the specializations
+ -- one by one, we should avoid infinite loops.
+ spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
-- | Instantiate given binders with corresponding types.
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-24 23:22:44 +0000