aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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
-rw-r--r--haddock-library/fixtures/Fixtures.hs2
-rw-r--r--haddock-library/src/Documentation/Haddock/Doc.hs8
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs9
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs5
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs17
17 files changed, 346 insertions, 266 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
-----------------------------------------------------------------------------
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index 282fd10d..a4e4321f 100644
--- a/haddock-library/fixtures/Fixtures.hs
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -102,7 +102,7 @@ acceptFixtures = traverse_ $ \(Fixture i o) -> do
writeFile o actual
parseString :: String -> Doc String
-parseString = Parse.toRegular . _doc . Parse.parseParas
+parseString = Parse.toRegular . _doc . Parse.parseParas Nothing
data Cmd = CmdRun | CmdAccept | CmdList
diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs
index 66bd1c97..297d30d6 100644
--- a/haddock-library/src/Documentation/Haddock/Doc.hs
+++ b/haddock-library/src/Documentation/Haddock/Doc.hs
@@ -27,16 +27,16 @@ metaDocAppend (MetaDoc { _meta = m, _doc = d })
(MetaDoc { _meta = m', _doc = d' }) =
MetaDoc { _meta = m' `metaAppend` m, _doc = d `docAppend` d' }
--- | This is not a monoidal append, it uses '<|>' for the '_version'.
+-- | This is not a monoidal append, it uses '<|>' for the '_version' and
+-- '_package'.
metaAppend :: Meta -> Meta -> Meta
-metaAppend (Meta { _version = v }) (Meta { _version = v' }) =
- Meta { _version = v <|> v' }
+metaAppend (Meta v1 p1) (Meta v2 p2) = Meta (v1 <|> v2) (p1 <|> p2)
emptyMetaDoc :: MetaDoc mod id
emptyMetaDoc = MetaDoc { _meta = emptyMeta, _doc = DocEmpty }
emptyMeta :: Meta
-emptyMeta = Meta { _version = empty }
+emptyMeta = Meta empty empty
docAppend :: DocH mod id -> DocH mod id -> DocH mod id
docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 6cbc3922..4921b3a7 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -116,10 +116,13 @@ 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
+parseParas :: Maybe Package
+ -> String -- ^ String to parse
-> MetaDoc mod Identifier
-parseParas input = case parseParasState input of
- (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state }
+parseParas pkg input = case parseParasState input of
+ (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state
+ , _package = pkg
+ }
, _doc = a
}
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 209f26e8..005ec186 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -34,7 +34,9 @@ import Data.Bitraversable
-- 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)
+data Meta = Meta { _version :: Maybe Version
+ , _package :: Maybe Package
+ } deriving (Eq, Show)
data MetaDoc mod id =
MetaDoc { _meta :: Meta
@@ -61,6 +63,7 @@ overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc
overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
type Version = [Int]
+type Package = String
data Hyperlink = Hyperlink
{ hyperlinkUrl :: String
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index c605e2c2..86ed3b35 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -24,8 +24,15 @@ instance IsString (Doc String) where
instance IsString a => IsString (Maybe a) where
fromString = Just . fromString
+emptyMeta :: Meta
+emptyMeta =
+ Meta {
+ _version = Nothing
+ , _package = Nothing
+ }
+
parseParas :: String -> MetaDoc () String
-parseParas = overDoc Parse.toRegular . Parse.parseParas
+parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing
parseString :: String -> Doc String
parseString = Parse.toRegular . Parse.parseString
@@ -375,17 +382,17 @@ spec = do
context "when parsing @since" $ do
it "adds specified version to the result" $ do
parseParas "@since 0.5.0" `shouldBe`
- MetaDoc { _meta = Meta { _version = Just [0,5,0] }
+ MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] }
, _doc = DocEmpty }
it "ignores trailing whitespace" $ do
parseParas "@since 0.5.0 \t " `shouldBe`
- MetaDoc { _meta = Meta { _version = Just [0,5,0] }
+ MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] }
, _doc = DocEmpty }
it "does not allow trailing input" $ do
parseParas "@since 0.5.0 foo" `shouldBe`
- MetaDoc { _meta = Meta { _version = Nothing }
+ MetaDoc { _meta = emptyMeta { _version = Nothing }
, _doc = DocParagraph "@since 0.5.0 foo" }
@@ -395,7 +402,7 @@ spec = do
"@since 0.5.0"
, "@since 0.6.0"
, "@since 0.7.0"
- ] `shouldBe` MetaDoc { _meta = Meta { _version = Just [0,7,0] }
+ ] `shouldBe` MetaDoc { _meta = emptyMeta { _version = Just [0,7,0] }
, _doc = DocEmpty }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 01:11:43 +0000