diff options
22 files changed, 407 insertions, 112 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 diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs index 1c20555d..fe8cf99b 100644 --- a/haddock-library/src/Documentation/Haddock/Doc.hs +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -1,12 +1,30 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Documentation.Haddock.Doc (docParagraph, docAppend, docConcat) where +module Documentation.Haddock.Doc (docParagraph, docAppend, + docConcat, metaDocConcat, + metaDocAppend, emptyMetaDoc) where +import Data.Monoid (mempty, (<>)) import Documentation.Haddock.Types import Data.Char (isSpace) docConcat :: [DocH mod id] -> DocH mod id docConcat = foldr docAppend DocEmpty +-- | Like 'docConcat' but also joins the 'Meta' info. +metaDocConcat :: [MetaDoc mod id] -> MetaDoc mod id +metaDocConcat = foldr metaDocAppend emptyMetaDoc + +-- | We do something perhaps unexpected here and join the meta info +-- in ‘reverse’: this results in the metadata from the ‘latest’ +-- paragraphs taking precedence. +metaDocAppend :: MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id +metaDocAppend (MetaDoc { _meta = m, _doc = d }) + (MetaDoc { _meta = m', _doc = d' }) = + MetaDoc { _meta = m' <> m, _doc = d `docAppend` d' } + +emptyMetaDoc :: MetaDoc mod id +emptyMetaDoc = MetaDoc { _meta = mempty, _doc = DocEmpty } + docAppend :: DocH mod id -> DocH mod id -> DocH mod id docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 1cc277b8..b88a8c7f 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -86,9 +86,11 @@ parse p = either err id . parseOnly (p <* endOfInput) -- | Main entry point to the parser. Appends the newline character -- to the input string. parseParas :: String -- ^ String to parse - -> (Maybe Version, DocH mod Identifier) + -> MetaDoc mod Identifier parseParas input = case parseParasState input of - (state, a) -> (parserStateSince state, a) + (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state } + , _doc = a + } parseParasState :: String -> (ParserState, DocH mod Identifier) parseParasState = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 92ddeb7e..6f22efb5 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -15,8 +15,28 @@ module Documentation.Haddock.Types where import Data.Foldable +import Data.Monoid import Data.Traversable +-- | With the advent of 'Version', we may want to start attaching more +-- meta-data to comments. We make a structure for this ahead of time +-- so we don't have to gut half the core each time we want to add such +-- info. +newtype Meta = Meta { _version :: Maybe Version } deriving (Eq, Show) + +instance Monoid Meta where + mempty = Meta { _version = Nothing } + Meta { _version = v } `mappend` Meta { _version = v' } = + Meta { _version = v `mappend` v' } + +data MetaDoc mod id = + MetaDoc { _meta :: Meta + , _doc :: DocH mod id + } deriving (Eq, Show, Functor, Foldable, Traversable) + +overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d +overDoc f d = d { _doc = f $ _doc d } + type Version = [Int] data Hyperlink = Hyperlink diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 7b0ef78d..44ec2988 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -22,8 +22,8 @@ instance IsString (Doc String) where instance IsString a => IsString (Maybe a) where fromString = Just . fromString -parseParas :: String -> (Maybe Version, Doc String) -parseParas = fmap Parse.toRegular . Parse.parseParas +parseParas :: String -> MetaDoc () String +parseParas = overDoc Parse.toRegular . Parse.parseParas parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString @@ -358,7 +358,7 @@ spec = do describe "parseParas" $ do let infix 1 `shouldParseTo` shouldParseTo :: String -> Doc String -> Expectation - shouldParseTo input ast = snd (parseParas input) `shouldBe` ast + shouldParseTo input ast = _doc (parseParas input) `shouldBe` ast it "is total" $ do property $ \xs -> @@ -366,13 +366,20 @@ spec = do context "when parsing @since" $ do it "adds specified version to the result" $ do - parseParas "@since 0.5.0" `shouldBe` (Just [0,5,0], DocEmpty) + parseParas "@since 0.5.0" `shouldBe` + MetaDoc { _meta = Meta { _version = Just [0,5,0] } + , _doc = DocEmpty } it "ignores trailing whitespace" $ do - parseParas "@since 0.5.0 \t " `shouldBe` (Just [0,5,0], DocEmpty) + parseParas "@since 0.5.0 \t " `shouldBe` + MetaDoc { _meta = Meta { _version = Just [0,5,0] } + , _doc = DocEmpty } it "does not allow trailing input" $ do - parseParas "@since 0.5.0 foo" `shouldBe` (Nothing, DocParagraph "@since 0.5.0 foo") + parseParas "@since 0.5.0 foo" `shouldBe` + MetaDoc { _meta = Meta { _version = Nothing } + , _doc = DocParagraph "@since 0.5.0 foo" } + context "when given multiple times" $ do it "gives last occurrence precedence" $ do @@ -380,7 +387,9 @@ spec = do "@since 0.5.0" , "@since 0.6.0" , "@since 0.7.0" - ] `shouldBe` (Just [0,7,0], DocEmpty) + ] `shouldBe` MetaDoc { _meta = Meta { _version = Just [0,7,0] } + , _doc = DocEmpty } + context "when parsing text paragraphs" $ do let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html new file mode 100644 index 00000000..117286ce --- /dev/null +++ b/html-test/ref/Bug26.html @@ -0,0 +1,175 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug26</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_Bug26.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe-Inferred</td + ></tr + ></table + ><p class="caption" + >Bug26</p + ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><p + >This module tests the ‘@since …’ annotation.</p + ><p + ><em + >Since: 1.2.3</em + ></p + ></div + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >f</a + > :: ()</li + ><li class="src short" + ><a href="" + >g</a + > :: ()</li + ><li class="src short" + ><span class="keyword" + >class</span + > <a href="" + >C</a + > a <span class="keyword" + >where</span + ><ul class="subs" + ><li + ><a href="" + >c_f</a + > :: a</li + ></ul + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:f" class="def" + >f</a + > :: ()</p + ><div class="doc" + ><p + >Foo</p + ><p + ><em + >Since: 2.10.8</em + ></p + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:g" class="def" + >g</a + > :: ()</p + ><div class="doc" + ><p + >Bar</p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a name="t:C" class="def" + >C</a + > a <span class="keyword" + >where</span + ></p + ><div class="doc" + ><p + >Class</p + ><p + ><em + >Since: 1.0</em + ></p + ></div + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a name="v:c_f" class="def" + >c_f</a + > :: a</p + ><div class="doc" + ><p + ><em + >Since: 1.2.3</em + ></p + ></div + ></div + ><div class="subs instances" + ><p id="control.i:C" class="caption collapser" onclick="toggleSection('i:C')" + >Instances</p + ><div id="section.i:C" class="show" + ><table + ><tr + ><td class="src" + ><a href="" + >C</a + > ()</td + ><td class="doc" + ><p + >instance for ()</p + ><p + ><em + >Since: 0.7.8</em + ></p + ></td + ></tr + ></table + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.15.1</p + ></div + ></body + ></html +> diff --git a/html-test/src/Bug26.hs b/html-test/src/Bug26.hs new file mode 100644 index 00000000..b0483f03 --- /dev/null +++ b/html-test/src/Bug26.hs @@ -0,0 +1,29 @@ +-- | This module tests the ‘@since …’ annotation. +-- +-- @since 1.2.3 +module Bug26 where + +-- | Foo +-- +-- @since 2.10.7 +-- +-- @since 2.10.8 +f :: () +f = () + +-- | Bar +g :: () +g = () + +-- | Class +-- +-- @since 1.0 +class C a where + -- | @since 1.2.3 + c_f :: a + +-- | instance for () +-- +-- @since 0.7.8 +instance C () where + c_f = () |