module Haddock.Backends.Xhtml.DocMarkup (
docToHtml,
rdrDocToHtml,
origDocToHtml,
docElement, docSection, maybeDocSection,
) where
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
import GHC
import Name
import RdrName
parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
parHtmlMarkup ppId isTyCon = Markup {
markupEmpty = noHtml,
markupString = toHtml,
markupParagraph = paragraph,
markupAppend = (+++),
markupIdentifier = thecode . ppId . choose,
markupModule = \m -> let (mdl,ref) = break (=='#') m
in ppModuleRef (mkModuleNoPackage mdl) ref,
markupEmphasis = emphasize,
markupMonospaced = thecode,
markupUnorderedList = unordList,
markupOrderedList = ordList,
markupDefList = defList,
markupCodeBlock = pre,
markupURL = \url -> anchor ! [href url] << url,
markupAName = \aname -> namedAnchor aname << "",
markupPic = \path -> image ! [src path],
markupExample = examplesToHtml
}
where
choose [] = error "empty identifier list in HsDoc"
choose [x] = x
choose (x:y:_)
| isTyCon x = x
| otherwise = y
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
exampleToHtml (Example expression result) = htmlExample
where
htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
docToHtml :: Qualification -> Doc DocName -> Html
docToHtml qual = markup fmt . cleanup
where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName)
origDocToHtml :: Doc Name -> Html
origDocToHtml = markup fmt . cleanup
where fmt = parHtmlMarkup ppName isTyConName
rdrDocToHtml :: Doc RdrName -> Html
rdrDocToHtml = markup fmt . cleanup
where fmt = parHtmlMarkup ppRdrName isRdrTc
docElement :: (Html -> Html) -> Html -> Html
docElement el content_ =
if isNoHtml content_
then el ! [theclass "doc empty"] << spaceHtml
else el ! [theclass "doc"] << content_
docSection :: Qualification -> Doc DocName -> Html
docSection qual = (docElement thediv <<) . docToHtml qual
maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
maybeDocSection qual = maybe noHtml (docSection qual)
cleanup :: Doc a -> Doc a
cleanup = markup fmtUnParagraphLists
where
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
}