diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.19.0.1 +version: 2.20.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -42,9 +42,9 @@ -- this package typically supports only single major versions build-depends: base ^>= 4.11.0 , Cabal ^>= 2.2.0 - , ghc ^>= 8.4 + , ghc ^>= 8.4.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.5.0 + , haddock-library ^>= 1.6.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -166,10 +166,10 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.0.0 - , ghc ^>= 8.4 + build-depends: Cabal ^>= 2.2.0 + , ghc ^>= 8.4.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.5.0 + , haddock-library ^>= 1.6.0 , xhtml ^>= 3000.2.2 , hspec ^>= 2.4.4 , QuickCheck ^>= 2.11 diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | @@ -25,7 +25,6 @@ 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.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 @@ -- 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 @@ } -- 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 @@ 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 @@ 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 @@ ((_, 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 @@ 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 @@ -323,24 +327,34 @@ let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title pkgStr - themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty + withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do + _ <- {-# SCC ppHtmlIndex #-} + ppHtmlIndex odir title pkgStr + themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls + allVisibleIfaces pretty + return () + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - ppHtmlContents dflags' odir title pkgStr - themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty - (makeContentsQual qual) + withTiming (pure dflags') "ppHtmlContents" (const ()) $ do + _ <- {-# SCC ppHtmlContents #-} + ppHtmlContents dflags' odir title pkgStr + themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls + allVisibleIfaces True prologue pretty + sincePkg (makeContentsQual qual) + return () copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir - prologue - themes opt_mathjax sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual - pretty withQuickjump + withTiming (pure dflags') "ppHtml" (const ()) $ do + _ <- {-# SCC ppHtml #-} + ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir + prologue + themes opt_mathjax sourceUrls' opt_wiki_urls + opt_contents_url opt_index_url unicode sincePkg qual + pretty withQuickjump + return () copyHtmlBits odir libDir themes withQuickjump writeHaddockMeta odir withQuickjump @@ -348,7 +362,12 @@ -- 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." , "" @@ -356,38 +375,19 @@ ++ " using the --package-name" , " and --package-version arguments." ] - Just (PackageName pkgNameFS, pkgVer) -> - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title - | otherwise = unpackFS pkgNameFS - in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) - visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do - ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style - libDir + withTiming (pure dflags') "ppLatex" (const ()) $ do + _ <- {-# SCC ppLatex #-} + ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style + libDir + return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces - --- | 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) + withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do + _ <- {-# SCC ppHyperlinkedSource #-} + ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces + return () ------------------------------------------------------------------------------- @@ -400,7 +400,7 @@ -> [(DocPaths, FilePath)] -> m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs = do - catMaybes `liftM` mapM tryReadIface pairs + catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't tryReadIface (paths, file) = @@ -609,8 +609,13 @@ 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 diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -530,14 +530,14 @@ (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing,_) = Just i +isUndocdInstance (i,Nothing,_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX -ppDocInstance unicode (instHead, doc, _) = +ppDocInstance unicode (instHead, doc, _, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -70,6 +70,7 @@ -> 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 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 @@ 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 @@ (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 @@ -> 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 @@ 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 @@ 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 @@ -> 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 @@ 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 @@ 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 @@ 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 = "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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ = 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/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -43,17 +43,18 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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,38 +558,38 @@ 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 instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) - instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) + instDecl no (inst, mdoc, loc, mdl) = + ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc) 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) instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) - instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) + instDecl no (inst, mdoc, loc, mdl) = + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification @@ -591,13 +598,14 @@ -> Bool -- ^ Is instance orphan -> Int -- ^ Normal -> InstHead DocNameI + -> Maybe Module -> SubDecl -ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = +ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc - , [subInstDetails iid ats sigs] + , [subInstDetails iid ats sigs mname] ) where sigs = ppInstanceSigs links splice unicode qual clsiSigs @@ -605,7 +613,7 @@ TypeInst rhs -> ( subInstHead iid ptype , mdoc - , [subFamInstDetails iid prhs] + , [subFamInstDetails iid prhs mname] ) where ptype = keyword "type" <+> typ @@ -614,11 +622,12 @@ DataInst dd -> ( subInstHead iid pdata , mdoc - , [subFamInstDetails iid pdecl]) + , [subFamInstDetails iid pdecl mname]) where pdata = keyword "data" <+> typ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where + mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual @@ -711,12 +720,12 @@ [(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 @@ -736,14 +745,14 @@ | 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 @@ -755,7 +764,7 @@ ] instancesBit = ppInstances links (OriginData docname) instances - splice unicode qual + splice unicode pkg qual @@ -822,8 +831,8 @@ | 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 @@ -849,7 +858,7 @@ 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/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,10 +171,10 @@ -- 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 @@ (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

(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 @@ 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/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -47,7 +47,7 @@ import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, title, quote ) import FastString ( unpackFS ) import GHC @@ -128,38 +128,39 @@ 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 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" @@ -228,15 +229,17 @@ subInstDetails :: String -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html -- ^ Source module -> Html -subInstDetails iid ats mets = - subInstSection iid << (subAssociatedTypes ats <+> subMethods mets) +subInstDetails iid ats mets mdl = + subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance + -> Html -- ^ Source module TODO: use this -> Html -subFamInstDetails iid fi = - subInstSection iid << thediv ! [theclass "src"] << fi +subFamInstDetails iid fi mdl = + subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -60,6 +60,7 @@ import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env) import RdrName (plusGlobalRdrEnv) +import ErrUtils (withTiming) #if defined(mingw32_HOST_OS) import System.IO @@ -93,13 +94,15 @@ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap + interfaces' <- {-# SCC attachInstances #-} + withTiming getDynFlags "attachInstances" (const ()) $ do + attachInstances (exportedNames, mods) interfaces instIfaceMap out verbosity verbose "Building cross-linking environment..." -- Combine the link envs of the external packages into one let extLinks = Map.unions (map ifLinkEnv extIfaces) - homeLinks = buildHomeLinks interfaces -- Build the environment for the home - -- package + homeLinks = buildHomeLinks interfaces' -- Build the environment for the home + -- package links = homeLinks `Map.union` extLinks out verbosity verbose "Renaming interfaces..." @@ -155,7 +158,9 @@ return (reverse ifaces) where f (ifaces, ifaceMap) modSummary = do - x <- processModule verbosity modSummary flags ifaceMap instIfaceMap + x <- {-# SCC processModule #-} + withTiming getDynFlags "processModule" (const ()) $ do + processModule verbosity modSummary flags ifaceMap instIfaceMap return $ case x of Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. @@ -164,7 +169,7 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- loadModule =<< typecheckModule =<< parseModule modsum + tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum -- We need to modify the interactive context's environment so that when -- Haddock later looks for instances, it also looks in the modules it @@ -179,7 +184,9 @@ if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." - (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap + (interface, msg) <- {-# SCC createIterface #-} + withTiming getDynFlags "createInterface" (const ()) $ do + runWriterGhc $ createInterface tm flags modMap instIfaceMap liftIO $ mapM_ putStrLn msg dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -69,7 +69,7 @@ attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) + [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys @@ -91,7 +91,11 @@ let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst fam_instances = maybeToList mb_instances >>= snd - fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) + fam_insts = [ ( synifyFamInst i opaque + , doc + , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) + , nameModule_maybe n + ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap @@ -99,14 +103,18 @@ , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) + cls_insts = [ ( synifyInstHead i + , instLookup instDocMap n iface ifaceMap instIfaceMap + , spanName n (synifyInstHead i) (L eSpan (tcdName d)) + , nameModule_maybe n + ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -46,7 +46,6 @@ import Avail hiding (avail) import qualified Avail -import qualified Packages import qualified Module import qualified SrcLoc import ConLike (ConLike(..)) @@ -55,13 +54,14 @@ 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 @@ !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 @@ 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 @@ 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 @@ , 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 _ (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 @@ -- 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 @@ 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 @@ 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 @@ -> 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 @@ 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 @@ fullModuleContents :: Bool -- is it a signature -> IfaceMap + -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap @@ -975,7 +989,7 @@ -> 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 @@ 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 @@ -1054,19 +1068,32 @@ FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) -> - SigD <$> extractRecSel name n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) - <- insts - -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name - ] - in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) - _ -> error "internal: extractDecl (ClsInstD)" + if isDataConName name + then SigD <$> extractPatternSyn name n tys (dd_cons defn) + else SigD <$> extractRecSel name n tys (dd_cons defn) + InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) + | isDataConName name -> + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = + FamEqn { feqn_rhs = dd + } + })) <- insts + , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) + ] + in case matches of + [d0] -> extractDecl declMap name (noLoc (InstD (DataFamInstD d0))) + _ -> error "internal: extractDecl (ClsInstD)" + | otherwise -> + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , selectorFieldOcc n == name + ] + in case matches of + [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) + _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -33,34 +33,35 @@ 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/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -24,8 +24,8 @@ -- 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 @@ 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/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -627,11 +627,11 @@ , hswc_wcs = PlaceHolder }) } renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) -renameDocInstance (inst, idoc, L l n) = do +renameDocInstance (inst, idoc, L l n, m) = do inst' <- renameInstHead inst n' <- rename n idoc' <- mapM renameDoc idoc - return (inst', idoc',L l n') + return (inst', idoc', L l n', m) renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) -binaryInterfaceVersion = 32 +binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -486,8 +486,13 @@ 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/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -29,19 +29,23 @@ 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 @@ | Flag_PackageName String | Flag_PackageVersion String | Flag_Reexport String + | Flag_SinceQualification String deriving (Eq, Show) @@ -210,7 +215,9 @@ 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 @@ [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 @@ 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/src/Haddock/Parser.hs b/src/Haddock/Parser.hs --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -28,8 +28,8 @@ 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/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -388,7 +388,7 @@ -- | An instance head that may have documentation and a source location. -type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name)) +type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module) -- | The head of an instance. Consists of a class name, a list of type -- parameters (which may be annotated with kinds), and an instance type @@ -577,6 +577,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