Use HsForAllTelescope (GHC#18235)

3 files changed, 45 insertions, 41 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