aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHtml.hs124
1 files changed, 79 insertions, 45 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 01d01d69..87d76d51 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -152,8 +152,7 @@ ppHtmlContents odir title source_url mods = do
header (thetitle (toHtml title) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
- body <<
- table ! [width "100%", cellpadding 0, cellspacing 1] << (
+ body << vanillaTable << (
simpleHeader title </>
ppModuleTree title tree </>
footer
@@ -211,8 +210,7 @@ ppHtmlIndex odir title ifaces = do
header (thetitle (toHtml (title ++ " (Index)")) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
- body <<
- table ! [width "100%", cellpadding 0, cellspacing 1] << (
+ body << vanillaTable << (
simpleHeader title </>
tda [theclass "section1"] << toHtml "Type/Class Index" </>
index_html tycls_index 't' </>
@@ -247,8 +245,7 @@ ppHtmlIndex odir title ifaces = do
html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
- body <<
- table ! [width "100%", cellpadding 0, cellspacing 1] << (
+ body << vanillaTable << (
simpleHeader title </>
tda [theclass "section1"] <<
toHtml (descr ++ " Index (" ++ c:")") </>
@@ -302,8 +299,7 @@ ppHtmlModule odir title source_url (Module mod,iface) = do
header (thetitle (toHtml mod) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
- body <<
- table ! [width "100%", cellpadding 0, cellspacing 1] << (
+ body << vanillaTable << (
pageHeader mod iface title source_url </>
ifaceToHtml mod iface </>
footer
@@ -330,7 +326,7 @@ ifaceToHtml mod iface
description
| Just doc <- iface_doc iface
= (tda [theclass "section1"] << toHtml "Description") </>
- docBox (markup htmlMarkup doc)
+ docBox (docToHtml doc)
| otherwise
= Html.emptyTable
@@ -364,7 +360,7 @@ ppModuleContents exports
| lev <= n = ( [], items )
| otherwise = ( html:sections, rest2 )
where
- html = (dterm << anchor ! [href ('#':id)] << markup htmlMarkup doc)
+ html = (dterm << anchor ! [href ('#':id)] << docToHtml doc)
+++ mk_subsections subsections
(subsections, rest1) = process lev rest
(sections, rest2) = process n rest1
@@ -386,12 +382,12 @@ numberSectionHeadings exports = go 1 exports
processExport :: Bool -> ExportItem -> HtmlTable
processExport summary (ExportGroup lev id doc)
| summary = Html.emptyTable
- | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
+ | otherwise = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
processExport summary (ExportDecl decl)
= doDecl summary decl
processExport summary (ExportDoc doc)
| summary = Html.emptyTable
- | otherwise = docBox (markup htmlMarkup doc)
+ | otherwise = docBox (docToHtml doc)
processExport summary (ExportModule (Module mod))
= declBox (toHtml "module" <+> ppHsModule mod)
@@ -410,7 +406,7 @@ declWithDoc False Nothing html_decl = declBox html_decl
declWithDoc False (Just doc) html_decl =
tda [width "100%"] <<
vanillaTable <<
- (declBox html_decl </> docBox (markup htmlMarkup doc))
+ (declBox html_decl </> docBox (docToHtml doc))
doDecl :: Bool -> HsDecl -> HtmlTable
doDecl summary decl = do_decl decl
@@ -439,7 +435,7 @@ doDecl summary decl = do_decl decl
do_decl (HsDocGroup loc lev str)
= if summary then Html.emptyTable
- else ppDocGroup lev (markup htmlMarkup str)
+ else ppDocGroup lev (docToHtml str)
do_decl _ = error ("do_decl: " ++ show decl)
@@ -465,14 +461,12 @@ ppShortDataDecl summary is_newty
ppShortDataDecl summary is_newty
(HsDataDecl loc ctx nm args cons drv _doc) =
vanillaTable << (
- aboves (
- (declBox (ppHsDataHeader summary is_newty nm args) :
- zipWith do_constr ('=':repeat '|') cons
- )
- )
- )
- where do_constr c con = tda [theclass "condecl"] << (
- toHtml [c] <+> ppShortConstr summary con)
+ declBox (ppHsDataHeader summary is_newty nm args) </>
+ tda [theclass "body"] << vanillaTable << (
+ aboves (zipWith do_constr ('=':repeat '|') cons)
+ )
+ )
+ where do_constr c con = declBox (toHtml [c] <+> ppShortConstr summary con)
-- First, the abstract case:
@@ -482,29 +476,33 @@ ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) =
-- The rest of the cases:
ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
- | summary || no_constr_docs
+ | summary || (isNothing doc && no_constr_docs)
= declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
| otherwise
- = td << vanillaTable << (header </> datadoc </> constrs)
+ = td << vanillaTable << (
+ header </>
+ tda [theclass "body"] << vanillaTable << (
+ datadoc </>
+ constr_hdr </>
+ (tda [theclass "body"] << table << constrs))
+ )
where
header = declBox (ppHsDataHeader False is_newty nm args)
+ table
+ | any isRecDecl cons = spacedTable5
+ | otherwise = spacedTable1
+
datadoc
- | isJust doc = docBox (markup htmlMarkup (fromJust doc))
+ | isJust doc = ndocBox (docToHtml (fromJust doc))
| otherwise = Html.emptyTable
constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
constrs
| null cons = Html.emptyTable
- | otherwise =
- tda [theclass "databody"] << (
- table ! [width "100%", cellpadding 0, cellspacing 10] <<
- aboves (constr_hdr : map do_constr cons)
- )
-
- do_constr con = ppHsFullConstr con
+ | otherwise = aboves (map ppSideBySideConstr cons)
no_constr_docs = all constr_has_no_doc cons
@@ -516,6 +514,8 @@ ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
field_has_no_doc (HsFieldDecl nms _ doc)
= isNothing doc
+isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True
+isRecDecl _ = False
ppShortConstr :: Bool -> HsConDecl -> Html
ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) =
@@ -533,6 +533,21 @@ ppHsConstrHdr tvs ctxt
+++
(if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
+ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) =
+ narrowDeclBox (hsep ((ppHsConstrHdr tvs ctxt +++
+ ppHsBinder False nm) : map ppHsBangType typeList)) <->
+ maybeRDocBox doc
+ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) =
+ narrowDeclBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
+ maybeRDocBox doc </>
+ (tda [theclass "body"] << spacedTable1 <<
+ aboves (map ppSideBySideField fields))
+
+ppSideBySideField (HsFieldDecl ns ty doc) =
+ declBox (hsep (punctuate comma (map (ppHsBinder False) ns))
+ <+> toHtml "::" <+> ppHsBangType ty) <->
+ maybeRDocBox doc
+
ppHsFullConstr (HsConDecl pos nm tvs ctxt typeList doc) =
declWithDoc False doc (
hsep ((ppHsConstrHdr tvs ctxt +++
@@ -548,7 +563,7 @@ ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) =
where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
constr_doc
- | isJust doc = docBox (markup htmlMarkup (fromJust doc))
+ | isJust doc = docBox (docToHtml (fromJust doc))
| otherwise = Html.emptyTable
fields_html =
@@ -624,7 +639,7 @@ ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
keyword "where")
classdoc
- | Just d <- doc = docBox (markup htmlMarkup d)
+ | Just d <- doc = docBox (docToHtml d)
| otherwise = Html.emptyTable
meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
@@ -651,9 +666,9 @@ ppFunSig summary nm ty doc
| otherwise =
td << vanillaTable << (
declBox (ppHsBinder False nm) </>
- (tda [theclass "body"] << narrowTable << (
+ (tda [theclass "body"] << vanillaTable << (
(if (isJust doc)
- then ndocBox (markup htmlMarkup (fromJust doc))
+ then ndocBox (docToHtml (fromJust doc))
else Html.emptyTable) </>
do_args True ty
))
@@ -667,20 +682,21 @@ ppFunSig summary nm ty doc
do_args :: Bool -> HsType -> HtmlTable
do_args first (HsForAllType maybe_tvs ctxt ty)
- = declBox (leader first <+> ppHsForAll maybe_tvs ctxt) </>
+ = narrowDeclBox (leader first <+> ppHsForAll maybe_tvs ctxt) </>
do_args False ty
do_args first (HsTyFun (HsTyDoc ty doc) r)
- = (declBox (leader first <+> ppHsBType ty) <->
- rdocBox (markup htmlMarkup doc)) </>
+ = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+ rdocBox (docToHtml doc)) </>
do_args False r
do_args first (HsTyFun ty r)
- = (declBox (leader first <+> ppHsBType ty) <->
+ = (narrowDeclBox (leader first <+> ppHsBType ty) <->
rdocBox noHtml) </>
do_args False r
do_args first (HsTyDoc ty doc)
- = (declBox (leader first <+> ppHsBType ty) <->
- rdocBox (markup htmlMarkup doc))
- do_args first _ = declBox (leader first <+> ppHsBType ty)
+ = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+ rdocBox (docToHtml doc))
+ do_args first ty = declBox (leader first <+> ppHsBType ty) <->
+ rdocBox (noHtml)
leader True = toHtml "::"
leader False = toHtml "->"
@@ -787,6 +803,11 @@ htmlMarkup = Markup {
markupURL = \url -> anchor ! [href url] << toHtml url
}
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers).
+docToHtml (DocParagraph p) = docToHtml p
+docToHtml doc = markup htmlMarkup doc
+
-- -----------------------------------------------------------------------------
-- * Misc
@@ -830,6 +851,10 @@ text = strAttr "TEXT"
declBox :: Html -> HtmlTable
declBox html = tda [theclass "decl"] << html
+-- a horrible hack to keep a box from expanding width-wise
+narrowDeclBox :: Html -> HtmlTable
+narrowDeclBox html = tda [theclass "decl", width "1"] << html
+
-- a box for displaying documentation,
-- indented and with a little padding at the top
docBox :: Html -> HtmlTable
@@ -843,9 +868,18 @@ ndocBox html = tda [theclass "ndoc"] << html
rdocBox :: Html -> HtmlTable
rdocBox html = tda [theclass "rdoc"] << html
+maybeRDocBox :: Maybe Doc -> HtmlTable
+maybeRDocBox Nothing = rdocBox (noHtml)
+maybeRDocBox (Just doc) = rdocBox (docToHtml doc)
+
-- a box for the buttons at the top of the page
topButBox html = tda [theclass "topbut"] << html
-vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]
+-- a vanilla table has width 100%, no border, no padding, no spacing
+-- a narrow table is the same but without width 100%.
+vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]
+narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0]
+
+spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0]
+spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
-narrowTable = table ! [cellpadding 0, cellspacing 0, border 0]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:37:57 +0000