aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/GhcUtils.hs
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2020-05-25 17:44:36 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2020-06-13 07:16:55 -0400
commita1cc87c864242377833ab383f1df72583ab4a01d (patch)
tree524fd1f871299ab387473dbdc9a1523509d781b8 /haddock-api/src/Haddock/GhcUtils.hs
parente2a7f9dcebc7c48f7e8fccef8643ed0928a91753 (diff)
Use HsForAllTelescope (GHC#18235)
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs32
1 files changed, 22 insertions, 10 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 1239377d..73a2bac6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -34,8 +34,8 @@ import GHC
import GHC.Core.Class
import GHC.Driver.Session
import GHC.Types.SrcLoc ( advanceSrcLoc )
-import GHC.Types.Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
- isInvisibleArgFlag )
+import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
+ , tyVarKind, updateTyVarKind, isInvisibleArgFlag )
import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
@@ -178,6 +178,11 @@ hsImplicitBodyI (HsIB { hsib_body = body }) = body
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI = hsImplicitBodyI
+mkHsForAllInvisTeleI ::
+ [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
+mkHsForAllInvisTeleI invis_bndrs =
+ HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
+
getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
getConArgsI d = con_args d
@@ -190,9 +195,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
- , hst_xforall = noExtField
- , hst_bndrs = qtvs
+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = mkHsForAllInvisTeleI qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
@@ -245,9 +249,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
- , hst_xforall = noExtField
- , hst_bndrs = qtvs
+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = mkHsForAllInvisTele qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
@@ -309,8 +312,8 @@ reparenTypePrec = go
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
go p (HsIParamTy x n ty)
= paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
- go p (HsForAllTy x fvf tvs ty)
- = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)
+ go p (HsForAllTy x tele ty)
+ = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)
go p (HsQualTy x ctxt ty)
= paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
go p (HsFunTy x ty1 ty2)
@@ -350,6 +353,15 @@ reparenType = reparenTypePrec PREC_TOP
reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType = fmap reparenType
+-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
+reparenHsForAllTelescope :: (XParTy a ~ NoExtField)
+ => HsForAllTelescope a -> HsForAllTelescope a
+reparenHsForAllTelescope (HsForAllVis x bndrs) =
+ HsForAllVis x (map (fmap reparenTyVar) bndrs)
+reparenHsForAllTelescope (HsForAllInvis x bndrs) =
+ HsForAllInvis x (map (fmap reparenTyVar) bndrs)
+reparenHsForAllTelescope v@XHsForAllTelescope{} = v
+
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n