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.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs70
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs69
3 files changed, 87 insertions, 69 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index ecaf1a5d..a0e56f07 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -422,7 +422,7 @@ mkMaps dflags pkgName gre instances decls = do
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
-- get the identifier with the right location.
- TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))
+ TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -904,26 +904,23 @@ extractDecl declMap name decl
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ n
+ InstD _ (DataFamInstD _ (DataFamInstDecl
+ (FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
- , feqn_rhs = defn }}))) ->
+ , feqn_rhs = defn }))) ->
if isDataConName name
then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)
else SigD noExtField <$> 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
+ let matches = [ d' | L _ d'@(DataFamInstDecl (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 noExtField (DataFamInstD noExtField d0)))
_ -> error "internal: extractDecl (ClsInstD)"
| otherwise ->
- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+ let matches = [ d' | L _ d'@(DataFamInstDecl d)
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
, Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
@@ -963,7 +960,7 @@ extractPatternSyn nm t tvs cons =
ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)
_ -> typ
typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
- in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
+ in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e7d19dfe..a1e712e0 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,10 +191,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki
renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
-renameLSigType = renameImplicit renameLType
+renameLSigType = mapM renameSigType
renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
-renameLSigWcType = renameWc (renameImplicit renameLType)
+renameLSigWcType = renameWc renameLSigType
renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
renameLKind = renameLType
@@ -294,6 +294,12 @@ renameType t = case t of
HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy a -> pure (HsWildCardTy a)
+renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
+ bndrs' <- renameOuterTyVarBndrs bndrs
+ body' <- renameLType body
+ pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }
+
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
--
@@ -486,21 +492,20 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_forall = forall -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
-renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
, con_mb_cxt = lcontext, con_g_args = details
- , con_res_ty = res_ty, con_forall = forall
+ , con_res_ty = res_ty
, con_doc = mbldoc } = do
lnames' <- mapM renameL lnames
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ bndrs' <- mapM renameOuterTyVarBndrs bndrs
lcontext' <- traverse renameLContext lcontext
details' <- renameGADTDetails details
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (ConDeclGADT
- { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
+ { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'
, con_mb_cxt = lcontext', con_g_args = details'
- , con_res_ty = res_ty', con_doc = mbldoc'
- , con_forall = forall}) -- Remove when #18311 is fixed
+ , con_res_ty = res_ty', con_doc = mbldoc' })
renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
-> RnM (HsScaled DocNameI (LHsType DocNameI))
@@ -618,32 +623,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
; return (TyFamInstDecl { tfid_eqn = eqn' }) }
renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
-renameTyFamInstEqn eqn
- = renameImplicit rename_ty_fam_eqn eqn
- where
- rename_ty_fam_eqn
- :: FamEqn GhcRn (LHsType GhcRn)
- -> RnM (FamEqn DocNameI (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
- , feqn_pats = pats, feqn_fixity = fixity
- , feqn_rhs = rhs })
- = do { tc' <- renameL tc
- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
- ; pats' <- mapM renameLTypeArg pats
- ; rhs' <- renameLType rhs
- ; return (FamEqn { feqn_ext = noExtField
- , feqn_tycon = tc'
- , feqn_bndrs = bndrs'
- , feqn_pats = pats'
- , feqn_fixity = fixity
- , feqn_rhs = rhs' }) }
+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; bndrs' <- renameOuterTyVarBndrs bndrs
+ ; pats' <- mapM renameLTypeArg pats
+ ; rhs' <- renameLType rhs
+ ; return (FamEqn { feqn_ext = noExtField
+ , feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }) }
renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
renameTyFamDefltD = renameTyFamInstD
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
- = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
+ = do { eqn' <- rename_data_fam_eqn eqn
; return (DataFamInstDecl { dfid_eqn = eqn' }) }
where
rename_data_fam_eqn
@@ -653,7 +652,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = defn })
= do { tc' <- renameL tc
- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExtField
@@ -663,13 +662,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
-renameImplicit :: (in_thing -> RnM out_thing)
- -> HsImplicitBndrs GhcRn in_thing
- -> RnM (HsImplicitBndrs DocNameI out_thing)
-renameImplicit rn_thing (HsIB { hsib_body = thing })
- = do { thing' <- rn_thing thing
- ; return (HsIB { hsib_body = thing'
- , hsib_ext = noExtField }) }
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+ -> RnM (HsOuterTyVarBndrs flag DocNameI)
+renameOuterTyVarBndrs (HsOuterImplicit{}) =
+ pure $ HsOuterImplicit{hso_ximplicit = noExtField}
+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =
+ HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 35e5258f..b19f52d0 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -56,7 +56,7 @@ specialize specs = go spec_map0
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
@@ -77,13 +77,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+ TypeSig noExtField lnames (typ {hswc_body = noLoc typ'})
where
- true_type :: HsType GhcRn
- true_type = unLoc (hsSigWcType typ)
- typ' :: HsType GhcRn
+ true_type :: HsSigType GhcRn
+ true_type = unLoc (dropWildCards typ)
+ typ' :: HsSigType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
- fv = foldr Set.union Set.empty . map freeVariables $ typs
+ fv = foldr Set.union Set.empty . map freeVariablesType $ typs
specializeSig _ _ sig = sig
@@ -207,25 +207,37 @@ setInternalOccName occ name =
nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
--- | Compute set of free variables of given type.
-freeVariables :: HsType GhcRn -> Set Name
-freeVariables =
- everythingWithState Set.empty Set.union query
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesType :: HsType GhcRn -> Set Name
+freeVariablesType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType)
+
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesSigType :: HsSigType GhcRn -> Set Name
+freeVariablesSigType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)
+
+queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)
+queryType term ctx = case term of
+ HsForAllTy _ tele _ ->
+ (Set.empty, Set.union ctx (teleNames tele))
+ HsTyVar _ _ (L _ name)
+ | getName name `Set.member` ctx -> (Set.empty, ctx)
+ | otherwise -> (Set.singleton $ getName name, ctx)
+ _ -> (Set.empty, ctx)
where
- query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
- query term ctx = case cast term :: Maybe (HsType GhcRn) of
- 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 :: HsForAllTelescope GhcRn -> Set Name
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)
+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =
+ (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs)))
+
+bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name
+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
-- | Make given type visually unambiguous.
@@ -236,12 +248,12 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: Set Name -> HsType GhcRn -> HsType GhcRn
-rename fv typ = evalState (renameType typ) env
+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn
+rename fv typ = evalState (renameSigType typ) env
where
env = RenameEnv
{ rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
- , rneSigFVs = Set.map getNameRep $ freeVariables typ
+ , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ
, rneCtx = Map.empty
}
mkPair name = (getNameRep name, name)
@@ -256,6 +268,17 @@ data RenameEnv name = RenameEnv
}
+renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)
+renameSigType (HsSig x bndrs body) =
+ HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body
+
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+ -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)
+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =
+ HsOuterImplicit <$> mapM renameName imp_tvs
+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x <$> mapM renameLBinder exp_bndrs
+
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType (HsForAllTy x tele lt) =
HsForAllTy x
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 12:22:24 +0000