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.hs25
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs24
3 files changed, 43 insertions, 23 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 786779c6..108e9f66 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -48,7 +48,7 @@ import GHC.Driver.Types
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Unit.State ( lookupModuleInAllPackages, PackageName(..) )
+import GHC.Unit.State
import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Tc.Types
@@ -159,7 +159,7 @@ createInterface tm flags modMap instIfaceMap = do
!prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
let !aliases =
- mkAliasMap dflags $ tm_renamed_source tm
+ mkAliasMap (unitState dflags) $ tm_renamed_source tm
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
@@ -197,8 +197,8 @@ createInterface tm flags modMap instIfaceMap = do
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
-- will go in 'ifaceModuleAliases'.
-mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap dflags mRenamedSource =
+mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap state mRenamedSource =
case mRenamedSource of
Nothing -> M.empty
Just (_,impDecls,_,_) ->
@@ -206,7 +206,7 @@ mkAliasMap dflags mRenamedSource =
mapMaybe (\(SrcLoc.L _ impDecl) -> do
SrcLoc.L _ alias <- ideclAs impDecl
return $
- (lookupModuleDyn dflags
+ (lookupModuleDyn state
-- TODO: This is supremely dodgy, because in general the
-- UnitId isn't going to look anything like the package
-- qualifier (even with old versions of GHC, the
@@ -265,13 +265,13 @@ unrestrictedModuleImports idecls =
-- Similar to GHC.lookupModule
-- ezyang: Not really...
lookupModuleDyn ::
- DynFlags -> Maybe Unit -> ModuleName -> Module
+ UnitState -> Maybe Unit -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
Module.mkModule pkgId mdlName
-lookupModuleDyn dflags Nothing mdlName =
- case lookupModuleInAllPackages dflags mdlName of
+lookupModuleDyn state Nothing mdlName =
+ case lookupModuleInAllUnits state mdlName of
(m,_):_ -> m
- [] -> Module.mkModule Module.mainUnitId mdlName
+ [] -> Module.mkModule Module.mainUnit mdlName
-------------------------------------------------------------------------------
@@ -476,7 +476,7 @@ subordinates instMap decl = case decl of
extract_deriv_ty (L l ty) =
case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
- HsForAllTy{ hst_fvf = ForallInvis
+ HsForAllTy{ hst_tele = HsForAllInvis{}
, hst_body = L _ (HsDocTy _ _ doc) }
-> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
@@ -835,7 +835,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Nothing -> return ([], (noDocForDecl, availNoDocs avail))
-- TODO: If we try harder, we might be able to find
-- a Haddock! Look in the Haddocks for each thing in
- -- requirementContext (pkgState)
+ -- requirementContext (unitState)
Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))
| otherwise ->
return ([], (noDocForDecl, availNoDocs avail))
@@ -966,8 +966,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule unitId expMod -- Identity module!
- unitId = moduleUnit thisMod
+ m = mkModule (moduleUnit thisMod) expMod -- Identity module!
-- Note [1]:
------------
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 848acb1f..a0c118f8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -223,11 +223,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
- HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do
- tyvars' <- mapM renameLTyVarBndr tyvars
- ltype' <- renameLType ltype
- return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
- , hst_bndrs = tyvars', hst_body = ltype' })
+ HsForAllTy { hst_tele = tele, hst_body = ltype } -> do
+ tele' <- renameHsForAllTelescope tele
+ ltype' <- renameLType ltype
+ return (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
@@ -304,6 +304,13 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
; return (HsQTvs { hsq_ext = noExtField
, hsq_explicit = tvs' }) }
+renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
+renameHsForAllTelescope tele = case tele of
+ HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllVis x bndrs'
+ HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllInvis x bndrs'
+
renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))
= do { n' <- rename n
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index cbfea762..e137c258 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -206,12 +206,16 @@ freeVariables =
everythingWithState Set.empty Set.union query
where
query term ctx = case cast term :: Maybe (HsType GhcRn) of
- Just (HsForAllTy _ _ bndrs _) ->
- (Set.empty, Set.union ctx (bndrsNames bndrs))
+ Just (HsForAllTy _ tele _) ->
+ (Set.empty, Set.union ctx (teleNames tele))
Just (HsTyVar _ _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
+
+ teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
+ teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
+
bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
@@ -244,9 +248,9 @@ data RenameEnv name = RenameEnv
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
-renameType (HsForAllTy x fvf bndrs lt) =
- HsForAllTy x fvf
- <$> mapM (located renameBinder) bndrs
+renameType (HsForAllTy x tele lt) =
+ HsForAllTy x
+ <$> renameForAllTelescope tele
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
@@ -291,11 +295,21 @@ renameLTypes = mapM renameLType
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
+renameForAllTelescope :: HsForAllTelescope GhcRn
+ -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)
+renameForAllTelescope (HsForAllVis x bndrs) =
+ HsForAllVis x <$> mapM renameLBinder bndrs
+renameForAllTelescope (HsForAllInvis x bndrs) =
+ HsForAllInvis x <$> mapM renameLBinder bndrs
+
renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname
renameBinder (KindedTyVar x fl lname lkind) =
KindedTyVar x fl <$> located renameName lname <*> located renameType lkind
+renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)
+renameLBinder = located renameBinder
+
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
renameName name = do
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 00:28:06 +0000