diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 82 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 |
2 files changed, 52 insertions, 32 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 741e97e0..565adef2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -21,11 +21,13 @@ module Haddock.Backends.Xhtml.DocMarkup ( import Control.Applicative ((<$>)) +import Data.List +import Data.Monoid (mconcat) import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils -import Haddock.Doc (combineDocumentation) +import Haddock.Doc (combineDocumentation, emptyMetaDoc, metaDocAppend) import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) @@ -93,8 +95,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup { -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id = - UntouchedDoc (DocH a id) - | CollapsingHeader (Header (DocH a id)) (DocH a id) Int (Maybe String) + UntouchedDoc (MetaDoc a id) + | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String) | HackAppend (Hack a id) (Hack a id) deriving Eq @@ -110,15 +112,15 @@ toHack :: Int -- ^ Counter for header IDs which serves to assign -- this should work more or less fine: it is in fact the -- implicit assumption the collapse/expand mechanism makes for -- things like ‘Instances’ boxes. - -> [DocH a id] -> Hack a id -toHack _ _ [] = UntouchedDoc DocEmpty + -> [MetaDoc a id] -> Hack a id +toHack _ _ [] = UntouchedDoc emptyMetaDoc toHack _ _ [x] = UntouchedDoc x -toHack n nm (DocHeader (Header l (DocBold x)):xs) = +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 (DocHeader (Header l' _)) = l' > l + p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l p _ = True -- Stuff ‘under’ this header r = takeWhile p xs @@ -128,16 +130,18 @@ toHack n nm (DocHeader (Header l (DocBold x)):xs) = app y ys = HackAppend y (toHack (n + 1) nm ys) in case r of -- No content under this header - [] -> CollapsingHeader h DocEmpty n nm `app` r' + [] -> CollapsingHeader h emptyMetaDoc n nm `app` r' -- We got something out, stitch it back together into one chunk - y:ys -> CollapsingHeader h (foldl DocAppend y ys) n nm `app` r' + 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 :: DocH a id -> [DocH a id] -flatten (DocAppend x y) = flatten x ++ flatten y +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 @@ -146,24 +150,40 @@ flatten x = [x] -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html -hackMarkup fmt h = case h of - UntouchedDoc d -> markup fmt d - CollapsingHeader (Header lvl titl) par n nm -> - let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ True [] <<) - lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] - getHeader = fromMaybe caption (lookup lvl lvs) - subCation = getHeader ! col' << markup fmt titl - in (subCation +++) . instTable $ markup fmt par - HackAppend d d' -> markupAppend fmt (hackMarkup fmt d) (hackMarkup fmt d') +hackMarkup fmt' h' = + let (html, ms) = hackMarkup' fmt' h' + in html +++ renderMeta fmt' (mconcat 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_ True "caption" + instTable = (thediv ! collapseSection id_ True [] <<) + 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 -> Meta -> Html +renderMeta fmt (Meta { _version = Just x }) = + markupParagraph fmt . markupEmphasis fmt . toHtml $ + "Since: " ++ formatVersion x + where + formatVersion v = concat . intersperse "." $ map show v +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 before first. +-- specific hacks to the tree first. markupHacked :: DocMarkup id Html -> Maybe String - -> Doc id + -> MDoc id -> Html markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten @@ -171,23 +191,23 @@ markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten -- 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. - -> Qualification -> Doc DocName -> Html + -> Qualification -> MDoc DocName -> Html docToHtml n qual = markupHacked fmt 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' - -> Qualification -> Doc DocName -> Html + -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> Doc Name -> Html +origDocToHtml :: Qualification -> MDoc Name -> Html origDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> Doc RdrName -> Html +rdrDocToHtml :: Qualification -> MDoc RdrName -> Html rdrDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -205,13 +225,13 @@ docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation docSection_ :: Maybe Name -- ^ Name of the thing this doc is for - -> Qualification -> Doc DocName -> Html + -> Qualification -> MDoc DocName -> Html docSection_ n qual = (docElement thediv <<) . docToHtml (getOccString <$> n) qual -cleanup :: Doc a -> Doc a -cleanup = markup fmtUnParagraphLists +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 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index c5d8b7a3..e6a91391 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -115,7 +115,7 @@ divTopDecl :: Html -> Html divTopDecl = thediv ! [theclass "top"] -type SubDecl = (Html, Maybe (Doc DocName), [Html]) +type SubDecl = (Html, Maybe (MDoc DocName), [Html]) divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html |