aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--html/xhaddock.css43
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs68
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs18
3 files changed, 80 insertions, 49 deletions
diff --git a/html/xhaddock.css b/html/xhaddock.css
index f1c149b5..fc305af3 100644
--- a/html/xhaddock.css
+++ b/html/xhaddock.css
@@ -1,6 +1,6 @@
* {
margin: 0;
- padding: 0;
+ padding: 0;
}
body {
@@ -56,25 +56,25 @@ h1, h2, h3, h4, h5 {
p {
padding-top: 2px;
padding-left: 10px;
- margin-bottom: 1em;
}
ul, ol, dl {
padding-top: 2px;
padding-left: 10px;
margin-left: 2.5em;
- margin-bottom: 1em;
}
pre {
padding-top: 2px;
padding-left: 20px;
- margin-bottom: 1em;
}
-h2 + p, h3 + p, h4 + p {
+* + p, * + pre {
margin-top: 1em;
}
+.caption + p, .src + p {
+ margin-top: 0;
+}
#package-header {
@@ -196,6 +196,8 @@ dl.info dd {
div.top {
margin-top: 1em;
+ clear: left;
+ margin-bottom: 1em;
}
div.top h5 {
@@ -224,6 +226,37 @@ div.top table, div.subdecl {
padding: 0 4px 2px 5px;
}
+div.subs {
+ margin-left: 10px;
+ clear: both;
+ margin-top: 2px;
+}
+
+.subs dl {
+ margin-left: 0;
+}
+
+.subs dl dl {
+ padding-left: 0;
+ padding-top: 4px;
+}
+
+.subs dt {
+ float: left;
+ margin-right: 1em;
+ clear: left;
+}
+
+.subs dd
+{
+ margin-bottom: 2px;
+ margin-top: 2px;
+}
+
+.fields .caption {
+ display: none;
+}
+
p.arg {
margin-bottom: 0;
}
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 286e9670..1245ff62 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -480,26 +480,12 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
ResTyGADT _ -> keyword "where"
_ -> empty
- constrTable
- | any isRecCon cons = spacedTable5
- | otherwise = spacedTable1
-
- constrBit
- | null cons = noHtml
- | otherwise = constrHdr +++ (
- constrTable <<
- aboves (map (ppSideBySideConstr subdocs unicode) cons)
- )
+ constrBit = subDecls "Constructors"
+ (map (ppSideBySideConstr subdocs unicode) cons)
instancesBit = ppInstances instances docname unicode
-isRecCon :: Located (ConDecl a) -> Bool
-isRecCon lcon = case con_details (unLoc lcon) of
- RecCon _ -> True
- _ -> False
-
-
ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
@@ -567,43 +553,45 @@ ppConstrHdr forall tvs ctxt unicode
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> empty
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> (Html, Maybe Html)
ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args))
- <-> maybeRDocBox mbDoc
+ (hsep ((header_ unicode +++ ppBinder False occ)
+ : map (ppLParendType unicode) args),
+ fmap docToHtml mbDoc)
RecCon fields ->
- argBox (header_ unicode +++ ppBinder False occ) <->
- maybeRDocBox mbDoc
- </>
- doRecordFields fields
+ (header_ unicode +++ ppBinder False occ,
+ fmap docToHtml mbDoc `with` (Just $ doRecordFields fields))
InfixCon arg1 arg2 ->
- argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2])
- <-> maybeRDocBox mbDoc
+ (hsep [header_ unicode+++ppLParendType unicode arg1,
+ ppBinder False occ,
+ ppLParendType unicode arg2],
+ fmap docToHtml mbDoc)
ResTyGADT resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
-- simplify the code.
- PrefixCon args -> doGADTCon args resTy
+ PrefixCon args -> doGADTCon args resTy Nothing
cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy
- </> doRecordFields fields
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+ (Just $ doRecordFields fields)
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy Nothing
where
- doRecordFields fields =
- (tda [theclass "body"] << spacedTable1 <<
- aboves (map (ppSideBySideField subdocs unicode) fields))
- doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs (con_cxt con) unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
- ) <-> maybeRDocBox mbDoc
-
-
+ doRecordFields fields = subDecls "Fields"
+ (map (ppSideBySideField subdocs unicode) fields)
+ doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Maybe Html -> (Html, Maybe Html)
+ doGADTCon args resTy fieldsHtml =
+ (ppBinder False occ <+> dcolon unicode
+ <+> hsep [ppForAll forall ltvs (con_cxt con) unicode,
+ ppLType unicode (foldr mkFunTy resTy args) ],
+ fmap docToHtml mbDoc `with` fieldsHtml)
+
+ with a = maybe a (\b -> Just $ a +++ b)
header_ = ppConstrHdr forall tyVars context
occ = docNameOcc . unLoc . con_name $ con
ltvs = con_qvars con
@@ -616,10 +604,10 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
mkFunTy a b = noLoc (HsFunTy a b)
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> (Html, Maybe Html)
ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
- argBox (ppBinder False (docNameOcc name)
- <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc
+ (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,
+ fmap docToHtml mbDoc)
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
mbDoc = join $ fmap fst $ lookup name subdocs
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 86c722b7..3ab93b82 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -17,11 +17,12 @@ module Haddock.Backends.Xhtml.Layout (
sectionName,
shortDeclList,
- divTopDecl,
+ divTopDecl,
+ subDecls,
topDeclElem, declElem,
- instHdr, atHdr, methHdr, constrHdr,
+ instHdr, atHdr, methHdr,
argBox, ndocBox, rdocBox, maybeRDocBox,
vanillaTable, vanillaTable2, spacedTable1, spacedTable5
@@ -32,6 +33,7 @@ import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Util
import Haddock.Types
+import Data.Char (isLetter, toLower)
import Text.XHtml hiding ( name, title, p, quote )
import FastString ( unpackFS )
@@ -63,6 +65,15 @@ shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
divTopDecl :: Html -> Html
divTopDecl = thediv ! [theclass "top"]
+subDecls :: String -> [(Html, Maybe Html)] -> Html
+subDecls _ [] = noHtml
+subDecls name decls = subSection << (subCaption +++ subList)
+ where
+ subSection = thediv ! [theclass $ unwords ["subs", subClass]]
+ subClass = map (\c -> if isLetter c then toLower c else '-') name
+ subCaption = paragraph ! [theclass "caption"] << name
+ subList = dlist << map subEntry decls
+ subEntry (dt,dd) = [dterm ! [theclass "src"] << dt, ddef << nonEmpty dd]
-- a box for displaying code
declElem :: Html -> Html
@@ -129,8 +140,7 @@ spacedTable1, spacedTable5 :: Html -> Html
spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0]
spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
-constrHdr, methHdr, atHdr :: Html
-constrHdr = h5 << "Constructors"
+methHdr, atHdr :: Html
methHdr = h5 << "Methods"
atHdr = h5 << "Associated Types"
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 11:55:04 +0000