aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMark Lentczner <markl@glyphic.com>2010-04-03 19:14:22 +0000
committerMark Lentczner <markl@glyphic.com>2010-04-03 19:14:22 +0000
commitf78afee6309a1f1baffc20b09639625a37944062 (patch)
treeff6353611d25ffeedf4554d27975ff0a85218c11 /src
parent4929e83c917d8b54ec3e2a0f945876b235e9faca (diff)
clean up Doc formatting code
- add CSS for lists - renderToString now uses showHtml since prettyHtml messes up <pre> sections
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs81
-rw-r--r--src/Haddock/Backends/Xhtml/Util.hs4
2 files changed, 39 insertions, 46 deletions
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 5ecd0aea..54e9f700 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -28,22 +28,21 @@ import RdrName
parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
parHtmlMarkup ppId isTyCon = Markup {
- markupParagraph = paragraph,
- markupEmpty = toHtml "",
+ markupEmpty = noHtml,
markupString = toHtml,
+ markupParagraph = paragraph,
markupAppend = (+++),
markupIdentifier = tt . ppId . choose,
- markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref,
- markupEmphasis = emphasize . toHtml,
- markupMonospaced = tt . toHtml,
- markupUnorderedList = ulist . concatHtml . map (li <<),
- markupPic = \path -> image ! [src path],
- markupOrderedList = olist . concatHtml . map (li <<),
- markupDefList = dlist . concatHtml . map markupDef,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m
+ in ppModule (mkModuleNoPackage mdl) ref,
+ markupEmphasis = emphasize,
+ markupMonospaced = tt,
+ markupUnorderedList = unordList,
+ markupOrderedList = ordList,
+ markupDefList = defList,
markupCodeBlock = pre,
markupURL = \url -> anchor ! [href url] << toHtml url,
- markupAName = \aname -> namedAnchor aname << toHtml "",
- markupExample = examplesToHtml
+ markupAName = \aname -> namedAnchor aname << toHtml ""
}
where
-- If an id can refer to multiple things, we give precedence to type
@@ -66,43 +65,37 @@ parHtmlMarkup ppId isTyCon = Markup {
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
-markupDef :: (HTML a, HTML b) => (a, b) -> Html
-markupDef (a,b) = dterm << a +++ ddef << b
-
-
-htmlMarkup :: DocMarkup DocName Html
-htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)
-
-htmlOrigMarkup :: DocMarkup Name Html
-htmlOrigMarkup = parHtmlMarkup ppName isTyConName
-
-htmlRdrMarkup :: DocMarkup RdrName Html
-htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc
-- If the doc is a single paragraph, don't surround it with <P> (this causes
--- ugly extra whitespace with some browsers).
+-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
docToHtml :: Doc DocName -> Html
-docToHtml doc = markup htmlMarkup (markup htmlCleanup doc)
+docToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppDocName (isTyConName . getName)
origDocToHtml :: Doc Name -> Html
-origDocToHtml doc = markup htmlOrigMarkup (markup htmlCleanup doc)
+origDocToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppName isTyConName
rdrDocToHtml :: Doc RdrName -> Html
-rdrDocToHtml doc = markup htmlRdrMarkup (markup htmlCleanup doc)
-
--- If there is a single paragraph, then surrounding it with <P>..</P>
--- can add too much whitespace in some browsers (eg. IE). However if
--- we have multiple paragraphs, then we want the extra whitespace to
--- separate them. So we catch the single paragraph case and transform it
--- here.
-unParagraph :: Doc a -> Doc a
-unParagraph (DocParagraph d) = d
---NO: This eliminates line breaks in the code block: (SDM, 6/5/2003)
---unParagraph (DocCodeBlock d) = (DocMonospaced d)
-unParagraph doc = doc
-
-htmlCleanup :: DocMarkup a (Doc a)
-htmlCleanup = idMarkup {
- markupUnorderedList = DocUnorderedList . map unParagraph,
- markupOrderedList = DocOrderedList . map unParagraph
- }
+rdrDocToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppRdrName isRdrTc
+
+
+
+cleanup :: Doc a -> Doc a
+cleanup = markup fmtUnParagraphLists
+ where
+ -- If there is a single paragraph, then surrounding it with <P>..</P>
+ -- can add too much whitespace in some browsers (eg. IE). However if
+ -- we have multiple paragraphs, then we want the extra whitespace to
+ -- separate them. So we catch the single paragraph case and transform it
+ -- here. We don't do this in code blocks as it eliminates line breaks.
+ unParagraph :: Doc a -> Doc a
+ unParagraph (DocParagraph d) = d
+ unParagraph doc = doc
+
+ fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists = idMarkup {
+ markupUnorderedList = DocUnorderedList . map unParagraph,
+ markupOrderedList = DocOrderedList . map unParagraph
+ }
diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs
index b7f3a8d4..cbaf6766 100644
--- a/src/Haddock/Backends/Xhtml/Util.hs
+++ b/src/Haddock/Backends/Xhtml/Util.hs
@@ -70,8 +70,8 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
renderToString :: Html -> String
--- renderToString = showHtml -- for production
-renderToString = prettyHtml -- for debugging
+renderToString = showHtml -- for production
+--renderToString = prettyHtml -- for debugging
hsep :: [Html] -> Html
hsep [] = noHtml