----------------------------------------------------------------------------- -- | -- 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 Data.List import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils import Haddock.Doc (combineDocumentation, emptyMetaDoc, metaDocAppend, metaConcat) import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) import GHC import GHC.Types.Name 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 (toHtml url) mLabel else fromMaybe (toHtml url) mLabel, markupAName = \aname -> if insertAnchors then namedAnchor aname << "" else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"), markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, markupHeader = \(Header l t) -> makeHeader l t, markupTable = \(Table h r) -> makeTable h r } 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!" makeTable :: [TableRow Html] -> [TableRow Html] -> Html makeTable hs bs = table (concatHtml (hs' ++ bs')) where hs' | null hs = [] | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] bs' = [tbody (concatHtml (map (makeTableRow td) bs))] makeTableRow :: (Html -> Html) -> TableRow Html -> Html makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs)) makeTableCell :: (Html -> Html) -> TableCell Html -> Html makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j') where i' = if i == 1 then [] else [ colspan i ] j' = if j == 1 then [] else [ rowspan j ] 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"] -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some -- elements. This is effectivelly a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id = UntouchedDoc (MetaDoc a id) | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String) | HackAppend (Hack a id) (Hack a id) deriving Eq -- | Group things under bold 'DocHeader's together. toHack :: Int -- ^ Counter for header IDs which serves to assign -- unique identifiers within the comment scope -> Maybe String -- ^ It is not enough to have unique identifier within the -- scope of the comment: if two different comments have the -- same ID for headers, the collapse/expand behaviour will act -- on them both. This serves to make each header a little bit -- more unique. As we can't export things with the same names, -- this should work more or less fine: it is in fact the -- implicit assumption the collapse/expand mechanism makes for -- things like ‘Instances’ boxes. -> [MetaDoc a id] -> Hack a id toHack _ _ [] = UntouchedDoc emptyMetaDoc toHack _ _ [x] = UntouchedDoc x toHack n nm (MetaDoc { _doc = DocHeader (Header l (DocBold x)) }:xs) = let -- Header with dropped bold h = Header l x -- Predicate for takeWhile, grab everything including ‘smaller’ -- headers p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l p _ = True -- Stuff ‘under’ this header r = takeWhile p xs -- Everything else that didn't make it under r' = drop (length r) xs app y [] = y app y ys = HackAppend y (toHack (n + 1) nm ys) in case r of -- No content under this header [] -> CollapsingHeader h emptyMetaDoc n nm `app` r' -- We got something out, stitch it back together into one chunk y:ys -> CollapsingHeader h (foldl metaDocAppend y ys) n nm `app` r' toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs) -- | Remove ‘top-level’ 'DocAppend's turning them into a flat list. -- This lends itself much better to processing things in order user -- might look at them, such as in 'toHack'. flatten :: MetaDoc a id -> [MetaDoc a id] flatten MetaDoc { _meta = m, _doc = DocAppend x y } = let f z = MetaDoc { _meta = m, _doc = z } in flatten (f x) ++ flatten (f y) flatten x = [x] -- | Generate the markup needed for collapse to happen. For -- 'UntouchedDoc' and 'HackAppend' we do nothing more but -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n col' = collapseControl id_ "caption" summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl in ((subCaption +++) . instTable $ markup fmt (_doc par), [_meta par]) HackAppend d d' -> let (x, m) = hackMarkup' fmt d (y, m') = hackMarkup' fmt d' in (markupAppend fmt x y, m ++ m') renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) = markupParagraph fmt . markupEmphasis fmt . toHtml $ "Since: " ++ formatPkgMaybe pkg ++ formatVersion x where formatVersion v = concat . intersperse "." $ map show v formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-" formatPkgMaybe _ = "" renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. markupHacked :: DocMarkup id Html -> Maybe Package -- this package -> Maybe String -> MDoc id -> Html markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten -- 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 :: Maybe String -- ^ Name of the thing this doc is for. See -- comments on 'toHack' for details. -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . 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 :: Maybe String -- ^ See 'toHack' -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . 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 :: Maybe Name -- ^ Name of the thing this doc is for -> Maybe Package -- ^ Current package -> Qualification -> Documentation DocName -> Html docSection n pkg qual = maybe noHtml (docSection_ n pkg qual) . combineDocumentation docSection_ :: Maybe Name -- ^ Name of the thing this doc is for -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docSection_ n pkg qual = (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual cleanup :: MDoc a -> MDoc a cleanup = overDoc (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 }