aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs13
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs82
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs2
-rw-r--r--haddock-api/src/Haddock/Doc.hs7
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs19
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs35
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs5
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs15
-rw-r--r--haddock-api/src/Haddock/ModuleTree.hs10
-rw-r--r--haddock-api/src/Haddock/Parser.hs4
-rw-r--r--haddock-api/src/Haddock/Types.hs15
-rw-r--r--haddock-api/src/Haddock/Utils.hs12
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 23:46:45 +0000