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/Hyperlinker/Parser.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs26
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs62
5 files changed, 56 insertions, 51 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/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 41591c6e..19c72335 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -46,7 +46,7 @@ parse dflags fpath bs = case unP (go False []) initState of
start = mkRealSrcLoc (mkFastString fpath) 1 1
pflags = mkParserFlags' (warningFlags dflags)
(extensionFlags dflags)
- (thisPackage dflags)
+ (homeUnitId dflags)
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 13f22db7..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)
@@ -795,7 +796,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
, ppLType unicode (getGADTConType con)
]
- fieldPart = case (con, getConArgs con) of
+ fieldPart = case (con, getConArgsI con) of
-- Record style GADTs
(ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs []
@@ -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.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index cfbaffc6..24b565fc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -52,12 +52,13 @@ import Data.Ord ( comparing )
import GHC.Driver.Session (Language(..))
import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import GHC.Types.Name
+import GHC.Unit.State
--------------------------------------------------------------------------------
-- * Generating HTML documentation
--------------------------------------------------------------------------------
-ppHtml :: DynFlags
+ppHtml :: UnitState
-> String -- ^ Title
-> Maybe String -- ^ Package
-> [Interface]
@@ -77,7 +78,7 @@ ppHtml :: DynFlags
-> Bool -- ^ Also write Quickjump index
-> IO ()
-ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
+ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode
pkg qual debug withQuickjump = do
@@ -86,7 +87,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
visible i = OptHide `notElem` ifaceOptions i
when (isNothing maybe_contents_url) $
- ppHtmlContents dflags odir doctitle maybe_package
+ ppHtmlContents state odir doctitle maybe_package
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces ++ reexported_ifaces)
False -- we don't want to display the packages in a single-package contents
@@ -258,7 +259,7 @@ moduleInfo iface =
ppHtmlContents
- :: DynFlags
+ :: UnitState
-> FilePath
-> String
-> Maybe String
@@ -272,14 +273,14 @@ ppHtmlContents
-> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
-ppHtmlContents dflags odir doctitle _maybe_package
+ppHtmlContents state odir doctitle _maybe_package
themes mathjax_url maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
- let tree = mkModuleTree dflags showPkgs
+ let tree = mkModuleTree state showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
, not (instIsSig iface)]
- sig_tree = mkModuleTree dflags showPkgs
+ sig_tree = mkModuleTree state showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
, instIsSig iface]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 76b5fae8..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
@@ -934,7 +936,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
, fixity
]
- fieldPart = case (con, getConArgs con) of
+ fieldPart = case (con, getConArgsI con) of
-- Record style GADTs
(ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ]
@@ -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-12 00:41:48 +0000