Use HsForAllTelescope (GHC#18235)

10 files changed, 198 insertions, 112 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e03611b2..27a7d804 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -71,7 +71,7 @@ dropHsDocTy :: HsType a -> HsType a
 dropHsDocTy = f
     where
         g (L src x) = L src (f x)
-        f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e)
+        f (HsForAllTy x a e) = HsForAllTy x a (g e)
         f (HsQualTy x a e) = HsQualTy x a (g e)
         f (HsBangTy x a b) = HsBangTy x a (g b)
         f (HsAppTy x a b) = HsAppTy x (g a) (g b)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b49fc74e..0c323ae5 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -474,10 +474,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
     arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
 
     do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
-    do_args _n leader (HsForAllTy _ fvf tvs ltype)
+    do_args _n leader (HsForAllTy _ tele ltype)
       = [ ( decltt leader
-          , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++
-                          [ppForAllSeparator unicode fvf]))
+          , decltt (ppHsForAllTelescope tele unicode)
               <+> ppLType unicode ltype
           ) ]
     do_args n leader (HsQualTy _ lctxt ltype)
@@ -506,12 +505,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
     gadtOpen = text "\\{"
 
 
-ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
-ppForAllSeparator unicode fvf =
-  case fvf of
-    ForallVis   -> text "\\ " <> arrow unicode
-    ForallInvis -> dot
-
 ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX
 ppTypeSig nms ty unicode =
   hsep (punctuate comma $ map ppSymName nms)
@@ -519,6 +512,14 @@ ppTypeSig nms ty unicode =
     <+> ppType unicode ty
 
 
+ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX
+ppHsForAllTelescope tele unicode = case tele of
+  HsForAllVis { hsf_vis_bndrs = bndrs } ->
+    hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode
+  HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot
+
+
 ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]
 ppTyVars = map (ppSymName . getName . hsLTyVarNameI)
 
@@ -1040,9 +1041,8 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
 
 
 ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
-  = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <>
-            ppForAllSeparator unicode fvf
+ppr_mono_ty (HsForAllTy _ tele ty) unicode
+  = sep [ ppHsForAllTelescope tele unicode
         , ppr_mono_lty ty unicode ]
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode
   = sep [ ppLContext ctxt unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 36bc04c3..5163fb6b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -151,10 +151,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
     do_largs n leader (L _ t) = do_args n leader t
 
     do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
-    do_args n leader (HsForAllTy _ fvf tvs ltype)
+    do_args n leader (HsForAllTy _ tele ltype)
       = do_largs n leader' ltype
       where
-        leader' = leader <+> ppForAll tvs unicode qual fvf
+        leader' = leader <+> ppForAll tele unicode qual
 
     do_args n leader (HsQualTy _ lctxt ltype)
       | null (unLoc lctxt)
@@ -189,20 +189,22 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
 
 
 
-ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag
+ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification
          -> Html
-ppForAll tvs unicode qual fvf =
-  case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
-    [] -> noHtml
-    ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf
-  where ppKTv n k = parens $
-          ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
-
-ppForAllSeparator :: Unicode -> ForallVisFlag -> Html
-ppForAllSeparator unicode fvf =
-  case fvf of
-    ForallVis   -> spaceHtml +++ arrow unicode
-    ForallInvis -> dot
+ppForAll tele unicode qual = case tele of
+  HsForAllVis { hsf_vis_bndrs = bndrs } ->
+    pp_bndrs bndrs (spaceHtml +++ arrow unicode)
+  HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+    pp_bndrs bndrs dot
+  where
+    pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html
+    pp_bndrs tvs forall_separator =
+      case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
+        [] -> noHtml
+        ts -> forallSymbol unicode <+> hsep ts +++ forall_separator
+
+    pp_ktv n k = parens $
+      ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
 
 ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
 ppFixities [] _ = noHtml
@@ -1146,16 +1148,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmp
     hasNonEmptyContext :: LHsType name -> Bool
     hasNonEmptyContext t =
       case unLoc t of
-        HsForAllTy _ _ _ s -> hasNonEmptyContext s
-        HsQualTy _ cxt s   -> if null (unLoc cxt) then hasNonEmptyContext s else True
-        HsFunTy _ _ s      -> hasNonEmptyContext s
+        HsForAllTy _ _ s -> hasNonEmptyContext s
+        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+        HsFunTy _ _ s    -> hasNonEmptyContext s
         _ -> False
     isFirstContextEmpty :: LHsType name -> Bool
     isFirstContextEmpty t =
       case unLoc t of
-        HsForAllTy _ _ _ s -> isFirstContextEmpty s
-        HsQualTy _ cxt _   -> null (unLoc cxt)
-        HsFunTy _ _ s      -> isFirstContextEmpty s
+        HsForAllTy _ _ s -> isFirstContextEmpty s
+        HsQualTy _ cxt _ -> null (unLoc cxt)
+        HsFunTy _ _ s    -> isFirstContextEmpty s
         _ -> False
 
 
@@ -1165,19 +1167,21 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
 ppPatSigType unicode qual typ =
   let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
 
-ppForAllPart :: RenderableBndrFlag flag =>
-  Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html
-ppForAllPart unicode qual fvf tvs =
-  hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++
-  ppForAllSeparator unicode fvf
+ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
+ppForAllPart unicode qual tele = case tele of
+  HsForAllVis { hsf_vis_bndrs = bndrs } ->
+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++
+    spaceHtml +++  arrow unicode
+  HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
 
 ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
 
 ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts
-  = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
+ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts
+  = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts
 
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
   = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 0020fc4c..b45b6eab 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -19,6 +19,8 @@ module Haddock.Convert (
   PrintRuntimeReps(..),
 ) where
 
+#include "HsVersions.h"
+
 import GHC.Data.Bag ( emptyBag )
 import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)
                   , PromotionFlag(..), DefMethSpec(..) )
@@ -44,7 +46,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
 import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
                  , liftedRepDataConKey )
 import GHC.Types.Unique ( getUnique )
-import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut )
+import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
+                      , filterByList, filterOut )
+import GHC.Utils.Outputable ( assertPanic )
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.SrcLoc
@@ -53,7 +57,7 @@ import Haddock.Types
 import Haddock.Interface.Specialize
 import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )
 
-import Data.Maybe                            ( catMaybes, maybeToList )
+import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )
 
 
 -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check
@@ -395,7 +399,7 @@ synifyDataCon use_gadt_syntax dc =
               ConDeclGADT { con_g_ext  = []
                           , con_names  = [name]
                           , con_forall = noLoc $ not $ null user_tvbndrs
-                          , con_qvars  = map synifyInvisTyVar user_tvbndrs
+                          , con_qvars  = map synifyTyVarBndr user_tvbndrs
                           , con_mb_cxt = ctx
                           , con_args   = hat
                           , con_res_ty = synifyType WithinType [] res_ty
@@ -404,7 +408,7 @@ synifyDataCon use_gadt_syntax dc =
               ConDeclH98 { con_ext    = noExtField
                          , con_name   = name
                          , con_forall = noLoc False
-                         , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs
+                         , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
                          , con_mb_cxt = ctx
                          , con_args   = hat
                          , con_doc    = Nothing }
@@ -450,27 +454,25 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = []
                            , hsq_explicit = map synifyTyVar ktvs }
 
 synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn
-synifyTyVar = synifyTyVar' emptyVarSet
+synifyTyVar = synify_ty_var emptyVarSet ()
+
+synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
+synifyTyVarBndr = synifyTyVarBndr' emptyVarSet
 
-synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
-synifyInvisTyVar = synifyInvisTyVar' emptyVarSet
+synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
+synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
 
--- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind
+-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
 -- signatures (even if they don't have the lifted type kind).
-synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn
-synifyTyVar' no_kinds tv
+synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
+synify_ty_var no_kinds flag tv
   | isLiftedTypeKind kind || tv `elemVarSet` no_kinds
-  = noLoc (UserTyVar noExtField () (noLoc name))
-  | otherwise = noLoc (KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
+  = noLoc (UserTyVar noExtField flag (noLoc name))
+  | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind))
   where
     kind = tyVarKind tv
     name = getName tv
 
-synifyInvisTyVar' :: VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
-synifyInvisTyVar' no_kinds (Bndr tv spec) = case (synifyTyVar' no_kinds tv) of
-  L l (UserTyVar   ne _ n)   -> L l (UserTyVar   ne spec n)
-  L l (KindedTyVar ne _ n k) -> L l (KindedTyVar ne spec n k)
-
 -- | Annotate (with HsKingSig) a type if the first parameter is True
 -- and if the type contains a free variable.
 -- This is used to synify type patterns for poly-kinded tyvars in
@@ -626,39 +628,56 @@ synifyType _ vs (AppTy t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
   in noLoc $ HsAppTy noExtField s1 s2
-synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty
+synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty
 synifyType _ vs       (FunTy VisArg t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
   in noLoc $ HsFunTy noExtField s1 s2
 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
-  synifyForAllType s argf vs forallty
+  case argf of
+    Required    -> synifyVisForAllType vs forallty
+    Invisible _ -> synifySigmaType s vs forallty
 
 synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t
 synifyType s vs (CastTy t _) = synifyType s vs t
 synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
 
--- | Process a 'Type' which starts with a forall or a constraint into
--- an 'HsType'
-synifyForAllType
+-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
+synifyVisForAllType
+  :: [TyVar]          -- ^ free variables in the type to convert
+  -> Type             -- ^ the forall type to convert
+  -> LHsType GhcRn
+synifyVisForAllType vs ty =
+  let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty
+
+      sTvs = map synifyTyVarBndr tvs
+
+      -- Figure out what the type variable order would be inferred in the
+      -- absence of an explicit forall
+      tvs' = orderedFVs (mkVarSet vs) [rho]
+
+  in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs
+                        , hst_xforall = noExtField
+                        , hst_body  = synifyType WithinType (tvs' ++ vs) rho }
+
+-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
+-- into an 'HsType'
+synifySigmaType
   :: SynifyTypeState  -- ^ what to do with the 'forall'
-  -> ArgFlag          -- ^ the visibility of the @forall@
   -> [TyVar]          -- ^ free variables in the type to convert
   -> Type             -- ^ the forall type to convert
   -> LHsType GhcRn
-synifyForAllType s argf vs ty =
-  let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
-      inv_tvs = map to_invis_bndr tvs
+synifySigmaType s vs ty =
+  let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
       sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
                       , hst_xqual = noExtField
                       , hst_body = synifyType WithinType (tvs' ++ vs) tau }
 
-      sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf
-                       , hst_bndrs = sTvs
+      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
                        , hst_xforall = noExtField
                        , hst_body  = noLoc sPhi }
 
-      sTvs = map synifyInvisTyVar inv_tvs
+      sTvs = map synifyTyVarBndr tvs
 
       -- Figure out what the type variable order would be inferred in the
       -- absence of an explicit forall
@@ -672,12 +691,7 @@ synifyForAllType s argf vs ty =
       | not (null tvs) -> noLoc sTy
       | otherwise -> noLoc sPhi
 
-    ImplicitizeForAll -> implicitForAll [] vs inv_tvs ctx (synifyType WithinType) tau
-
-  where
-    to_invis_bndr :: TyVarBinder -> InvisTVBinder
-    to_invis_bndr (Bndr tv Required)         = Bndr tv SpecifiedSpec
-    to_invis_bndr (Bndr tv (Invisible spec)) = Bndr tv spec
+    ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
 
 -- | Put a forall in if there are any type variables which require
 -- explicit kind annotations or if the inferred type variable order
@@ -701,13 +715,12 @@ implicitForAll tycons vs tvs ctx synInner tau
        = HsQualTy { hst_ctxt = synifyCtx ctx
                   , hst_xqual = noExtField
                   , hst_body = synInner (tvs' ++ vs) tau }
-  sTy = HsForAllTy { hst_fvf = ForallInvis
-                   , hst_bndrs = sTvs
+  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
                    , hst_xforall = noExtField
                    , hst_body = noLoc sPhi }
 
   no_kinds_needed = noKindTyVars tycons tau
-  sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs
+  sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
 
   -- Figure out what the type variable order would be inferred in the
   -- absence of an explicit forall
@@ -850,22 +863,54 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this
 invariant didn't hold.
 -}
 
--- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
+-- | A version of 'TcType.tcSplitSigmaTy' that:
+--
+-- 1. Preserves type synonyms.
+-- 2. Returns 'InvisTVBinder's instead of 'TyVar's.
 --
 -- See Note [Invariant: Never expand type synonyms]
-tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type)
-tcSplitSigmaTySameVisPreserveSynonyms argf ty =
-    case tcSplitForAllTysSameVisPreserveSynonyms argf ty of
+tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type)
+tcSplitSigmaTyPreserveSynonyms ty =
+    case tcSplitForAllTysInvisPreserveSynonyms ty of
       (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of
         (theta, tau) -> (tvs, theta, tau)
 
 -- | See Note [Invariant: Never expand type synonyms]
-tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type)
-tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
+tcSplitSomeForAllTysPreserveSynonyms ::
+  (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type)
+tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty []
+  where
+    split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs
+      | argf_pred argf  = split ty' ty' (tvb:tvs)
+    split orig_ty _ tvs = (reverse tvs, orig_ty)
+
+-- | See Note [Invariant: Never expand type synonyms]
+tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
+tcSplitForAllTysReqPreserveSynonyms ty =
+  let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty
+      req_bndrs         = mapMaybe mk_req_bndr_maybe all_bndrs in
+  ASSERT( req_bndrs `equalLength` all_bndrs )
+  (req_bndrs, body)
   where
-    split _       (ForAllTy tvbndr@(Bndr _ argf) ty') tvs
-      | argf `sameVis` supplied_argf                = split ty' ty' (tvbndr:tvs)
-    split orig_ty _                             tvs = (reverse tvs, orig_ty)
+    mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder
+    mk_req_bndr_maybe (Bndr tv argf) = case argf of
+      Required    -> Just $ Bndr tv ()
+      Invisible _ -> Nothing
+
+-- | See Note [Invariant: Never expand type synonyms]
+tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
+tcSplitForAllTysInvisPreserveSynonyms ty =
+  let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty
+      inv_bndrs         = mapMaybe mk_inv_bndr_maybe all_bndrs in
+  ASSERT( inv_bndrs `equalLength` all_bndrs )
+  (inv_bndrs, body)
+  where
+    mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder
+    mk_inv_bndr_maybe (Bndr tv argf) = case argf of
+      Invisible s -> Just $ Bndr tv s
+      Required    -> Nothing
+
+-- | See Note [Invariant: Never expand type synonyms]
 
 -- | See Note [Invariant: Never expand type synonyms]
 tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
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
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 5e09fec6..108e9f66 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -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 -})
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
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e8670012..21c7d19b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -695,6 +695,10 @@ type instance XTyLit           DocNameI = NoExtField
 type instance XWildCardTy      DocNameI = NoExtField
 type instance XXType           DocNameI = NewHsTypeX
 
+type instance XHsForAllVis        DocNameI = NoExtField
+type instance XHsForAllInvis      DocNameI = NoExtField
+type instance XXHsForAllTelescope DocNameI = NoExtCon
+
 type instance XUserTyVar    DocNameI = NoExtField
 type instance XKindedTyVar  DocNameI = NoExtField
 type instance XXTyVarBndr   DocNameI = NoExtCon
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 010bd8bc..d72b9004 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -138,9 +138,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
   = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
           -- The mkEmptySigWcType is suspicious
   where
-    go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))
-       = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
-                           , hst_bndrs = tvs, hst_body = go ty })
+    go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
+       = L loc (HsForAllTy { hst_xforall = noExtField
+                           , hst_tele = tele, hst_body = go ty })
     go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
        = L loc (HsQualTy { hst_xqual = noExtField
                          , hst_ctxt = add_ctxt ctxt, hst_body = ty })