From a1cc87c864242377833ab383f1df72583ab4a01d Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Mon, 25 May 2020 17:44:36 -0400
Subject: Use HsForAllTelescope (GHC#18235)

---
 haddock-api/src/Haddock/GhcUtils.hs | 32 ++++++++++++++++++++++----------
 1 file changed, 22 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src/Haddock/GhcUtils.hs')

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
-- 
cgit v1.2.3