diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 143 |
1 files changed, 143 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 index 00000000..5e27d9b0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.DocMarkup +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.DocMarkup ( + docToHtml, + rdrDocToHtml, + origDocToHtml, + docToHtmlNoAnchors, + + docElement, docSection, docSection_, +) where + +import Control.Applicative ((<$>)) + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils +import Haddock.Doc (combineDocumentation) + +import Text.XHtml hiding ( name, p, quote ) +import Data.Maybe (fromMaybe) + +import GHC + +parHtmlMarkup :: Qualification -> Bool + -> (Bool -> a -> Html) -> DocMarkup a Html +parHtmlMarkup qual insertAnchors ppId = Markup { + markupEmpty = noHtml, + markupString = toHtml, + markupParagraph = paragraph, + markupAppend = (+++), + markupIdentifier = thecode . ppId insertAnchors, + markupIdentifierUnchecked = thecode . ppUncheckedLink qual, + markupModule = \m -> let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef (mkModuleName mdl') ref, + markupWarning = thediv ! [theclass "warning"], + markupEmphasis = emphasize, + markupBold = strong, + markupMonospaced = thecode, + markupUnorderedList = unordList, + markupOrderedList = ordList, + markupDefList = defList, + markupCodeBlock = pre, + markupHyperlink = \(Hyperlink url mLabel) + -> if insertAnchors + then anchor ! [href url] + << fromMaybe url mLabel + else toHtml $ fromMaybe url mLabel, + markupAName = \aname -> namedAnchor aname << "", + markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), + markupProperty = pre . toHtml, + markupExample = examplesToHtml, + markupHeader = \(Header l t) -> makeHeader l t + } + where + makeHeader :: Int -> Html -> Html + makeHeader 1 mkup = h1 mkup + makeHeader 2 mkup = h2 mkup + makeHeader 3 mkup = h3 mkup + makeHeader 4 mkup = h4 mkup + makeHeader 5 mkup = h5 mkup + makeHeader 6 mkup = h6 mkup + makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + + + 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"] + + +-- If the doc is a single paragraph, don't surround it with <P> (this causes +-- ugly extra whitespace with some browsers). FIXME: Does this still apply? +docToHtml :: Qualification -> Doc DocName -> Html +docToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + +-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element +-- in links. This is used to generate the Contents box elements. +docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html +docToHtmlNoAnchors qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + +origDocToHtml :: Qualification -> Doc Name -> Html +origDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const $ ppName Raw) + + +rdrDocToHtml :: Qualification -> Doc RdrName -> Html +rdrDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const ppRdrName) + + +docElement :: (Html -> Html) -> Html -> Html +docElement el content_ = + if isNoHtml content_ + then el ! [theclass "doc empty"] << spaceHtml + else el ! [theclass "doc"] << content_ + + +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation + + +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual + + +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 + } |