aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-03-26 23:35:59 -0700
committerAlexander Biehl <alexbiehl@gmail.com>2018-03-27 08:35:59 +0200
commit978dbc859df09eb991d9ccc0911276cc9655b783 (patch)
tree8082d90d0c73db65292ba844e19ae92c3e9ad1a6 /haddock-api/src
parentd270aeee23427c8cfe582549ead8f495704603f6 (diff)
@since includes package name (#749)
* Metadoc stores a package name This means that '@since' annotations can be package aware. * Get the package name the right way This should extract the package name for `@since` annotations the right way. I had to move `modulePackageInfo` around to do this and, in the process, I took the liberty to update it. Since it appears that finding the package name is something that can fail, I added a warning for this case. * Silence warnings * Hide package for local 'since' annotations As discussed, this is still the usual case (and we should avoid being noisy for it). Although this commit is large, it is basically only about threading a 'Maybe Package' from 'Haddock.render' all the way to 'Haddock.Backends.Xhtml.DocMarkup.renderMeta'. * Bump binary interface version * Add a '--since-qual' option This controls when to qualify since annotations with the package they come from. The default is always, but I've left an 'external' variant where only those annotations coming from outside of the current package are qualified. * Make ParserSpec work * Make Fixtures work * Use package name even if package version is not available The @since stuff needs only the package name passed in, so it makes sense to not be forced to pass in a version too.
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs72
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs110
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs147
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs50
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs57
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs48
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs6
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs11
-rw-r--r--haddock-api/src/Haddock/Options.hs39
-rw-r--r--haddock-api/src/Haddock/Parser.hs4
-rw-r--r--haddock-api/src/Haddock/Types.hs6
12 files changed, 319 insertions, 252 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dc903e08..00eb50f6 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -25,7 +25,6 @@ module Haddock (
withGhc
) where
-import Data.Version
import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Meta
import Haddock.Backends.Xhtml.Themes (getThemes)
@@ -42,7 +41,6 @@ import Haddock.Options
import Haddock.Utils
import Control.Monad hiding (forM_)
-import Control.Applicative
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
@@ -151,7 +149,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- or which exits with an error or help message.
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
- qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
+ qual <- rightOrThrowE (qualification flags)
+ sinceQual <- rightOrThrowE (sinceQualification flags)
-- inject dynamic-too into flags before we proceed
flags' <- ghc flags $ do
@@ -184,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags flags qual packages ifaces
+ liftIO $ renderStep dflags flags sinceQual qual packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -194,7 +193,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags flags qual packages []
+ liftIO $ renderStep dflags flags sinceQual qual packages []
-- | Create warnings about potential misuse of -optghc
warnings :: [String] -> [String]
@@ -228,8 +227,9 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags qual pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
+ -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
@@ -238,12 +238,12 @@ renderStep dflags flags qual pkgs interfaces = do
((_, Just path), ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
-
- render dflags flags qual interfaces installedIfaces extSrcMap
+ render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags flags qual ifaces installedIfaces extSrcMap = do
+render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
+ -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -270,6 +270,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
pkgKey = moduleUnitId pkgMod
pkgStr = Just (unitIdString pkgKey)
pkgNameVer = modulePackageInfo dflags flags pkgMod
+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
+ sincePkg = case sinceQual of
+ External -> pkgName
+ Always -> Nothing
(srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
@@ -338,7 +342,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
ppHtmlContents dflags' odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
allVisibleIfaces True prologue pretty
- (makeContentsQual qual)
+ sincePkg (makeContentsQual qual)
return ()
copyHtmlBits odir libDir themes withQuickjump
@@ -348,7 +352,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
prologue
themes opt_mathjax sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode qual
+ opt_contents_url opt_index_url unicode sincePkg qual
pretty withQuickjump
return ()
copyHtmlBits odir libDir themes withQuickjump
@@ -358,7 +362,12 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
-- might want to fix that if/when these two get some work on them
when (Flag_Hoogle `elem` flags) $ do
case pkgNameVer of
- Nothing -> putStrLn . unlines $
+ (Just (PackageName pkgNameFS), Just pkgVer) ->
+ let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
+ | otherwise = unpackFS pkgNameFS
+ in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+ visibleIfaces odir
+ _ -> putStrLn . unlines $
[ "haddock: Unable to find a package providing module "
++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
, ""
@@ -366,14 +375,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
++ " using the --package-name"
, " and --package-version arguments."
]
- Just (PackageName pkgNameFS, pkgVer) ->
- let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
- | otherwise = unpackFS pkgNameFS
- in withTiming (pure dflags') "ppHoogle" (const ()) $ do
- _ <- {-# SCC ppHoogle #-}
- ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
- visibleIfaces odir
- return ()
when (Flag_LaTeX `elem` flags) $ do
withTiming (pure dflags') "ppLatex" (const ()) $ do
@@ -388,26 +389,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
return ()
--- | From GHC 7.10, this function has a potential to crash with a
--- nasty message such as @expectJust getPackageDetails@ because
--- package name and versions can no longer reliably be extracted in
--- all cases: if the package is not installed yet then this info is no
--- longer available. The @--package-name@ and @--package-version@
--- Haddock flags allow the user to specify this information and it is
--- returned here if present: if it is not present, the error will
--- occur. Nasty but that's how it is for now. Potential TODO.
-modulePackageInfo :: DynFlags
- -> [Flag] -- ^ Haddock flags are checked as they may
- -- contain the package name or version
- -- provided by the user which we
- -- prioritise
- -> Module -> Maybe (PackageName, Data.Version.Version)
-modulePackageInfo dflags flags modu =
- cmdline <|> pkgDb
- where
- cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
- pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)
-
-------------------------------------------------------------------------------
-- * Reading and dumping interface files
@@ -628,10 +609,15 @@ getPrologue dflags flags =
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! parseParas dflags str
+ return . Just $! parseParas dflags Nothing str
_ -> throwE "multiple -p/--prologue options"
+rightOrThrowE :: Either String b -> IO b
+rightOrThrowE (Left msg) = throwE msg
+rightOrThrowE (Right x) = pure x
+
+
#ifdef IN_GHC_TREE
getInTreeDir :: IO String
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index d03cf0ba..c9a262a4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -70,6 +70,7 @@ ppHtml :: DynFlags
-> Maybe String -- ^ The contents URL (--use-contents)
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
+ -> Maybe String -- ^ Package name
-> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> Bool -- ^ Also write Quickjump index
@@ -78,7 +79,7 @@ ppHtml :: DynFlags
ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode
- qual debug withQuickjump = do
+ pkg qual debug withQuickjump = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -88,7 +89,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces ++ reexported_ifaces)
False -- we don't want to display the packages in a single-package contents
- prologue debug (makeContentsQual qual)
+ prologue debug pkg (makeContentsQual qual)
when (isNothing maybe_index_url) $ do
ppHtmlIndex odir doctitle maybe_package
@@ -96,12 +97,12 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
(map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
when withQuickjump $
- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
visible_ifaces
mapM_ (ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
+ maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
@@ -258,11 +259,12 @@ ppHtmlContents
-> WikiURLs
-> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
-> Bool
+ -> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents dflags odir doctitle _maybe_package
themes mathjax_url maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
let tree = mkModuleTree dflags showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
@@ -276,41 +278,41 @@ ppHtmlContents dflags odir doctitle _maybe_package
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
- ppPrologue qual doctitle prologue,
- ppSignatureTree qual sig_tree,
- ppModuleTree qual tree
+ ppPrologue pkg qual doctitle prologue,
+ ppSignatureTree pkg qual sig_tree,
+ ppModuleTree pkg qual tree
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug 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))
+ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
+ppPrologue _ _ _ Nothing = noHtml
+ppPrologue pkg qual title (Just doc) =
+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))
-ppSignatureTree :: Qualification -> [ModuleTree] -> Html
-ppSignatureTree qual ts =
- divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppSignatureTree pkg qual ts =
+ divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
-ppModuleTree :: Qualification -> [ModuleTree] -> Html
-ppModuleTree _ [] = mempty
-ppModuleTree qual ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
+ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppModuleTree _ _ [] = mempty
+ppModuleTree pkg qual ts =
+ divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)
-mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
-mkNodeList qual ss p ts = case ts of
+mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList pkg qual ss p ts = case ts of
[] -> noHtml
- _ -> unordList (zipWith (mkNode qual ss) ps ts)
+ _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)
where
ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
-mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =
+mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
htmlModule <+> shortDescr +++ htmlPkg +++ subtree
where
modAttrs = case (ts, leaf) of
@@ -330,14 +332,14 @@ mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =
Nothing -> toHtml s
)
- shortDescr = maybe noHtml (origDocToHtml qual) short
+ shortDescr = maybe noHtml (origDocToHtml pkg qual) short
htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
subtree =
if null ts then noHtml else
collapseDetails p DetailsOpen (
thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++
- mkNodeList qual (s:ss) p ts
+ mkNodeList pkg qual (s:ss) p ts
)
@@ -350,10 +352,11 @@ ppJsonIndex :: FilePath
-> SourceURLs -- ^ The source URL (--source)
-> WikiURLs -- ^ The wiki URL (--wiki)
-> Bool
+ -> Maybe Package
-> QualOption
-> [Interface]
-> IO ()
-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do
createDirectoryIfMissing True odir
IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do
Builder.hPutBuilder h (encodeToBuilder modules)
@@ -371,7 +374,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
goExport mdl qual item
- | Just item_html <- processExport True links_info unicode qual item
+ | Just item_html <- processExport True links_info unicode pkg qual item
= [ Object
[ "display_html" .= String (showHtmlFragment item_html)
, "name" .= String (intercalate " " (map nameString names))
@@ -529,11 +532,11 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> Maybe String -> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool -> QualOption
+ -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug iface = do
+ maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
let
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
@@ -555,7 +558,7 @@ ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
]
createDirectoryIfMissing True odir
@@ -565,9 +568,9 @@ signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
-ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
- = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
+ = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++
description +++
synopsis +++
divInterface (maybe_doc_hdr +++ bdy +++ orphans)
@@ -585,7 +588,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
description | isNoHtml doc = doc
| otherwise = divDescription $ sectionName << "Description" +++ doc
- where doc = docSection Nothing qual (ifaceRnDoc iface)
+ where doc = docSection Nothing pkg qual (ifaceRnDoc iface)
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -595,7 +598,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
collapseDetails "syn" DetailsClosed (
thesummary << "Synopsis" +++
shortDeclList (
- mapMaybe (processExport True linksInfo unicode qual) exports
+ mapMaybe (processExport True linksInfo unicode pkg qual) exports
) ! collapseToggle "syn" ""
)
@@ -609,19 +612,20 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
bdy =
foldr (+++) noHtml $
- mapMaybe (processExport False linksInfo unicode qual) exports
+ mapMaybe (processExport False linksInfo unicode pkg qual) exports
orphans =
- ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual
+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual
linksInfo = (maybe_source_url, maybe_wiki_url)
-ppModuleContents :: Qualification
+ppModuleContents :: Maybe Package -- ^ This package
+ -> Qualification
-> [ExportItem DocNameI]
- -> Bool -- ^ Orphans sections
+ -> Bool -- ^ Orphans sections
-> Html
-ppModuleContents qual exports orphan
+ppModuleContents pkg qual exports orphan
| null sections && not orphan = noHtml
| otherwise = contentsDiv
where
@@ -641,7 +645,7 @@ ppModuleContents qual exports orphan
| otherwise = ( html:secs, rest2 )
where
html = linkedAnchor (groupId id0)
- << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs
+ << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
(secs, rest2) = process n rest1
process n (_ : rest) = process n rest
@@ -661,22 +665,22 @@ numberSectionHeadings = go 1
= other : go n es
-processExport :: Bool -> LinksInfo -> Bool -> Qualification
+processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> 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 (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
-processExport summary _ _ qual (ExportNoDecl y [])
+processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
+processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
+ = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)
+processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
+processExport summary _ _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
-processExport summary _ _ qual (ExportNoDecl y subs)
+processExport summary _ _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
ppDocName qual Prefix True y
+++ parenList (map (ppDocName qual Prefix True) subs)
-processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection_ Nothing qual doc
-processExport summary _ _ _ (ExportModule mdl)
+processExport summary _ _ pkg qual (ExportDoc doc)
+ = nothingIf summary $ docSection_ Nothing pkg qual doc
+processExport summary _ _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d92bdd3a..815ecee9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -43,17 +43,18 @@ import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
-> [(HsDecl DocNameI, DocForDecl DocName)]
-> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
- -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode
+ -> Maybe Package -> Qualification -> Html
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigWcType lty) fixities splice unicode qual
+ (hsSigWcType lty) fixities splice unicode pkg qual
SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
- ty fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ ty fixities splice unicode pkg qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ -> noHtml
DerivD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
@@ -61,28 +62,29 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
ppFunSig summary links loc doc (map unLoc lnames) lty fixities
- splice unicode qual
+ splice unicode pkg qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
- splice unicode qual HideEmptyContexts
+ splice unicode pkg qual HideEmptyContexts
where
pp_typ = ppLType unicode qual HideEmptyContexts typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsSigType DocNameI ->
[(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice
+ unicode pkg qual
| summary = pref1
| otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
- +++ docSection Nothing qual doc
+ +++ docSection Nothing pkg qual doc
where
pref1 = hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
@@ -92,15 +94,15 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
- Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
- splice unicode qual emptyCtxts =
+ splice unicode pkg qual emptyCtxts =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
, addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
- splice unicode qual emptyCtxts
+ splice unicode pkg qual emptyCtxts
where
occnames = map (nameOccName . getName) docnames
addFixities html
@@ -110,12 +112,14 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
- -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
+ -> Splice -> Unicode -> Maybe Package -> Qualification
+ -> HideEmptyContexts -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
+ splice unicode pkg qual emptyCtxts
| summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
| otherwise = topDeclElem links loc splice docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc
+ subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc
where
curName = getName <$> listToMaybe docnames
argDoc n = Map.lookup n argDocs
@@ -181,23 +185,23 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
- splice unicode qual
- = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
-ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
+ splice unicode pkg qual
+ = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
+ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
-> DocForDecl DocName -> TyClDecl DocNameI
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype })
- splice unicode qual
+ splice unicode pkg qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
- splice unicode qual ShowEmptyToplevelContexts
+ splice unicode pkg qual ShowEmptyToplevelContexts
where
hdr = hsep ([keyword "type", ppBinder summary occ]
++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
@@ -206,7 +210,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
fixs
| summary = noHtml
| otherwise = ppFixities fixities qual
-ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html
@@ -297,11 +301,13 @@ ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
[(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
+ FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->
+ Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode
+ pkg qual
| summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit
where
docname = unLoc $ fdLName decl
@@ -312,10 +318,10 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
instancesBit
| FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
, not summary
- = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
+ = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
| otherwise
- = ppInstances links (OriginFamily docname) instances splice unicode qual
+ = ppInstances links (OriginFamily docname) instances splice unicode pkg qual
-- Individual equation of a closed type family
ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
@@ -343,9 +349,10 @@ ppPseudoFamilyDecl links splice unicode qual
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
- -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package
+ -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
--------------------------------------------------------------------------------
@@ -454,22 +461,22 @@ ppFds fds unicode qual =
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
-> [(DocName, DocForDecl DocName)]
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
, tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
- subdocs splice unicode qual =
+ subdocs splice unicode pkg qual =
if not (any isUserLSig sigs) && null ats
then (if summary then id else topDeclElem links loc splice [nm]) hdr
else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+++ shortSubDecls False
(
- [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
+ [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats
, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
[ ppFunSig summary links loc doc names (hsSigWcType typ)
- [] splice unicode qual
+ [] splice unicode pkg qual
| L _ (TypeSig lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -480,20 +487,20 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
nm = unLoc lname
-ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]
-> SrcSpan -> Documentation DocName
-> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
- splice unicode qual
- | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
- | otherwise = classheader +++ docSection Nothing qual d
+ splice unicode pkg qual
+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
+ | otherwise = classheader +++ docSection Nothing pkg qual d
+++ minimalBit +++ atBit +++ methodBit +++ instancesBit
where
sigs = map unLoc lsigs
@@ -510,14 +517,14 @@ ppClassDecl summary links instances fixities loc d subdocs
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual
| at <- ats
, let n = unL . fdLName $ unL at
doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
- subfixs splice unicode qual
+ subfixs splice unicode pkg qual
| L _ (ClassOpSig _ lnames typ) <- lsigs
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
@@ -551,17 +558,17 @@ ppClassDecl summary links instances fixities loc d subdocs
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
instancesBit = ppInstances links (OriginClass nm) instances
- splice unicode qual
+ splice unicode pkg qual
-ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppInstances :: LinksInfo
-> InstOrigin DocName -> [DocInstance DocNameI]
- -> Splice -> Unicode -> Qualification
+ -> Splice -> Unicode -> Maybe Package -> Qualification
-> Html
-ppInstances links origin instances splice unicode qual
- = subInstances qual instName links True (zipWith instDecl [1..] instances)
+ppInstances links origin instances splice unicode pkg qual
+ = subInstances pkg qual instName links True (zipWith instDecl [1..] instances)
-- force Splice = True to use line URLs
where
instName = getOccString origin
@@ -572,10 +579,10 @@ ppInstances links origin instances splice unicode qual
ppOrphanInstances :: LinksInfo
-> [DocInstance DocNameI]
- -> Splice -> Unicode -> Qualification
+ -> Splice -> Unicode -> Maybe Package -> Qualification
-> Html
-ppOrphanInstances links instances splice unicode qual
- = subOrphanInstances qual links True (zipWith instDecl [1..] instances)
+ppOrphanInstances links instances splice unicode pkg qual
+ = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances)
where
instOrigin :: InstHead name -> InstOrigin (IdP name)
instOrigin inst = OriginClass (ihdClsName inst)
@@ -713,12 +720,12 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
[(HsDecl DocNameI, DocForDecl DocName)] ->
- Splice -> Unicode -> Qualification -> Html
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
- splice unicode qual
+ splice unicode pkg qual
| summary = ppShortDataDecl summary False dataDecl pats unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -738,14 +745,14 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
| null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
- constrBit = subConstructors qual
- [ ppSideBySideConstr subdocs subfixs unicode qual c
+ constrBit = subConstructors pkg qual
+ [ ppSideBySideConstr subdocs subfixs unicode pkg qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
(map unLoc (getConNames (unLoc c)))) fixities
]
- patternBit = subPatterns qual
+ patternBit = subPatterns pkg qual
[ (hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
@@ -757,7 +764,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
]
instancesBit = ppInstances links (OriginData docname) instances
- splice unicode qual
+ splice unicode pkg qual
@@ -824,8 +831,8 @@ ppConstrHdr forall_ tvs ctxt unicode qual
| otherwise = noHtml
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L _ con)
+ -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl
+ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
= (decl, mbDoc, fieldPart)
where
decl = case con of
@@ -851,7 +858,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
RecCon (L _ fields) -> [doRecordFields fields]
_ -> []
- doRecordFields fields = subFields qual
+ doRecordFields fields = subFields pkg qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
doGADTCon :: Located (HsType DocNameI) -> Html
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 2990e1e4..ed323a90 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -171,10 +171,10 @@ flatten x = [x]
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- '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' =
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup fmt' currPkg h' =
let (html, ms) = hackMarkup' fmt' h'
- in html +++ renderMeta fmt' (metaConcat ms)
+ in html +++ renderMeta fmt' currPkg (metaConcat ms)
where
hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
-> (Html, [Meta])
@@ -193,45 +193,50 @@ hackMarkup fmt' h' =
(y, m') = hackMarkup' fmt d'
in (markupAppend fmt x y, m ++ m')
-renderMeta :: DocMarkup id Html -> Meta -> Html
-renderMeta fmt (Meta { _version = Just x }) =
+renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html
+renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) =
markupParagraph fmt . markupEmphasis fmt . toHtml $
- "Since: " ++ formatVersion x
+ "Since: " ++ formatPkgMaybe pkg ++ formatVersion x
where
formatVersion v = concat . intersperse "." $ map show v
-renderMeta _ _ = noHtml
+ formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"
+ formatPkgMaybe _ = ""
+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 first.
markupHacked :: DocMarkup id Html
+ -> Maybe Package -- this package
-> Maybe String
-> MDoc id
-> Html
-markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten
+markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten
-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- 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.
+docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
+ -- comments on 'toHack' for details.
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docToHtml n qual = markupHacked fmt n . cleanup
+docToHtml n pkg qual = markupHacked fmt pkg 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'
+docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup
+docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
-origDocToHtml :: Qualification -> MDoc Name -> Html
-origDocToHtml qual = markupHacked fmt Nothing . cleanup
+origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
+origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
where fmt = parHtmlMarkup qual True (const $ ppName Raw)
-rdrDocToHtml :: Qualification -> MDoc RdrName -> Html
-rdrDocToHtml qual = markupHacked fmt Nothing . cleanup
+rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
+rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
where fmt = parHtmlMarkup qual True (const ppRdrName)
@@ -243,14 +248,17 @@ docElement el content_ =
docSection :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Maybe Package -- ^ Current package
-> Qualification -> Documentation DocName -> Html
-docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation
+docSection n pkg qual =
+ maybe noHtml (docSection_ n pkg qual) . combineDocumentation
-docSection_ :: Maybe Name -- ^ Name of the thing this doc is for
+docSection_ :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docSection_ n qual =
- (docElement thediv <<) . docToHtml (getOccString <$> n) qual
+docSection_ n pkg qual =
+ (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual
cleanup :: MDoc a -> MDoc a
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 217ca2af..501caa4b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -128,38 +128,39 @@ divSubDecls cssClass captionName = maybe noHtml wrap
subCaption = paragraph ! [theclass "caption"] << captionName
-subDlist :: Qualification -> [SubDecl] -> Maybe Html
-subDlist _ [] = Nothing
-subDlist qual decls = Just $ ulist << map subEntry decls
+subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
+subDlist _ _ [] = Nothing
+subDlist pkg qual decls = Just $ ulist << map subEntry decls
where
subEntry (decl, mdoc, subs) =
li <<
(define ! [theclass "src"] << decl +++
- docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))
+ docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs))
-subTable :: Qualification -> [SubDecl] -> Maybe Html
-subTable _ [] = Nothing
-subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
+subTable _ _ [] = Nothing
+subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)
where
subRow (decl, mdoc, subs) =
(td ! [theclass "src"] << decl
<->
- docElement td << fmap (docToHtml Nothing qual) mdoc)
+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc)
: map (cell . (td <<)) subs
-- | Sub table with source information (optional).
-subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html
-subTableSrc _ _ _ [] = Nothing
-subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
+subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool
+ -> [(SubDecl,Located DocName)] -> Maybe Html
+subTableSrc _ _ _ _ [] = Nothing
+subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
where
subRow ((decl, mdoc, subs),L loc dn) =
(td ! [theclass "src clearfix"] <<
(thespan ! [theclass "inst-left"] << decl)
<+> linkHtml loc dn
<->
- docElement td << fmap (docToHtml Nothing qual) mdoc
+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc
)
: map (cell . (td <<)) subs
linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn
@@ -170,49 +171,49 @@ subBlock [] = Nothing
subBlock hs = Just $ toHtml hs
-subArguments :: Qualification -> [SubDecl] -> Html
-subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual
subAssociatedTypes :: [Html] -> Html
subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
-subConstructors :: Qualification -> [SubDecl] -> Html
-subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual
-subPatterns :: Qualification -> [SubDecl] -> Html
-subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual
-subFields :: Qualification -> [SubDecl] -> Html
-subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual
-subEquations :: Qualification -> [SubDecl] -> Html
-subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual
-- | Generate sub table for instance declarations, with source
-subInstances :: Qualification
+subInstances :: Maybe Package -> Qualification
-> String -- ^ Class name, used for anchor generation
-> LinksInfo -> Bool
-> [(SubDecl,Located DocName)] -> Html
-subInstances qual nm lnks splice = maybe noHtml wrap . instTable
+subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
where
wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))
- instTable = subTableSrc qual lnks splice
+ instTable = subTableSrc pkg qual lnks splice
subSection = thediv ! [theclass "subs instances"]
summary = thesummary << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
-subOrphanInstances :: Qualification
+subOrphanInstances :: Maybe Package -> Qualification
-> LinksInfo -> Bool
-> [(SubDecl,Located DocName)] -> Html
-subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable
+subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
wrap = ((h1 << "Orphan instances") +++)
- instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice
+ instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice
id_ = makeAnchorId $ "orphans"
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index deef7ad3..a35e2053 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -46,7 +46,6 @@ import Data.Traversable
import Avail hiding (avail)
import qualified Avail
-import qualified Packages
import qualified Module
import qualified SrcLoc
import ConLike (ConLike(..))
@@ -55,13 +54,14 @@ import HscTypes
import Name
import NameSet
import NameEnv
+import Packages ( lookupModuleInAllPackages, PackageName(..) )
import Bag
import RdrName
import TcRnTypes
-import FastString (concatFS)
+import FastString ( concatFS, unpackFS )
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
-import HsDecls ( getConDetails )
+import HsDecls ( getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -85,12 +85,22 @@ createInterface tm flags modMap instIfaceMap = do
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
!exportedNames = modInfoExportsWithSelectors mi
+ (pkgNameFS, _) = modulePackageInfo dflags flags mdl
+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
(TcGblEnv { tcg_rdr_env = gre
, tcg_warns = warnings
, tcg_exports = all_exports
}, md) = tm_internals_ tm
+ -- The 'pkgName' is necessary to decide what package to mention in "@since"
+ -- annotations. Not having it is not fatal though.
+ --
+ -- Cabal can be trusted to pass the right flags, so this warning should be
+ -- mostly encountered when running Haddock outside of Cabal.
+ when (isNothing pkgName) $
+ liftErrMsg $ tell [ "Warning: Package name is not available." ]
+
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
(group_, imports, mayExports, mayDocHeader) <-
@@ -103,7 +113,7 @@ createInterface tm flags modMap instIfaceMap = do
opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
-- Process the top-level module header documentation.
- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
let declsWithDocs = topDecls group_
@@ -130,13 +140,13 @@ createInterface tm flags modMap instIfaceMap = do
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
maps@(!docMap, !argMap, !declMap, _) <-
- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
+ liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-- The MAIN functionality: compute the export items which will
-- each be the actual documentation of this module.
- exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre
+ exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre
exportedNames decls maps fixMap unrestrictedImportedMods
splices exports all_exports instIfaceMap dflags
@@ -190,6 +200,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+
-- | Given all of the @import M as N@ declarations in a package,
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
@@ -266,7 +277,7 @@ lookupModuleDyn ::
lookupModuleDyn _ (Just pkgId) mdlName =
Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
- case Packages.lookupModuleInAllPackages dflags mdlName of
+ case lookupModuleInAllPackages dflags mdlName of
(m,_):_ -> m
[] -> Module.mkModule Module.mainUnitId mdlName
@@ -346,11 +357,12 @@ type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap)
-- find its names, its subordinates, and its doc strings. Process doc strings
-- into 'Doc's.
mkMaps :: DynFlags
+ -> Maybe Package -- this package
-> GlobalRdrEnv
-> [Name]
-> [(LHsDecl GhcRn, [HsDocString])]
-> ErrMsgM Maps
-mkMaps dflags gre instances decls = do
+mkMaps dflags pkgName gre instances decls = do
(a, b, c) <- unzip3 <$> traverse mappings decls
pure ( f' (map (nubByName fst) a)
, f (filterMapping (not . M.null) b)
@@ -377,8 +389,8 @@ mkMaps dflags gre instances decls = do
declDoc :: [HsDocString] -> Map Int HsDocString
-> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
declDoc strs m = do
- doc' <- processDocStrings dflags gre strs
- m' <- traverse (processDocStringParas dflags gre) m
+ doc' <- processDocStrings dflags pkgName gre strs
+ m' <- traverse (processDocStringParas dflags pkgName gre) m
pure (doc', m')
(doc, args) <- declDoc docStrs (typeDocs decl)
@@ -605,12 +617,13 @@ collectDocs = go Nothing []
mkExportItems
:: Bool -- is it a signature
-> IfaceMap
+ -> Maybe Package -- this package
-> Module -- this module
-> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
+ -> [LHsDecl GhcRn] -- renamed source declarations
-> Maps
-> FixMap
-> M.Map ModuleName [ModuleName]
@@ -621,12 +634,12 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem GhcRn]
mkExportItems
- is_sig modMap thisMod semMod warnings gre exportedNames decls
+ is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
maps fixMap unrestricted_imp_mods splices exportList allExports
instIfaceMap dflags =
case exportList of
Nothing ->
- fullModuleContents is_sig modMap thisMod semMod warnings gre
+ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre
exportedNames decls maps fixMap splices instIfaceMap dflags
allExports
Just exports -> liftM concat $ mapM lookupExport exports
@@ -636,14 +649,14 @@ mkExportItems
return [ExportGroup lev "" doc]
lookupExport (IEDoc docStr, _) = liftErrMsg $ do
- doc <- processDocStringParas dflags gre docStr
+ doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
lookupExport (IEDocNamed str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
- doc <- processDocStringParas dflags gre docStr
+ doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
lookupExport (IEModuleContents (L _ mod_name), _)
@@ -962,6 +975,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
fullModuleContents :: Bool -- is it a signature
-> IfaceMap
+ -> Maybe Package -- this package
-> Module -- this module
-> Module -- semantic module
-> WarningMap
@@ -975,7 +989,7 @@ fullModuleContents :: Bool -- is it a signature
-> DynFlags
-> Avails
-> ErrMsgGhc [ExportItem GhcRn]
-fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames
+fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
let availEnv = availsToNameEnv (nubAvails avails)
(concat . concat) `fmap` (for decls $ \decl -> do
@@ -984,7 +998,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames
doc <- liftErrMsg (processDocString dflags gre docStr)
return [[ExportGroup lev "" doc]]
(L _ (DocD (DocCommentNamed _ docStr))) -> do
- doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
return [[ExportDoc doc]]
(L _ (ValD valDecl))
| name:_ <- collectHsBindBinders valDecl
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 1269df3f..9a978f9f 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -33,34 +33,35 @@ import RdrName
import EnumSet
import RnEnv (dataTcOccs)
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
+processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
-processDocStrings dflags gre strs = do
- mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
+processDocStrings dflags pkg gre strs = do
+ mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs
case mdoc 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 } -> pure Nothing
+ MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing
x -> pure (Just x)
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
-processDocStringParas dflags gre (HsDocString fs) =
- overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString
+ -> ErrMsgM (MDoc Name)
+processDocStringParas dflags pkg gre (HsDocString fs) =
+ overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre (HsDocString fs) =
rename dflags gre $ parseString dflags (unpackFS fs)
-processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
-processModuleHeader dflags gre safety mayStr = do
+processModuleHeader dflags pkgName gre safety mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
- (hmi, doc) = parseModuleHeader dflags str
+ (hmi, doc) = parseModuleHeader dflags pkgName str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
Nothing -> pure Nothing
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 6690c22d..050901b6 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -24,8 +24,8 @@ 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, MDoc RdrName)
-parseModuleHeader dflags str0 =
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader dflags pkgName str0 =
let
getKey :: String -> String -> (Maybe String,String)
getKey key str = case parseKey key str of
@@ -52,7 +52,7 @@ parseModuleHeader dflags str0 =
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags str9)
+ }, parseParas dflags pkgName str9)
-- | This function is how we read keys.
--
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index bbd8d04e..d5bbce2c 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
-binaryInterfaceVersion = 32
+binaryInterfaceVersion = 33
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -486,8 +486,13 @@ instance Binary a => Binary (TableCell a) where
return (TableCell i j c)
instance Binary Meta where
- put_ bh Meta { _version = v } = put_ bh v
- get bh = (\v -> Meta { _version = v }) <$> get bh
+ put_ bh (Meta v p) = do
+ put_ bh v
+ put_ bh p
+ get bh = do
+ v <- get bh
+ p <- get bh
+ return (Meta v p)
instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where
put_ bh MetaDoc { _meta = m, _doc = d } = do
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 0609aa63..b5e987d8 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -29,19 +29,23 @@ module Haddock.Options (
optLaTeXStyle,
optMathjax,
qualification,
+ sinceQualification,
verbosity,
ghcFlags,
reexportFlags,
readIfaceArgs,
optPackageName,
- optPackageVersion
+ optPackageVersion,
+ modulePackageInfo
) where
import qualified Data.Char as Char
import Data.Version
+import Control.Applicative
import Distribution.Verbosity
import FastString
+import GHC ( DynFlags, Module, moduleUnitId )
import Haddock.Types
import Haddock.Utils
import Packages
@@ -103,6 +107,7 @@ data Flag
| Flag_PackageName String
| Flag_PackageVersion String
| Flag_Reexport String
+ | Flag_SinceQualification String
deriving (Eq, Show)
@@ -210,7 +215,9 @@ options backwardsCompat =
Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
"name of the package being documented",
Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
- "version of the package being documented in usual x.y.z.w format"
+ "version of the package being documented in usual x.y.z.w format",
+ Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
+ "package qualification of @since, one of\n'always' (default) or 'only-external'"
]
@@ -310,6 +317,14 @@ qualification flags =
[arg] -> Left $ "unknown qualification type " ++ show arg
_:_ -> Left "qualification option given multiple times"
+sinceQualification :: [Flag] -> Either String SinceQual
+sinceQualification flags =
+ case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of
+ [] -> Right Always
+ ["always"] -> Right Always
+ ["external"] -> Right External
+ [arg] -> Left $ "unknown since-qualification type " ++ show arg
+ _:_ -> Left "since-qualification option given multiple times"
verbosity :: [Flag] -> Verbosity
verbosity flags =
@@ -344,3 +359,23 @@ readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
optLast :: [a] -> Maybe a
optLast [] = Nothing
optLast xs = Just (last xs)
+
+
+-- | This function has a potential to return 'Nothing' because package name and
+-- versions can no longer reliably be extracted in all cases: if the package is
+-- not installed yet then this info is no longer available.
+--
+-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
+-- specify this information manually and it is returned here if present.
+modulePackageInfo :: DynFlags
+ -> [Flag] -- ^ Haddock flags are checked as they may contain
+ -- the package name or version provided by the user
+ -- which we prioritise
+ -> Module
+ -> (Maybe PackageName, Maybe Data.Version.Version)
+modulePackageInfo dflags flags modu =
+ ( optPackageName flags <|> fmap packageName pkgDb
+ , optPackageVersion flags <|> fmap packageVersion pkgDb
+ )
+ where
+ pkgDb = lookupPackage dflags (moduleUnitId modu)
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index 47bf814b..58500f1b 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 -> MetaDoc mod RdrName
-parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName
+parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
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 2810862f..36ed7baf 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -578,6 +578,12 @@ data HideEmptyContexts
= HideEmptyContexts
| ShowEmptyToplevelContexts
+-- | When to qualify @since@ annotations with their package
+data SinceQual
+ = Always
+ | External -- ^ only qualify when the thing being annotated is from
+ -- an external package
+
-----------------------------------------------------------------------------
-- * Error handling
-----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 17:31:09 +0000