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.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs129
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs32
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs22
5 files changed, 114 insertions, 85 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index e8a79b2b..dc8afa31 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 a280c0b2..dbd4a9b2 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,30 +57,29 @@ 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.Parser.Annotation (IsUnicodeSyntax (..))
import GHC.Stack (HasCallStack)
import GHC.Tc.Types hiding (IfM)
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)
import GHC.Types.SourceFile (HscSource (..))
import GHC.Types.SourceText (SourceText (..), sl_fs)
+import GHC.Unit.Types
import qualified GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Unit.Module as Module
import GHC.Unit.Module.ModSummary (msHsFilePath)
-import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))
import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
-import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Unit.Module.Warnings
+import GHC.Types.Unique.Map
newtype IfEnv m = IfEnv
{
@@ -257,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)
@@ -351,8 +350,7 @@ mkAliasMap state impDecls =
-- them to the user. We should reuse that information;
-- or at least reuse the renamed imports, which know what
-- they import!
- (fmap Module.fsToUnit $
- fmap sl_fs $ ideclPkgQual impDecl)
+ (ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
@@ -395,11 +393,11 @@ unrestrictedModuleImports idecls =
-- Similar to GHC.lookupModule
-- ezyang: Not really...
lookupModuleDyn ::
- UnitState -> Maybe Unit -> ModuleName -> Module
-lookupModuleDyn _ (Just pkgId) mdlName =
- Module.mkModule pkgId mdlName
-lookupModuleDyn state Nothing mdlName =
- case lookupModuleInAllUnits state mdlName of
+ UnitState -> PkgQual -> ModuleName -> Module
+lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
+ OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
+ ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
+ NoPkgQual -> case lookupModuleInAllUnits state mdlName of
(m,_):_ -> m
[] -> Module.mkModule Module.mainUnit mdlName
@@ -408,7 +406,7 @@ lookupModuleDyn state Nothing mdlName =
-- 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
@@ -419,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
-------------------------------------------------------------------------------
@@ -482,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
@@ -515,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
@@ -575,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]:
------------
@@ -637,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 $
@@ -709,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
@@ -788,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)
@@ -1010,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
@@ -1045,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
@@ -1113,7 +1131,7 @@ extractDecl declMap name decl
, Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , extFieldOcc n == name
+ , foExt n == name
]
in case matches of
[d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
@@ -1142,17 +1160,17 @@ extractPatternSyn nm t tvs cons =
InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
PrefixConGADT args' -> map hsScaledThing args'
- RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
+ RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ)
_ -> typ
- typ'' = noLocA (HsQualTy noExtField Nothing typ')
+ typ'' = noLocA (HsQualTy noExtField (noLocA []) typ')
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -1169,12 +1187,12 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
- , L l n <- ns, extFieldOcc n == nm ]
+ matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
+ , L l n <- ns, foExt n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
@@ -1200,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 _ = []
@@ -1220,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 a827cf66..f3b57792 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 2833df49..cbc7e58f 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))
@@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
-renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)
-renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)
+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))
+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))
+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
@@ -258,7 +259,7 @@ renameType t = case t of
, hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
- lcontext' <- traverse renameLContext lcontext
+ lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
@@ -289,11 +290,11 @@ renameType t = case t of
HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
- HsOpTy _ a (L loc op) b -> do
+ HsOpTy _ prom a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy noAnn a' (L loc op') b')
+ return (HsOpTy noAnn prom a' (L loc op') b')
HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
@@ -316,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
@@ -505,18 +507,19 @@ renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc
- , con_forall = forall }) = do
+ , con_forall = forall_ }) = do
lname' <- renameL lname
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
+ , con_forall = forall_ -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
+ , con_dcolon = dcol
, con_mb_cxt = lcontext, con_g_args = details
, con_res_ty = res_ty
, con_doc = mbldoc } = do
@@ -527,7 +530,8 @@ renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (ConDeclGADT
- { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'
+ { con_g_ext = noExtField, con_names = lnames'
+ , con_dcolon = dcol, con_bndrs = bndrs'
, con_mb_cxt = lcontext', con_g_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' })
@@ -548,9 +552,9 @@ renameH98Details (InfixCon a b) = do
renameGADTDetails :: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
-renameGADTDetails (RecConGADT (L l fields)) = do
+renameGADTDetails (RecConGADT (L l fields) arr) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecConGADT (L (locA l) fields'))
+ return (RecConGADT (L (locA l) fields') arr)
renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 16f00fda..d1164858 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -16,6 +16,7 @@ import Haddock.Syb
import Haddock.Types
import GHC
+import GHC.Types.Basic ( PromotionFlag(..) )
import GHC.Types.Name
import GHC.Data.FastString
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
@@ -132,9 +133,9 @@ sugarTuples typ =
sugarOperators :: HsType GhcRn -> HsType GhcRn
-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
- | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)
+ | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb
+ | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
where
name' = getName name
sugarOperators typ = typ
@@ -283,7 +284,7 @@ renameType (HsForAllTy x tele lt) =
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
- <$> renameMContext lctxt
+ <$> renameLContext lctxt
<*> renameLType lt
renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
@@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
-renameType (HsOpTy x la lop lb) =
- HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
+renameType (HsOpTy x prom la lop lb) =
+ HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
@@ -311,7 +312,7 @@ renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameHsArrow mult = pure mult
@@ -324,11 +325,10 @@ renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
-renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))
-renameMContext Nothing = return Nothing
-renameMContext (Just (L l ctxt)) = do
+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
+renameLContext (L l ctxt) = do
ctxt' <- renameContext ctxt
- return (Just (L l ctxt'))
+ return (L l ctxt')
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-23 10:21:00 +0000