diff options
Diffstat (limited to 'haddock-api/src/Haddock')
-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 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Doc.hs | 7 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 19 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 35 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 5 | ||||
-rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 15 | ||||
-rw-r--r-- | haddock-api/src/Haddock/ModuleTree.hs | 10 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Parser.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 15 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 12 |
15 files changed, 138 insertions, 99 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 diff --git a/haddock-api/src/Haddock/Doc.hs b/haddock-api/src/Haddock/Doc.hs index 91ad709f..9c21015a 100644 --- a/haddock-api/src/Haddock/Doc.hs +++ b/haddock-api/src/Haddock/Doc.hs @@ -7,11 +7,14 @@ module Haddock.Doc ( module Documentation.Haddock.Doc import Data.Maybe import Documentation.Haddock.Doc import Haddock.Types +import Haddock.Utils (mkMeta) -combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation :: Documentation name -> Maybe (MDoc name) combineDocumentation (Documentation Nothing Nothing) = Nothing combineDocumentation (Documentation mDoc mWarning) = - Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc) + Just (maybe emptyMetaDoc mkMeta mWarning + `metaDocAppend` + fromMaybe emptyMetaDoc mDoc) -- Drop trailing whitespace from @..@ code blocks. Otherwise this: -- diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 00c119fa..2ed25542 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where -import Documentation.Haddock.Doc (docAppend) +import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Types import Haddock.Options import Haddock.GhcUtils @@ -256,19 +256,19 @@ mkMaps dflags gre instances decls = f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat - f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name) - f' = M.fromListWith docAppend . concat + f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) + f' = M.fromListWith metaDocAppend . concat mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, Doc Name)] - , [(Name, Map Int (Doc Name))] + -> ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] , [(Name, [LHsDecl Name])] ) mappings (ldecl, docStrs) = let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (Doc Name), Map Int (Doc Name)) + -> (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = let doc' = processDocStrings dflags gre strs m' = M.map (processDocStringParas dflags gre) m @@ -641,7 +641,8 @@ hiValExportItem dflags name doc splice fixity = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap + -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs n warnings docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in @@ -731,8 +732,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index f1021436..35abf8a6 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -21,7 +21,7 @@ module Haddock.Interface.LexParseRn import Control.Applicative import Data.IntSet (toList) import Data.List -import Documentation.Haddock.Doc (docConcat) +import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (ExtensionFlag(..), languageExtensions) import FastString import GHC @@ -32,31 +32,26 @@ import Name import Outputable (showPpr) import RdrName -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] + -> Maybe (MDoc Name) processDocStrings dflags gre strs = - case docConcat $ map (processDocStringParas dflags gre) strs of - DocEmpty -> Nothing + case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -- We check that we don't have any version info to render instead + -- of just checking if there is no comment: there may not be a + -- comment but we still want to pass through any meta data. + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing x -> Just x - -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocStringParas = process parseParas - +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas dflags gre (HsDocString fs) = + overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocString = process parseString - -process :: (DynFlags -> String -> Doc RdrName) - -> DynFlags - -> GlobalRdrEnv - -> HsDocString - -> Doc Name -process parse dflags gre (HsDocString fs) = - rename dflags gre $ parse dflags (unpackFS fs) - +processDocString dflags gre (HsDocString fs) = + rename dflags gre $ parseString dflags (unpackFS fs) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) + -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of @@ -66,7 +61,7 @@ processModuleHeader dflags gre safety mayStr = do (hmi, doc) = parseModuleHeader dflags str !descr = rename dflags gre <$> hmi_description hmi hmi' = hmi { hmi_description = descr } - doc' = rename dflags gre doc + doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') let flags :: [ExtensionFlag] diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 6848dc63..d92e8b2a 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -25,7 +25,7 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName) +parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) parseModuleHeader dflags str0 = let getKey :: String -> String -> (Maybe String,String) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 748e0210..277d6ca9 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -12,7 +12,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse) +import Data.Traversable (traverse, Traversable) import Haddock.GhcUtils import Haddock.Types @@ -160,10 +160,9 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -renameDoc :: Doc Name -> RnM (Doc DocName) +renameDoc :: Traversable t => t Name -> RnM (t DocName) renameDoc = traverse rename - renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index bb997b9a..e4671f5e 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -77,7 +77,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 708 -binaryInterfaceVersion = 25 +binaryInterfaceVersion = 26 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -455,6 +455,19 @@ instance Binary a => Binary (Header a) where t <- get bh return (Header l t) +instance Binary Meta where + put_ bh Meta { _version = v } = put_ bh v + get bh = (\v -> Meta { _version = v }) <$> get bh + +instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where + put_ bh MetaDoc { _meta = m, _doc = d } = do + put_ bh m + put_ bh d + get bh = do + m <- get bh + d <- get bh + return $ MetaDoc { _meta = m, _doc = d } + {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh DocEmpty = do diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2a7fbfcc..22cfcdfa 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -12,17 +12,17 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( Doc ) +import Haddock.Types ( MDoc ) import GHC ( Name ) import Module ( Module, moduleNameString, moduleName, modulePackageId, packageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] +mkModuleTree :: Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where @@ -31,7 +31,7 @@ mkModuleTree showPkgs mods = fn (mod_,pkg,short) = addToTrees mod_ pkg short -addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) @@ -43,7 +43,7 @@ addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] +mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index ea4b7a3f..47bf814b 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -28,8 +28,8 @@ import RdrName (RdrName) import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> DocH mod RdrName -parseParas d = P.overIdentifier (parseIdent d) . P.parseParas +parseParas :: DynFlags -> String -> MetaDoc mod RdrName +parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 85b3a592..d131f019 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -44,8 +44,8 @@ import Control.Monad (ap) type IfaceMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface -- TODO: rename -type DocMap a = Map Name (Doc a) -type ArgMap a = Map Name (Map Int (Doc a)) +type DocMap a = Map Name (MDoc a) +type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name @@ -128,7 +128,7 @@ data Interface = Interface , ifaceWarningMap :: !WarningMap } -type WarningMap = DocMap Name +type WarningMap = Map Name (Doc Name) -- | A subset of the fields of 'Interface' that we store in the interface @@ -233,20 +233,20 @@ data ExportItem name } -- | Some documentation. - | ExportDoc !(Doc name) + | ExportDoc !(MDoc name) -- | A cross-reference to another module. | ExportModule !Module data Documentation name = Documentation - { documentationDoc :: Maybe (Doc name) + { documentationDoc :: Maybe (MDoc name) , documentationWarning :: !(Maybe (Doc name)) } deriving Functor -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. -type FnArgsDoc name = Map Int (Doc name) +type FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) @@ -301,7 +301,7 @@ instance OutputableBndr a => Outputable (InstType a) where ppr (DataInst a) = text "DataInst" <+> ppr a -- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (Doc name)) +type DocInstance name = (InstHead name, Maybe (MDoc name)) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type @@ -315,6 +315,7 @@ type InstHead name = (name, [HsType name], [HsType name], InstType name) type LDoc id = Located (Doc id) type Doc id = DocH (ModuleName, OccName) id +type MDoc id = MetaDoc (ModuleName, OccName) id instance (NFData a, NFData mod) => NFData (DocH mod a) where diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index ee7bfd0a..bbb9c02b 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -39,6 +39,7 @@ module Haddock.Utils ( -- * Doc markup markup, idMarkup, + mkMeta, -- * List utilities replace, @@ -56,6 +57,7 @@ module Haddock.Utils ( ) where +import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils @@ -110,14 +112,16 @@ out progVerbosity msgVerbosity msg -- | Extract a module's short description. -toDescription :: Interface -> Maybe (Doc Name) -toDescription = hmi_description . ifaceInfo +toDescription :: Interface -> Maybe (MDoc Name) +toDescription = fmap mkMeta . hmi_description . ifaceInfo -- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) -toInstalledDescription = hmi_description . instInfo +toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) +toInstalledDescription = fmap mkMeta . hmi_description . instInfo +mkMeta :: Doc a -> MDoc a +mkMeta x = emptyMetaDoc { _doc = x } -------------------------------------------------------------------------------- -- * Making abstract declarations |