aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-12-09 07:00:07 +0000
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-12-10 00:58:24 +0000
commit12a066d96332b40f346621c9376c5c7328c92a0b (patch)
treecdfff73571b8c437a19d85035d28c639c77557cf /haddock-api/src
parentc67e63a1a426dc311ce4b1ad7c628b842d87024c (diff)
Allow the parser to spit out meta-info
Currently we only use it only for ‘since’ annotations but with these patches it should be fairly simple to add new attributes if we wish to. Closes #26. It seems to work fine but due to 7.10 rush I don't have the chance to do more exhaustive testing right now. The way the meta is output (emphasis at the end of the whole comment) is fairly arbitrary and subject to bikeshedding. Note that this makes test for Bug310 fail due to interface version bump: it can't find the docs for base with this interface version so it fails. There is not much we can do to help this because it tests for ’built-in’ identifier, not something we can provide ourselves.
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs9
-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
16 files changed, 144 insertions, 102 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 631f813b..2aa8ff7f 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -283,12 +283,15 @@ render dflags flags qual ifaces installedIfaces srcMap = do
pretty
copyHtmlBits odir libDir themes
+ -- TODO: we throw away Meta for both Hoogle and LaTeX right now,
+ -- might want to fix that if/when these two get some work on them
when (Flag_Hoogle `elem` flags) $ do
let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
- ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
+ ppHoogle dflags pkgName2 pkgVer title (fmap _doc prologue) visibleIfaces
+ odir
when (Flag_LaTeX `elem` flags) $ do
- ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
+ ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
libDir
@@ -449,7 +452,7 @@ updateHTMLXRefs packages = do
mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
-getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))
+getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue dflags flags =
case [filename | Flag_Prologue filename <- flags ] of
[] -> return Nothing
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