diff options
Diffstat (limited to 'src/Haddock/Backends/Xhtml/DocMarkup.hs')
| -rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 143 |
1 files changed, 0 insertions, 143 deletions
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs deleted file mode 100644 index 5e27d9b0..00000000 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - } |