aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs60
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:18:25 +0000