diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 13 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 12 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 82 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 |
5 files changed, 68 insertions, 45 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 628e1cd0..79ada0f7 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -207,12 +207,14 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) -- DOCUMENTATION ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] -ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w +ppDocumentation dflags (Documentation d w) = mdoc dflags d ++ doc dflags w doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] doc dflags = docWith dflags "" +mdoc :: Outputable o => DynFlags -> Maybe (MDoc o) -> [String] +mdoc dflags = docWith dflags "" . fmap _doc docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] docWith _ [] Nothing = [] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 7b72c030..f540527b 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -234,7 +234,7 @@ processExport (ExportNoDecl y subs) processExport (ExportModule mdl) = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing processExport (ExportDoc doc) - = docToLaTeX doc + = docToLaTeX $ _doc doc ppDocGroup :: Int -> LaTeX -> LaTeX @@ -393,7 +393,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) where do_largs n leader (L _ t) = do_args n leader t - arg_doc n = rDoc (Map.lookup n argDocs) + arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX do_args n leader (HsForAllTy Explicit tvs lctxt ltype) @@ -553,7 +553,7 @@ isUndocdInstance _ = Nothing -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX ppDocInstance unicode (instHead, doc) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX @@ -674,7 +674,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mbDoc = lookup (unLoc $ con_name con) subdocs + >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -684,7 +685,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= combineDocumentation . fst + mbDoc = lookup name subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1105,7 +1106,7 @@ docToLaTeX doc = markup latexMarkup doc Plain documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX = fmap docToLaTeX . combineDocumentation +documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 3b085c8e..8e133e65 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -64,7 +64,7 @@ ppHtml :: String -> Maybe String -- ^ Package -> [Interface] -> FilePath -- ^ Destination directory - -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe + -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) @@ -246,7 +246,7 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) + -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool -> Qualification -- ^ How to qualify names -> IO () @@ -270,7 +270,7 @@ ppHtmlContents odir doctitle _maybe_package ppHtmlContentsFrame odir doctitle themes ifaces debug -ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html +ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html ppPrologue _ _ Nothing = noHtml ppPrologue qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) @@ -590,7 +590,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - [groupTag lvl << docToHtml Nothing qual txt] + [groupTag lvl << docToHtml Nothing qual (mkMeta txt)] processForMiniSynopsis _ _ _ _ = [] @@ -625,7 +625,7 @@ ppModuleContents qual exports | otherwise = ( html:secs, rest2 ) where html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors (Just id0) qual doc +++ mk_subsections ssecs + << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest @@ -649,7 +649,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocName -> Maybe Html processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual doc + = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual processExport summary _ _ qual (ExportNoDecl y []) 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 |