aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs146
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs3
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs46
3 files changed, 71 insertions, 124 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 66702396..ebb38907 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -33,12 +33,8 @@ import Outputable ( ppr, showSDoc, Outputable )
-- TODO: use DeclInfo DocName or something
-ppDecl' :: Bool -> LinksInfo -> LHsDecl DocName ->
- DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html
-ppDecl' s k l m i d u = vanillaTable << ppDecl s k l m i d u
-
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode
TyClD d@(TyData {})
@@ -50,11 +46,11 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = ca
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode
SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode
- InstD _ -> emptyTable
+ InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- DocName -> HsType DocName -> Bool -> HtmlTable
+ DocName -> HsType DocName -> Bool -> Html
ppFunSig summary links loc doc docname typ unicode =
ppTypeOrFunSig summary links loc docname typ doc
(ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
@@ -62,11 +58,11 @@ ppFunSig summary links loc doc docname typ unicode =
occname = docNameOcc docname
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
- DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable
+ DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html
ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode
| summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1
- | otherwise = topDeclBox links loc docname pref2 </>
- (tda [theclass "body"] << vanillaTable << (
+ | otherwise = topDeclElem links loc docname pref2 +++
+ (vanillaTable << (
do_args 0 sep typ </>
(case doc of
Just d -> ndocBox (docToHtml d)
@@ -110,14 +106,14 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
tyvarNames = map (getName . hsTyVarName . unLoc)
-ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html
ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode
= ppFunSig summary links loc doc name typ unicode
ppFor _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable
+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html
ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
= ppTypeOrFunSig summary links loc name (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode
@@ -163,35 +159,31 @@ ppTyFamHeader summary associated decl unicode =
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> HtmlTable
+ TyClDecl DocName -> Bool -> Html
ppTyFam summary associated links loc mbDoc decl unicode
| summary = declWithDoc summary links loc docname mbDoc
- (ppTyFamHeader True associated decl unicode)
-
- | associated, isJust mbDoc = header_ </> bodyBox << doc
- | associated = header_
- | null instances, isJust mbDoc = header_ </> bodyBox << doc
- | null instances = header_
- | isJust mbDoc = header_ </> bodyBox << (doc </> instancesBit)
- | otherwise = header_ </> bodyBox << instancesBit
+ (ppTyFamHeader True associated decl unicode)
+ | otherwise = header_ +++ maybeDocToHtml mbDoc +++ instancesBit
where
docname = tcdName decl
- header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode)
-
- doc = ndocBox . docToHtml . fromJust $ mbDoc
+ header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode)
instId = collapseId (getName docname)
- instancesBit = instHdr instId </>
+ instancesBit
+ | associated || null instances = noHtml
+ | otherwise = vanillaTable << (
+ instHdr instId </>
tda [theclass "body"] <<
collapsed thediv instId (
spacedTable1 << (
aboves (map (ppDocInstance unicode) instances)
)
)
+ )
-- TODO: get the instances
instances = []
@@ -220,23 +212,17 @@ ppDataInst = undefined
ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> HtmlTable
+ TyClDecl DocName -> Bool -> Html
ppTyInst summary associated links loc mbDoc decl unicode
| summary = declWithDoc summary links loc docname mbDoc
(ppTyInstHeader True associated decl unicode)
-
- | isJust mbDoc = header_ </> bodyBox << doc
- | otherwise = header_
+ | otherwise = header_ +++ maybeDocToHtml mbDoc
where
docname = tcdName decl
- header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode)
-
- doc = case mbDoc of
- Just d -> ndocBox (docToHtml d)
- Nothing -> emptyTable
+ header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode)
ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
@@ -252,7 +238,7 @@ ppTyInstHeader _ _ decl unicode =
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html
ppAssocType summ links doc (L loc decl) unicode =
case decl of
TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode
@@ -359,24 +345,23 @@ ppFds fds unicode =
fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
hsep (map ppDocName vars2)
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html
ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode =
if null sigs && null ats
- then (if summary then declBox else topDeclBox links loc nm) hdr
- else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")
- </>
+ then (if summary then declElem else topDeclElem links loc nm) hdr
+ else (if summary then declElem else topDeclElem links loc nm) (hdr <+> keyword "where")
+ +++ vanillaTable <<
(
- bodyBox <<
- aboves
- (
- [ ppAssocType summary links doc at unicode | at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
-
- [ ppFunSig summary links loc doc n typ unicode
- | L _ (TypeSig (L _ n) (L _ typ)) <- sigs
- , let doc = lookupAnySubdoc n subdocs ]
- )
- )
+ bodyBox << aboves
+ (
+ [ ppAssocType summary links doc at unicode | at <- ats
+ , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
+
+ [ ppFunSig summary links loc doc n typ unicode
+ | L _ (TypeSig (L _ n) (L _ typ)) <- sigs
+ , let doc = lookupAnySubdoc n subdocs ]
+ )
+ )
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode
nm = unLoc lname
@@ -386,47 +371,30 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
- -> TyClDecl DocName -> Bool -> HtmlTable
+ -> TyClDecl DocName -> Bool -> Html
ppClassDecl summary links instances loc mbDoc subdocs
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _) unicode
| summary = ppShortClassDecl summary links decl loc subdocs unicode
- | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit)
+ | otherwise = classheader +++ maybeDocToHtml mbDoc +++ instancesBit
where
classheader
- | null lsigs = topDeclBox links loc nm (hdr unicode)
- | otherwise = topDeclBox links loc nm (hdr unicode <+> keyword "where")
+ | null lsigs = topDeclElem links loc nm (hdr unicode)
+ | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where")
nm = unLoc $ tcdLName decl
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-
- classdoc = case mbDoc of
- Nothing -> emptyTable
- Just d -> ndocBox (docToHtml d)
-
- body_
- | null lsigs, null ats = emptyTable
- | null ats = s8 </> methHdr </> bodyBox << methodTable
- | otherwise = s8 </> atHdr </> bodyBox << atTable </>
- s8 </> methHdr </> bodyBox << methodTable
-
- methodTable =
- abovesSep s8 [ ppFunSig summary links loc doc n typ unicode
- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let doc = lookupAnySubdoc n subdocs ]
-
- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
-
+
instId = collapseId (getName nm)
instancesBit
- | null instances = emptyTable
- | otherwise
- = s8 </> instHdr instId </>
+ | null instances = noHtml
+ | otherwise = vanillaTable << (
+ instHdr instId </>
tda [theclass "body"] <<
collapsed thediv instId (
spacedTable1 << aboves (map (ppDocInstance unicode) instances)
)
+ )
ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
@@ -479,12 +447,12 @@ ppShortDataDecl summary links loc dataDecl unicode
where
dataHeader =
- (if summary then declBox else topDeclBox links loc docname)
+ (if summary then declElem else topDeclElem links loc docname)
((ppDataHeader summary dataDecl unicode) <+>
case resTy of ResTyGADT _ -> keyword "where"; _ -> empty)
- doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode)
- doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode)
+ doConstr c con = declElem (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode)
+ doGADTConstr con = declElem (ppShortConstr summary (unLoc con) unicode)
docname = unLoc . tcdLName $ dataDecl
cons = tcdCons dataDecl
@@ -492,27 +460,21 @@ ppShortDataDecl summary links loc dataDecl unicode
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
+ SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html
ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
| summary = declWithDoc summary links loc docname mbDoc
(ppShortDataDecl summary links loc dataDecl unicode)
| otherwise
- = (if validTable then (</>) else const) header_ $
- tda [theclass "body"] << vanillaTable << (
- datadoc </>
- constrBit </>
- instancesBit
- )
-
+ = header_ +++ datadoc +++ constrBit +++ instancesBit
where
docname = unLoc . tcdLName $ dataDecl
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
- header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode
+ header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode
<+> whereBit)
whereBit
@@ -548,8 +510,6 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
)
)
- validTable = isJust mbDoc || not (null cons) || not (null instances)
-
isRecCon :: Located (ConDecl a) -> Bool
isRecCon lcon = case con_details (unLoc lcon) of
@@ -682,10 +642,10 @@ ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
Just _ -> aboves [hdr, constr_doc, fields_html]
)
- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
+ where hdr = declElem (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
constr_doc
- | isJust doc = docBox (docToHtml (fromJust doc))
+ | isJust doc = docElem (docToHtml (fromJust doc))
| otherwise = emptyTable
fields_html =
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 54e9f700..5103f569 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -80,7 +80,8 @@ rdrDocToHtml :: Doc RdrName -> Html
rdrDocToHtml = markup fmt . cleanup
where fmt = parHtmlMarkup ppRdrName isRdrTc
-
+maybeDocToHtml :: Maybe (Doc DocName) -> Html
+maybeDocToHtml = maybe noHtml docToHtml
cleanup :: Doc a -> Doc a
cleanup = markup fmtUnParagraphLists
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index fa96049d..93ce0987 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -24,12 +24,10 @@ import FastString ( unpackFS )
import GHC
-declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable
-declWithDoc True _ _ _ _ html_decl = declBox html_decl
-declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl
-declWithDoc False links loc nm (Just doc) html_decl =
- topDeclBox links loc nm html_decl </> docBox (docToHtml doc)
-
+declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> Html
+declWithDoc True _ _ _ _ html_decl = declElem html_decl
+declWithDoc False links loc nm doc html_decl =
+ topDeclElem links loc nm html_decl +++ maybeDocToHtml doc
{-
@@ -38,36 +36,27 @@ text = strAttr "TEXT"
-}
-- a box for displaying code
-declBox :: Html -> HtmlTable
-declBox html = tda [theclass "decl"] << html
+declElem :: Html -> Html
+declElem = paragraph ! [theclass "decl"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
-topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable
-topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html
-topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url))
- loc name html =
- tda [theclass "topdecl"] <<
- ( table ! [theclass "declbar"] <<
- ((tda [theclass "declname"] << html)
- <-> srcLink
- <-> wikiLink)
- )
+topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html
+topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html =
+ declElem << (html +++ srcLink +++ wikiLink)
where srcLink =
case maybe_source_url of
- Nothing -> emptyTable
- Just url -> tda [theclass "declbut"] <<
- let url' = spliceURL (Just fname) (Just origMod)
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just origMod)
(Just n) (Just loc) url
- in anchor ! [href url'] << toHtml "Source"
+ in anchor ! [href url', theclass "link"] << "Source"
wikiLink =
case maybe_wiki_url of
- Nothing -> emptyTable
- Just url -> tda [theclass "declbut"] <<
- let url' = spliceURL (Just fname) (Just mdl)
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just mdl)
(Just n) (Just loc) url
- in anchor ! [href url'] << toHtml "Comments"
+ in anchor ! [href url', theclass "link"] << "Comments"
-- For source links, we want to point to the original module,
-- because only that will have the source.
@@ -81,16 +70,13 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url))
fname = unpackFS (srcSpanFile loc)
+
-- a box for displaying an 'argument' (some code which has text to the
-- right of it). Wrapping is not allowed in these boxes, whereas it is
-- in a declBox.
argBox :: Html -> HtmlTable
argBox html = tda [theclass "arg"] << html
--- a box for displaying documentation,
--- indented and with a little padding at the top
-docBox :: Html -> HtmlTable
-docBox html = tda [theclass "doc"] << html
-- a box for displaying documentation, not indented.
ndocBox :: Html -> HtmlTable
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 06:55:40 +0000