diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 3929c286719c1ad5ec61388041ef5d65251de26a..a218b11828704774209be4c1d26b9d1c57c6fa72 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -355,10 +355,7 @@ classify tok =
ITeof -> TkUnknown
ITlineComment {} -> TkComment
- ITdocCommentNext {} -> TkComment
- ITdocCommentPrev {} -> TkComment
- ITdocCommentNamed {} -> TkComment
- ITdocSection {} -> TkComment
+ ITdocComment {} -> TkComment
ITdocOptions {} -> TkComment
-- The lexer considers top-level pragmas as comments (see `pragState` in
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 3f97236a54c97ff3a5aa7c4dab79292a1dae369a..9f9120fa43ef9671aeeff367ef428b87cb4b710d 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -96,7 +96,7 @@ ifTrueJust True = Just
ifTrueJust False = const Nothing
sigName :: LSig GhcRn -> [IdP GhcRn]
-sigName (L _ sig) = sigNameNoLoc sig
+sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig
-- | Was this signature given by the user?
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
@@ -193,7 +193,7 @@ getMainDeclBinderI (ValD _ d) =
case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
+getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d
getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinderI _ = []
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 804367c4df1115a5365ab9d5f8340dc883d97899..19113107f81c6a45d5aa527b92568fcdcaff854f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -146,7 +146,7 @@ createIfaces verbosity modules flags instIfaceMap = do
let
installHaddockPlugin :: HscEnv -> HscEnv
installHaddockPlugin hsc_env =
- let
+ let
old_plugins = hsc_plugins hsc_env
new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }
hsc_env' = hsc_env { hsc_plugins = new_plugins }
@@ -362,7 +362,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
]
where
formatName :: SrcSpan -> HsDecl GhcRn -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of
RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
show (srcSpanStartLine rss) ++ ")"
_ -> ""
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index e8a79b2b50bfc34a2613a0cd585a271295bc8807..dc8afa3152145b8b6755a3599dda5ba4a218d59c 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -136,12 +136,12 @@ attachToExportItem index expInfo getInstDoc getFixity export =
, expItemSubDocs = subDocs
} = e { expItemFixities =
nubByName fst $ expItemFixities e ++
- [ (n',f) | n <- getMainDeclBinder d
+ [ (n',f) | n <- getMainDeclBinder emptyOccEnv d
, n' <- n : (map fst subDocs ++ patsyn_names)
, f <- maybeToList (getFixity n')
] }
where
- patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
+ patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns
attachFixities e = e
-- spanName: attach the location to the name that is the same file as the instance location
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4d746405ba07364738d1de6a4582044e094ca400..dbd4a9b2fa48d383ec15236bdd0395bef7bbc781 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -35,7 +35,7 @@ import Documentation.Haddock.Doc (metaDocAppend)
import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)
import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,
pretty, restrictTo, sigName, unL)
-import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader)
+import Haddock.Interface.LexParseRn
import Haddock.Options (Flag (..), modulePackageInfo)
import Haddock.Types hiding (liftErrMsg)
import Haddock.Utils (replace)
@@ -57,7 +57,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef)
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (bytesFS, unpackFS)
import GHC.Driver.Ppr (showSDoc)
-import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps)
import GHC.IORef (readIORef)
import GHC.Stack (HasCallStack)
import GHC.Tc.Types hiding (IfM)
@@ -65,7 +65,7 @@ import GHC.Tc.Utils.Monad (finalSafeMode)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
import GHC.Types.Basic (PromotionFlag (..))
-import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName)
+import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv)
import GHC.Types.Name.Env (lookupNameEnv)
import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv)
import GHC.Types.Name.Set (elemNameSet, mkNameSet)
@@ -79,6 +79,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
import GHC.Unit.Module.Warnings
+import GHC.Types.Unique.Map
newtype IfEnv m = IfEnv
{
@@ -255,7 +256,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
-- Process the top-level module header documentation.
(!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
- tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr))
+ tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr))
-- Warnings on declarations in this module
decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
@@ -405,7 +406,7 @@ lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
-- Warnings
-------------------------------------------------------------------------------
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
mkWarningMap dflags warnings gre exps = case warnings of
NoWarnings -> pure M.empty
WarnAll _ -> pure M.empty
@@ -416,18 +417,18 @@ mkWarningMap dflags warnings gre exps = case warnings of
, let n = greMangledName elt, n `elem` exps ]
in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name))
moduleWarning _ _ NoWarnings = pure Nothing
moduleWarning _ _ (WarnSome _) = pure Nothing
moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name)
parseWarning dflags gre w = case w of
- DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg)
- WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg)
+ DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
+ WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
where
format x bs = DocWarning . DocParagraph . DocAppend (DocString x)
- <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs)
+ <$> processDocStringFromString dflags gre bs
-------------------------------------------------------------------------------
@@ -479,7 +480,7 @@ mkMaps :: DynFlags
-> Maybe Package -- this package
-> GlobalRdrEnv
-> [Name]
- -> [(LHsDecl GhcRn, [HsDocString])]
+ -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-> ExtractedTHDocs -- ^ Template Haskell putDoc docs
-> ErrMsgM Maps
mkMaps dflags pkgName gre instances decls thDocs = do
@@ -512,36 +513,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do
thMappings = do
let ExtractedTHDocs
_
- (DeclDocMap declDocs)
- (ArgDocMap argDocs)
- (DeclDocMap instDocs) = thDocs
- ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)
- ds2mdoc = processDocStringParas dflags pkgName gre
-
- declDocs' <- mapM ds2mdoc declDocs
- argDocs' <- mapM (mapM ds2mdoc) argDocs
- instDocs' <- mapM ds2mdoc instDocs
+ declDocs
+ argDocs
+ instDocs = thDocs
+ ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name)
+ ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString
+
+ let cvt = M.fromList . nonDetEltsUniqMap
+
+ declDocs' <- mapM ds2mdoc (cvt declDocs)
+ argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs)
+ instDocs' <- mapM ds2mdoc (cvt instDocs)
return (declDocs' <> instDocs', argDocs')
- mappings :: (LHsDecl GhcRn, [HsDocString])
+ mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
-> ErrMsgM ( [(Name, MDoc Name)]
, [(Name, IntMap (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do
- let declDoc :: [HsDocString] -> IntMap HsDocString
+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do
+ let docStrs = map hsDocString hs_docStrs
+ declDoc :: [HsDocString] -> IntMap HsDocString
-> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
declDoc strs m = do
doc' <- processDocStrings dflags pkgName gre strs
m' <- traverse (processDocStringParas dflags pkgName gre) m
pure (doc', m')
- (doc, args) <- declDoc docStrs (declTypeDocs decl)
+ (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl))
let
subs :: [(Name, [HsDocString], IntMap HsDocString)]
- subs = subordinates instanceMap decl
+ subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))
+ $ subordinates emptyOccEnv instanceMap decl
(subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
@@ -572,7 +577,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do
TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
- names _ decl = getMainDeclBinder decl
+ names _ decl = getMainDeclBinder emptyOccEnv decl
+
+-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
+-- maps with values for the same key merge the inner map as well.
+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
+
+unionArgMaps :: forall b . Map Name (IntMap b)
+ -> Map Name (IntMap b)
+ -> Map Name (IntMap b)
+unionArgMaps a b = M.foldrWithKey go b a
+ where
+ go :: Name -> IntMap b
+ -> Map Name (IntMap b) -> Map Name (IntMap b)
+ go n newArgMap acc
+ | Just oldArgMap <- M.lookup n acc =
+ M.insert n (newArgMap `IM.union` oldArgMap) acc
+ | otherwise = M.insert n newArgMap acc
-- Note [2]:
------------
@@ -634,11 +655,11 @@ mkExportItems
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
- doc <- processDocString dflags gre docStr
+ doc <- processDocString dflags gre (hsDocString . unLoc $ docStr)
return [ExportGroup lev "" doc]
lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
- doc <- processDocStringParas dflags pkgName gre docStr
+ doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
@@ -706,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
+ let declNames = getMainDeclBinder emptyOccEnv (unL decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
@@ -785,7 +806,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let
patSynNames =
- concatMap (getMainDeclBinder . fst) bundledPatSyns
+ concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns
fixities =
[ (n, f)
@@ -1007,17 +1028,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
(concat . concat) `fmap` (for decls $ \decl -> do
case decl of
(L _ (DocD _ (DocGroup lev docStr))) -> do
- doc <- liftErrMsg (processDocString dflags gre docStr)
+ doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr))
return [[ExportGroup lev "" doc]]
(L _ (DocD _ (DocCommentNamed _ docStr))) -> do
- doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr))
return [[ExportDoc doc]]
(L _ (ValD _ valDecl))
| name:_ <- collectHsBindBinders CollNoDictBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> return []
_ ->
- for (getMainDeclBinder (unLoc decl)) $ \nm -> do
+ for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
Just avail ->
availExportItem is_sig modMap thisMod
@@ -1042,7 +1063,7 @@ extractDecl
-> LHsDecl GhcRn -- ^ parent declaration
-> Either ErrMsg (LHsDecl GhcRn)
extractDecl declMap name decl
- | name `elem` getMainDeclBinder (unLoc decl) = pure decl
+ | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl
| otherwise =
case unLoc decl of
TyClD _ d@ClassDecl { tcdLName = L _ clsNm
@@ -1197,10 +1218,10 @@ mkVisibleNames (_, _, _, instMap) exports opts
where
exportName e@ExportDecl {} = name ++ subs ++ patsyns
where subs = map fst (expItemSubDocs e)
- patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
+ patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ decl -> getMainDeclBinder emptyOccEnv decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1217,6 +1238,7 @@ findNamedDoc name = search
tell ["Cannot find documentation for: $" ++ name]
return Nothing
search (DocD _ (DocCommentNamed name' doc) : rest)
- | name == name' = return (Just doc)
+ | name == name' = return (Just (hsDocString . unLoc $ doc))
+
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index a827cf662eb54272cdfb71ceafae7d2b83447d52..f3b57792d4c12cdb6b0023cbf13ef0040ae862ce 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -15,6 +15,7 @@
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
( processDocString
+ , processDocStringFromString
, processDocStringParas
, processDocStrings
, processModuleHeader
@@ -38,6 +39,7 @@ import GHC.Parser.PostProcess
import GHC.Driver.Ppr ( showPpr, showSDoc )
import GHC.Types.Name.Reader
import GHC.Data.EnumSet as EnumSet
+import GHC.Utils.Trace
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do
processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
processDocStringParas dflags pkg gre hds =
- overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)
+ overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre hds =
- rename dflags gre $ parseString dflags (unpackHDS hds)
+ processDocStringFromString dflags gre (renderHsDocString hds)
+
+processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)
+processDocStringFromString dflags gre hds =
+ rename dflags gre $ parseString dflags hds
processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
@@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do
case mayStr of
Nothing -> return failure
Just hds -> do
- let str = unpackHDS hds
+ let str = renderHsDocString hds
(hmi, doc) = parseModuleHeader dflags pkgName str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 98c39859986711a0cfa6365290e60ce36803cf92..f2b3a9fa6102e4268972190a8138ccfe3aa25cfd 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) =
Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
-renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
-renameLDocHsSyn = return
+renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))
+renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) []))
renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
@@ -317,6 +317,7 @@ renameType t = case t of
HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy _ -> pure (HsWildCardTy noAnn)
+
renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
bndrs' <- renameOuterTyVarBndrs bndrs
@@ -511,7 +512,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameH98Details details
- mbldoc' <- mapM renameLDocHsSyn mbldoc
+ mbldoc' <- mapM (renameLDocHsSyn) mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_forall = forall_ -- Remove when #18311 is fixed