From 37bc451213dd08871d87182bb158c9594a0732c0 Mon Sep 17 00:00:00 2001
From: Finley McIlwaine <finleymcilwaine@gmail.com>
Date: Mon, 8 May 2023 16:07:33 -0600
Subject: [PATCH] Memory usage fixes
- Refactor `ifaceDeclMap` to drastically reduce memory footprint. We
no longer store all declarations associated with a given name, since
we only cared to determine if the only declaration associated with a
name was a value declaration. Change the `DeclMap` type to better
reflect this.
- Drop pre-renaming export items after the renaming step. Since the
Hoogle backend used the pre-renamed export items, this isn't trivial.
We now generate Hoogle output for exported declarations during the
renaming step (if Hoogle output /should/ be generated), and store that
with the renamed export item.
- Slightly refactor Hoogle backend to handle the above change and allow
for early generation of Hoogle output.
- Remove the `ifaceRnDocMap` and `ifaceRnArgMap` fields of the
`Interface` type, as they were never used.
- Remove some unnecessary strictness
- Remove a lot of dead code from `Syb` module
---
haddock-api/src/Haddock.hs | 16 ++-
haddock-api/src/Haddock/Backends/Hoogle.hs | 67 +++++----
haddock-api/src/Haddock/Backends/LaTeX.hs | 43 ++++--
haddock-api/src/Haddock/Backends/Xhtml.hs | 51 +++++--
haddock-api/src/Haddock/Convert.hs | 8 +-
haddock-api/src/Haddock/Interface.hs | 70 +++++-----
.../src/Haddock/Interface/AttachInstances.hs | 31 ++--
haddock-api/src/Haddock/Interface/Create.hs | 132 +++++++++---------
.../src/Haddock/Interface/LexParseRn.hs | 24 ++--
haddock-api/src/Haddock/Interface/Rename.hs | 64 +++++++--
haddock-api/src/Haddock/Syb.hs | 50 +------
haddock-api/src/Haddock/Types.hs | 128 ++++++++++++-----
12 files changed, 406 insertions(+), 278 deletions(-)
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 29f151b14f..2f6a9cc356 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -46,6 +47,7 @@ import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
+import Control.DeepSeq (force)
import Control.Monad hiding (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
@@ -55,9 +57,9 @@ import Data.List (find, isPrefixOf, nub)
import Control.Exception
import Data.Maybe
import Data.IORef
-import Data.Map (Map)
+import Data.Map.Strict (Map)
import Data.Version (makeVersion)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
import System.IO
import System.Exit
import System.FilePath
@@ -73,9 +75,9 @@ import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import GHC.Settings.Config
-import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Env
+import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Types.Name.Cache
@@ -197,7 +199,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
ghc flags' $ withDir $ do
dflags <- getDynFlags
logger <- getLogger
- unit_state <- hsc_units <$> getSession
+ !unit_state <- hsc_units <$> getSession
-- If any --show-interface was used, show the given interfaces
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
@@ -771,8 +773,10 @@ hypSrcWarnings flags = do
updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()
updateHTMLXRefs packages = do
- writeIORef html_xrefs_ref (Map.fromList mapping)
- writeIORef html_xrefs_ref' (Map.fromList mapping')
+ let !modMap = force $ Map.fromList mapping
+ !modNameMap = force $ Map.fromList mapping'
+ writeIORef html_xrefs_ref modMap
+ writeIORef html_xrefs_ref' modNameMap
where
mapping = [ (instMod iface, html) | (html, ifaces) <- packages
, iface <- ifInstalledIfaces ifaces ]
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 211dd70aa2..15d6e4e202 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -15,7 +15,11 @@
-- http://www.haskell.org/hoogle/
-----------------------------------------------------------------------------
module Haddock.Backends.Hoogle (
+ -- * Main entry point to Hoogle output generation
ppHoogle
+
+ -- * Utilities for generating Hoogle output during interface creation
+ , ppExportD
, outWith
) where
@@ -55,7 +59,8 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
["@package " ++ package] ++
["@version " ++ showVersion version
- | not (null (versionBranch version)) ] ++
+ | not (null (versionBranch version))
+ ] ++
concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
@@ -64,9 +69,14 @@ ppModule :: DynFlags -> Interface -> [String]
ppModule dflags iface =
"" : ppDocumentation dflags (ifaceDoc iface) ++
["module " ++ moduleString (ifaceMod iface)] ++
- concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap ppExportItem (ifaceRnExportItems $ iface) ++
map (fromMaybe "" . haddockClsInstPprHoogle) (ifaceInstances iface)
+-- | If the export item is an 'ExportDecl', get the attached Hoogle textual
+-- database entries for that export declaration.
+ppExportItem :: ExportItem DocNameI -> [String]
+ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o
+ppExportItem _ = []
---------------------------------------------------------------------
-- Utility functions
@@ -116,28 +126,37 @@ commaSeparate dflags = showSDoc dflags . interpp'SP
---------------------------------------------------------------------
-- How to print each export
-ppExport :: DynFlags -> ExportItem GhcRn -> [String]
-ppExport dflags ExportDecl { expItemDecl = L _ decl
- , expItemPats = bundledPats
- , expItemMbDoc = mbDoc
- , expItemSubDocs = subdocs
- , expItemFixities = fixities
- } = concat [ ppDocumentation dflags dc ++ f d
- | (d, (dc, _)) <- (decl, mbDoc) : bundledPats
- ] ++
- ppFixities
- where
- f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
- f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
- f (TyClD _ (FamDecl _ d)) = ppFam dflags d
- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
- f (SigD _ sig) = ppSig dflags sig
- f _ = []
-
- ppFixities = concatMap (ppFixity dflags) fixities
-ppExport _ _ = []
+ppExportD :: DynFlags -> ExportD GhcRn -> [String]
+ppExportD dflags
+ ExportD
+ { expDDecl = L _ decl
+ , expDPats = bundledPats
+ , expDMbDoc = mbDoc
+ , expDSubDocs = subdocs
+ , expDFixities = fixities
+ }
+ = let
+ -- Since Hoogle is line based, we want to avoid breaking long lines.
+ dflags' = dflags{ pprCols = maxBound }
+ in
+ concat
+ [ ppDocumentation dflags' dc ++ f d
+ | (d, (dc, _)) <- (decl, mbDoc) : bundledPats
+ ] ++ ppFixities
+ where
+ f :: HsDecl GhcRn -> [String]
+ f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
+ f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
+ f (TyClD _ (FamDecl _ d)) = ppFam dflags d
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
+ f (SigD _ sig) = ppSig dflags sig
+ f _ = []
+
+ ppFixities :: [String]
+ ppFixities = concatMap (ppFixity dflags) fixities
+
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags sig subdocs = case sig of
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d335e8fa17..f07534920a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.LaTeX (
) where
import Documentation.Haddock.Markup
+import Haddock.Doc (combineDocumentation)
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
@@ -42,8 +43,6 @@ import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Foldable ( toList )
import Prelude hiding ((<>))
-import Haddock.Doc (combineDocumentation)
-
{- SAMPLE OUTPUT
\haddockmoduleheading{\texttt{Data.List}}
@@ -178,7 +177,18 @@ ppLaTeXModule _title odir iface = do
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
-exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
+exportListItem
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ( ExportD
+ { expDDecl = decl
+ , expDSubDocs = subdocs
+ }
+ )
+ }
+ )
+ )
= let (leader, names) = declNames decl
in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>
case subdocs of
@@ -213,9 +223,18 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
- , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
+isSimpleSig
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDDecl = L _ (SigD _ (TypeSig _ lnames t))
+ , expDMbDoc = (Documentation Nothing Nothing, argDocs)
+ }
+ }
+ )
+ )
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
isSimpleSig _ = Nothing
@@ -227,7 +246,7 @@ isExportModule _ = Nothing
processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _))
= ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
@@ -290,13 +309,9 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode
- TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
- TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
--- Family instances happen via FamInst now
--- TyClD _ d@TySynonym{}
--- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
--- Family instances happen via FamInst now
+ TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode
+ TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
+ TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4cc6aa7709..da4d1ed01e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -11,7 +11,11 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
-{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
module Haddock.Backends.Xhtml (
ppHtml, copyHtmlBits,
ppHtmlIndex, ppHtmlContents,
@@ -356,7 +360,7 @@ ppPrologue pkg qual title (Just doc) =
ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
-ppSignatureTrees pkg qual [(info, ts)] =
+ppSignatureTrees pkg qual [(info, ts)] =
divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
ppSignatureTrees pkg qual tss =
divModuleList <<
@@ -427,8 +431,6 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
mkNodeList pkg qual (s:ss) p ts
)
-
-
--------------------------------------------------------------------------------
-- * Generate the index
--------------------------------------------------------------------------------
@@ -522,11 +524,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
names = exportName item ++ exportSubs item
exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
- exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
+ exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs
exportSubs _ = []
exportName :: ExportItem DocNameI -> [IdP DocNameI]
- exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl)
+ exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl)
exportName ExportNoDecl { expItemName } = [expItemName]
exportName _ = []
@@ -538,7 +540,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
-- update link using relative path to output directory
fixLink :: FilePath
-> JsonIndexEntry -> JsonIndexEntry
- fixLink ifaceFile jie =
+ fixLink ifaceFile jie =
jie { jieLink = makeRelative odir (takeDirectory ifaceFile)
FilePath.</> jieLink jie }
@@ -722,7 +724,17 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
+ has_doc
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDMbDoc =
+ ( Documentation mDoc mWarn, _ )
+ }
+ }
+ )
+ ) = isJust mDoc || isJust mWarn
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -816,11 +828,28 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
+processExport _ _ _ _ _
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDDecl = L _ (InstD {})
+ }
+ }
+ )
+ )
+ = Nothing -- Hide empty instances
+processExport summary links unicode pkg qual
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD decl pats doc subdocs insts fixities splice
+ }
+ )
+ )
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (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)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 496b357490..25d5a0648e 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Convert
@@ -639,7 +643,7 @@ synifyType _ vs (TyConApp tc tys)
= mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc))
vis_tys
where
- prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
+ !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
mk_app_tys ty_app ty_args =
foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
(noLocA ty_app)
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 215458bab8..0eba8b1fb9 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -40,14 +40,11 @@ import Haddock.Interface.Create (createInterface1, runIfM)
import Haddock.Interface.Rename (renameInterface)
import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv)
import Haddock.Options hiding (verbosity)
-import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv,
- expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage,
- ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, throwE, haddockClsInstName)
+import Haddock.Types
import Haddock.Utils (Verbosity (..), normal, out, verbose)
import Control.Monad (unless, when)
-import Control.Monad.IO.Class (MonadIO)
-import Data.IORef (atomicModifyIORef', newIORef, readIORef)
+import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)
import Data.List (foldl', isPrefixOf, nub)
import Data.Maybe (mapMaybe)
import Data.Traversable (for)
@@ -64,7 +61,7 @@ import GHC.HsToCore.Docs (getMainDeclBinder)
import GHC.Plugins
import GHC.Tc.Types (TcGblEnv (..), TcM)
import GHC.Tc.Utils.Env (tcLookupGlobal)
-import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
+import GHC.Tc.Utils.Monad (getTopEnv)
import GHC.Unit.Module.Graph
import GHC.Utils.Error (withTiming)
@@ -91,8 +88,11 @@ processModules verbosity modules flags extIfaces = do
liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif
+ dflags <- getDynFlags
+
out verbosity verbose "Creating interfaces..."
+
-- Map from a module to a corresponding installed interface
let instIfaceMap :: InstIfaceMap
instIfaceMap = Map.fromList
@@ -129,7 +129,7 @@ processModules verbosity modules flags extIfaces = do
withTimingM "renameAllInterfaces" (const ()) $
for interfaces' $ \i -> do
withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $
- renameInterface ignoredSymbolSet links warnings i
+ renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i
return (interfaces'', homeLinks)
@@ -150,10 +150,15 @@ createIfaces
-> Ghc ([Interface], ModuleSet)
-- ^ Resulting interfaces
createIfaces verbosity modules flags instIfaceMap = do
- (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
- verbosity flags instIfaceMap
+ -- Initialize the IORefs for the interface map and the module set
+ (ifaceMapRef, moduleSetRef) <- liftIO $ do
+ m <- newIORef Map.empty
+ s <- newIORef emptyModuleSet
+ return (m, s)
let
+ haddockPlugin = plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef
+
installHaddockPlugin :: HscEnv -> HscEnv
installHaddockPlugin hsc_env =
let
@@ -178,8 +183,11 @@ createIfaces verbosity modules flags instIfaceMap = do
throwE "Cannot typecheck modules"
Succeeded -> do
modGraph <- GHC.getModuleGraph
- ifaceMap <- liftIO getIfaces
- moduleSet <- liftIO getModules
+
+ (ifaceMap, moduleSet) <- liftIO $ do
+ m <- readIORef ifaceMapRef
+ s <- readIORef moduleSetRef
+ return (m, s)
let
-- We topologically sort the module graph including boot files,
@@ -245,23 +253,18 @@ createIfaces verbosity modules flags instIfaceMap = do
-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
-- parallelize the compilation process.
plugin
- :: MonadIO m
- => Verbosity
+ :: Verbosity
-- ^ Verbosity requested by the Haddock caller
-> [Flag]
-- ^ Command line flags which Hadddock was invoked with
-> InstIfaceMap
-- ^ Map from module to corresponding installed interface file
- -> m
- (
- StaticPlugin -- the plugin to install with GHC
- , m IfaceMap -- get the processed interfaces
- , m ModuleSet -- get the loaded modules
- )
-plugin verbosity flags instIfaceMap = liftIO $ do
- ifaceMapRef <- newIORef Map.empty
- moduleSetRef <- newIORef emptyModuleSet
-
+ -> IORef IfaceMap
+ -- ^ The 'IORef' to write the interface map to
+ -> IORef ModuleSet
+ -- ^ The 'IORef' to write the module set to
+ -> StaticPlugin -- the plugin to install with GHC
+plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef =
let
processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
processTypeCheckedResult mod_summary tc_gbl_env
@@ -282,16 +285,15 @@ plugin verbosity flags instIfaceMap = liftIO $ do
atomicModifyIORef' moduleSetRef $ \xs ->
(modules `unionModuleSet` xs, ())
-
- staticPlugin :: StaticPlugin
- staticPlugin = StaticPlugin
+ in
+ StaticPlugin
{
spPlugin = PluginWithArgs
{
paPlugin = defaultPlugin
{
renamedResultAction = keepRenamedSource
- , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+ , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do
processTypeCheckedResult mod_summary tc_gbl_env
pure tc_gbl_env
}
@@ -299,13 +301,6 @@ plugin verbosity flags instIfaceMap = liftIO $ do
}
}
- pure
- ( staticPlugin
- , liftIO (readIORef ifaceMapRef)
- , liftIO (readIORef moduleSetRef)
- )
-
-
processModule1
:: Verbosity
-- ^ Verbosity requested by the Haddock caller
@@ -375,9 +370,10 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
undocumentedExports :: [String]
undocumentedExports =
[ formatName (locA s) n
- | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface
+ | ExportDecl ExportD
+ { expDDecl = L s n
+ , expDMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface
]
where
formatName :: SrcSpan -> HsDecl GhcRn -> String
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 71cc25c7f0..6b85424788 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -102,7 +102,7 @@ attachToExportItem
-> Ghc (ExportItem GhcRn)
attachToExportItem index expInfo getInstDoc getFixity export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
+ ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
@@ -139,18 +139,27 @@ attachToExportItem index expInfo getInstDoc getFixity export =
let mkBug = (text "haddock-bug:" <+>) . text
putMsgM (sep $ map mkBug famInstErrs)
return $ cls_insts ++ cleanFamInsts
- return $ e { expItemInstances = insts }
+ return $ ExportDecl e { expDInstances = insts }
e -> return e
where
- attachFixities e@ExportDecl{ expItemDecl = L _ d
- , expItemPats = patsyns
- , expItemSubDocs = subDocs
- } = e { expItemFixities =
- nubByName fst $ expItemFixities e ++
- [ (n',f) | n <- getMainDeclBinder emptyOccEnv d
- , n' <- n : (map fst subDocs ++ patsyn_names)
- , f <- maybeToList (getFixity n')
- ] }
+ attachFixities
+ ( ExportDecl
+ ( e@ExportD
+ { expDDecl = L _ d
+ , expDPats = patsyns
+ , expDSubDocs = subDocs
+ }
+ )
+ )
+ = ExportDecl e
+ { expDFixities =
+ nubByName fst $ expDFixities e ++
+ [ (n',f)
+ | n <- getMainDeclBinder emptyOccEnv d
+ , n' <- n : (map fst subDocs ++ patsyn_names)
+ , f <- maybeToList (getFixity n')
+ ]
+ }
where
patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 06b494c158..2a3450d506 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -50,8 +50,8 @@ import Data.Foldable (toList)
import Data.List (find, foldl')
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList)
import Data.Traversable (for)
@@ -312,8 +312,6 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
, ifaceOptions = doc_opts
, ifaceDocMap = docs
, ifaceArgMap = arg_docs
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
, ifaceExportItems = if OptPrune `elem` doc_opts then
pruned_export_items else export_items
, ifaceRnExportItems = [] -- Filled in renameInterfaceRn
@@ -544,11 +542,11 @@ mkMaps dflags pkgName gre instances decls thDocs = do
, force $
fmap intmap2mapint $
th_b `unionArgMaps` (f (filterMapping (not . IM.null) b))
- , f (filterMapping (not . null) c)
+ , f c
, instanceMap
)
where
- f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
@@ -585,7 +583,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
-> ErrMsgM ( [(Name, MDoc Name)]
, [(Name, IntMap (MDoc Name))]
- , [(Name, [LHsDecl GhcRn])]
+ , [(Name, DeclMapEntry)]
)
mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do
let docStrs = map hsDocString hs_docStrs
@@ -610,7 +608,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
subNs = [ n | (n, _, _) <- subs ]
dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
- cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+ cm = [ (n, toDeclMapEntry ldecl) | n <- ns ++ subNs ]
seqList ns `seq`
seqList subNs `seq`
@@ -773,19 +771,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l' (ValD _ _)], (doc, _)) -> do
- let l = locA l'
- -- Top-level binding without type signature
- export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
+ (Just (EValD srcSpan), (doc, _)) -> do
+ -- Since the DeclMapEntry is an 'EValD', we know the declaration is a
+ -- top-level binding without a type signature. We get type information
+ -- for the binding from the GHC interface file using the
+ -- 'hiValExportItem' function
+ export <- hiValExportItem dflags t srcSpan doc (srcSpan `elem` splices) $ M.lookup t fixMap
return [export]
- (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder emptyOccEnv (unL decl)
+
+ (Just (EOther d), docs_) ->
+ let declNames = getMainDeclBinder emptyOccEnv (unL d)
in case () of
_
- -- We should not show a subordinate by itself if any of its
- -- parents is also exported. See note [1].
+ -- If 't' is not the main declaration binder, then it is a
+ -- subordinate name in the declaration. If any of its parents are
+ -- also exported, we do not want to show its documentation by
+ -- itself. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
+ Just p <- find isExported (parents t $ unL d) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
@@ -795,7 +798,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
return []
-- normal case
- | otherwise -> case decl of
+ | otherwise -> case d of
-- A single signature might refer to many names, but we
-- create an export item for a single name only. So we
-- modify the signature to contain only that single name.
@@ -811,10 +814,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
availExportDecl avail
(L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
- _ -> availExportDecl avail decl docs_
+ _ -> availExportDecl avail d docs_
-- Declaration from another package
- ([], _) -> do
+ (Nothing, _) -> do
mayDecl <- hiDecl dflags t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
@@ -832,8 +835,6 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Just iface ->
availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface))
- _ -> return []
-
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl declName parentDecl =
@@ -866,38 +867,40 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
, Just f <- [M.lookup n fixMap]
]
- return [ ExportDecl {
- expItemDecl = restrictTo (fmap fst subs) extractedDecl
- , expItemPats = bundledPatSyns
- , expItemMbDoc = doc
- , expItemSubDocs = subs
- , expItemInstances = []
- , expItemFixities = fixities
- , expItemSpliced = False
- }
- ]
+ return
+ [ ExportDecl ExportD
+ { expDDecl = restrictTo (fmap fst subs) extractedDecl
+ , expDPats = bundledPatSyns
+ , expDMbDoc = doc
+ , expDSubDocs = subs
+ , expDInstances = []
+ , expDFixities = fixities
+ , expDSpliced = False
+ }
+ ]
| otherwise = for subs $ \(sub, sub_doc) -> do
extractedDecl <- availDecl sub decl
- return ( ExportDecl {
- expItemDecl = extractedDecl
- , expItemPats = []
- , expItemMbDoc = sub_doc
- , expItemSubDocs = []
- , expItemInstances = []
- , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
- , expItemSpliced = False
- } )
+ return $
+ ExportDecl ExportD
+ { expDDecl = extractedDecl
+ , expDPats = []
+ , expDMbDoc = sub_doc
+ , expDSubDocs = []
+ , expDInstances = []
+ , expDFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
+ , expDSpliced = False
+ }
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
- findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: AvailInfo -> IfM m (Maybe DeclMapEntry, (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl avail
| m == semMod =
case M.lookup n declMap of
- Just ds -> return (ds, lookupDocs avail warnings docMap argMap)
+ Just d -> return (Just d, lookupDocs avail warnings docMap argMap)
Nothing
| is_sig -> do
-- OK, so it wasn't in the local declaration map. It could
@@ -905,19 +908,19 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- from the type.
mb_r <- hiDecl dflags n
case mb_r of
- Nothing -> return ([], (noDocForDecl, availNoDocs avail))
+ Nothing -> return (Nothing, (noDocForDecl, availNoDocs avail))
-- TODO: If we try harder, we might be able to find
-- a Haddock! Look in the Haddocks for each thing in
-- requirementContext (unitState)
- Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))
+ Just decl -> return (Just $ toDeclMapEntry decl, (noDocForDecl, availNoDocs avail))
| otherwise ->
- return ([], (noDocForDecl, availNoDocs avail))
+ return (Nothing, (noDocForDecl, availNoDocs avail))
| Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap
- , Just ds <- M.lookup n (ifaceDeclMap iface) =
- return (ds, lookupDocs avail warnings
+ , Just d <- M.lookup n (ifaceDeclMap iface) =
+ return (Just d, lookupDocs avail warnings
(ifaceDocMap iface)
(ifaceArgMap iface))
- | otherwise = return ([], (noDocForDecl, availNoDocs avail))
+ | otherwise = return (Nothing, (noDocForDecl, availNoDocs avail))
where
n = availName avail
m = nameModule n
@@ -930,9 +933,9 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Just (AConLike PatSynCon{}) -> do
export_items <- declWith (Avail.avail name)
pure [ (unLoc patsyn_decl, patsyn_doc)
- | ExportDecl {
- expItemDecl = patsyn_decl
- , expItemMbDoc = patsyn_doc
+ | ExportDecl ExportD
+ { expDDecl = patsyn_decl
+ , expDMbDoc = patsyn_doc
} <- export_items
]
_ -> pure []
@@ -983,7 +986,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
+ Just decl -> return (ExportDecl $ ExportD (fixSpan decl) [] doc [] [] fixities splice)
where
fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t
fixities = case fixity of
@@ -994,7 +997,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
-- | Lookup docs for a declaration from maps.
lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs avail warnings docMap argMap =
+lookupDocs avail warningMap docMap argMap =
let n = availName avail in
let lookupArgDoc x = M.findWithDefault M.empty x argMap in
let doc = (lookupDoc n, lookupArgDoc n) in
@@ -1003,7 +1006,7 @@ lookupDocs avail warnings docMap argMap =
] in
(doc, subDocs)
where
- lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warningMap)
-- | Export the given module as `ExportModule`. We are not concerned with the
@@ -1087,7 +1090,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
return [[ExportDoc doc]]
(L _ (ValD _ valDecl))
| name:_ <- collectHsBindBinders CollNoDictBinders valDecl
- , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
+ , Just (EOther (L _ SigD{})) <- M.lookup name declMap
-> return []
_ ->
for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do
@@ -1097,9 +1100,6 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
semMod warnings exportedNames maps fixMap
splices instIfaceMap dflags avail
Nothing -> pure [])
- where
- isSigD (L _ SigD{}) = True
- isSigD _ = False
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
@@ -1144,7 +1144,7 @@ extractDecl declMap name decl
(_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
([], [])
- | Just (famInstDecl:_) <- M.lookup name declMap
+ | Just (EOther famInstDecl) <- M.lookup name declMap
-> extractDecl declMap name famInstDecl
_ -> Left (concat [ "Ambiguous decl for ", getOccString name
, " in class ", getOccString clsNm ])
@@ -1159,7 +1159,7 @@ extractDecl declMap name decl
TyClD _ FamDecl {}
| isValName name
- , Just (famInst:_) <- M.lookup name declMap
+ , Just (EOther famInst) <- M.lookup name declMap
-> extractDecl declMap name famInst
InstD _ (DataFamInstD _ (DataFamInstDecl
(FamEqn { feqn_tycon = L _ n
@@ -1257,7 +1257,7 @@ extractRecSel nm t tvs (L _ con : rest) =
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems = filter hasDoc
where
- hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
+ hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
@@ -1267,10 +1267,10 @@ mkVisibleNames (_, _, _, instMap) exports opts
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
where
- exportName e@ExportDecl {} = name ++ subs ++ patsyns
- where subs = map fst (expItemSubDocs e)
- patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e)
- name = case unLoc $ expItemDecl e of
+ exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns
+ where subs = map fst (expDSubDocs e)
+ patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e)
+ name = case unLoc $ expDDecl e of
InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
decl -> getMainDeclBinder emptyOccEnv decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index d731d61204..f142f0651a 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -22,7 +22,6 @@ module Haddock.Interface.LexParseRn
) where
import Control.Arrow
-import Control.DeepSeq
import Control.Monad
import Data.Functor
import Data.List ((\\), maximumBy)
@@ -45,25 +44,24 @@ processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
processDocStrings dflags pkg gre strs = do
mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs
- force <$>
- 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 Nothing Nothing, _doc = DocEmpty } -> pure Nothing
- x -> pure (Just x)
+ 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 Nothing Nothing, _doc = DocEmpty } -> pure Nothing
+ x -> pure (Just x)
processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
-processDocStringParas dflags pkg gre hds = force <$>
- overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds))
+processDocStringParas dflags pkg gre hds =
+ overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds))
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre hds =
- force <$> processDocStringFromString dflags gre (renderHsDocString hds)
+ processDocStringFromString dflags gre (renderHsDocString hds)
processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)
processDocStringFromString dflags gre hds =
- force <$> rename dflags gre (parseString dflags hds)
+ rename dflags gre (parseString dflags hds)
processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
@@ -84,7 +82,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
- return $ force
+ return
(hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2e25ded990..49ff2dace2 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -20,6 +20,7 @@ module Haddock.Interface.Rename (renameInterface) where
import Data.Traversable (mapM)
+import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
import Haddock.Types hiding (runWriter)
@@ -48,7 +49,9 @@ import GHC.Types.Basic ( TopLevelFlag(..) )
-- The renamed output gets written into fields in the Haddock interface record
-- that were previously left empty.
renameInterface
- :: Map.Map (Maybe String) (Set.Set String)
+ :: DynFlags
+ -- ^ GHC session dyn flags
+ -> Map.Map (Maybe String) (Set.Set String)
-- ^ Ignored symbols. A map from module names to unqualified names. Module
-- 'Just M' mapping to name 'f' means that link warnings should not be
-- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to
@@ -58,15 +61,23 @@ renameInterface
-- module 'M' if 'M' is the preferred link destination for name 'n'.
-> Bool
-- ^ Are warnings enabled?
+ -> Bool
+ -- ^ Is Hoogle output enabled?
-> Interface
-- ^ The interface we are renaming.
-> Ghc Interface
-- ^ The renamed interface. Note that there is nothing really special about
-- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or
-- even pure, depending on the link warnings are reported.
-renameInterface ignoreSet renamingEnv warnings iface = do
+renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do
let (iface', warnedNames) =
- runRnM mdl localLinkEnv warnName $ renameInterfaceRn iface
+ runRnM
+ dflags
+ mdl
+ localLinkEnv
+ warnName
+ (hoogle && not (OptHide `elem` ifaceOptions iface))
+ (renameInterfaceRn iface)
reportMissingLinks mdl warnedNames
return iface'
where
@@ -139,17 +150,29 @@ newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a }
-- | The renaming monad environment. Stores the linking environment (mapping
-- names to modules), the link warning predicate, and the current module.
data RnMEnv = RnMEnv
- { rnLinkEnv :: LinkEnv
+ { -- | The linking environment (map from names to modules)
+ rnLinkEnv :: LinkEnv
+
+ -- | Link warning predicate (whether failing to find a link destination
+ -- for a given name should result in a warning)
, rnWarnName :: (Name -> Bool)
+
+ -- | The current module
, rnModuleString :: String
+
+ -- | Should Hoogle output be generated for this module?
+ , rnHoogleOutput :: Bool
+
+ -- | GHC Session DynFlags, necessary for Hoogle output generation
+ , rnDynFlags :: DynFlags
}
-- | Run the renamer action in a renaming environment built using the given
-- module, link env, and link warning predicate. Returns the renamed value along
-- with a set of 'Name's that were not renamed and should be warned for (i.e.
-- they satisfied the link warning predicate).
-runRnM :: Module -> LinkEnv -> (Name -> Bool) -> RnM a -> (a, Set.Set Name)
-runRnM mdl linkEnv warnName rn =
+runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name)
+runRnM dflags mdl linkEnv warnName hoogleOutput rn =
runWriter $ runReaderT (unRnM rn) rnEnv
where
rnEnv :: RnMEnv
@@ -157,6 +180,8 @@ runRnM mdl linkEnv warnName rn =
{ rnLinkEnv = linkEnv
, rnWarnName = warnName
, rnModuleString = moduleString mdl
+ , rnHoogleOutput = hoogleOutput
+ , rnDynFlags = dflags
}
--------------------------------------------------------------------------------
@@ -167,16 +192,18 @@ runRnM mdl linkEnv warnName rn =
renameInterfaceRn :: Interface -> RnM Interface
renameInterfaceRn iface = do
exportItems <- renameExportItems (ifaceExportItems iface)
- docMap <- mapM renameDoc (ifaceDocMap iface)
- argMap <- mapM (mapM renameDoc) (ifaceArgMap iface)
orphans <- mapM renameDocInstance (ifaceOrphanInstances iface)
finalModDoc <- renameDocumentation (ifaceDoc iface)
pure $! iface
{ ifaceRnDoc = finalModDoc
- , ifaceRnDocMap = docMap
- , ifaceRnArgMap = argMap
+
+ -- The un-renamed export items are not used after renaming
, ifaceRnExportItems = exportItems
+ , ifaceExportItems = []
+
+ -- The un-renamed orphan instances are not used after renaming
, ifaceRnOrphanInstances = orphans
+ , ifaceOrphanInstances = []
}
-- | Lookup a 'Name' in the renaming environment.
@@ -216,7 +243,15 @@ renameExportItem item = case item of
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
- ExportDecl decl pats doc subs instances fixities splice -> do
+ ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do
+ -- If Hoogle output should be generated, generate it
+ RnMEnv{..} <- ask
+ let hoogleOut =
+ if rnHoogleOutput then
+ ppExportD rnDynFlags ed
+ else
+ []
+
decl' <- renameLDecl decl
pats' <- renamePats pats
doc' <- renameDocForDecl doc
@@ -225,7 +260,12 @@ renameExportItem item = case item of
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
- return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
+
+ return $
+ ExportDecl RnExportD
+ { rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice
+ , rnExpDHoogle = hoogleOut
+ }
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index fc946c8e5f..e2dc77fb0b 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -4,15 +4,15 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Haddock.Syb
- ( everything, everythingButType, everythingWithState
- , everywhere, everywhereButType
- , mkT, mkQ, extQ
- , combine
+ ( everythingWithState
+ , everywhereButType
+ , mkT
+ , mkQ
+ , extQ
) where
import Data.Data
-import Control.Applicative
import Data.Maybe
import Data.Foldable
@@ -21,34 +21,6 @@ import Data.Foldable
isType :: forall a b. (Typeable a, Typeable b) => b -> Bool
isType _ = isJust $ eqT @a @b
--- | Perform a query on each level of a tree.
---
--- This is stolen directly from SYB package and copied here to not introduce
--- additional dependencies.
-everything :: (r -> r -> r)
- -> (forall a. Data a => a -> r)
- -> (forall a. Data a => a -> r)
-everything k f x = foldl' k (f x) (gmapQ (everything k f) x)
-
--- | Variation of "everything" with an added stop condition
--- Just like 'everything', this is stolen from SYB package.
-everythingBut :: (r -> r -> r)
- -> (forall a. Data a => a -> (r, Bool))
- -> (forall a. Data a => a -> r)
-everythingBut k f x = let (v, stop) = f x
- in if stop
- then v
- else foldl' k v (gmapQ (everythingBut k f) x)
-
--- | Variation of "everything" that does not recurse into children of type t
--- requires AllowAmbiguousTypes
-everythingButType ::
- forall t r. (Typeable t)
- => (r -> r -> r)
- -> (forall a. Data a => a -> r)
- -> (forall a. Data a => a -> r)
-everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t
-
-- | Perform a query with state on each level of a tree.
--
-- This is the same as 'everything' but allows for stateful computations. In
@@ -61,12 +33,6 @@ everythingWithState s k f x =
let (r, s') = f x s
in foldl' k r (gmapQ (everythingWithState s' k f) x)
--- | Apply transformation on each level of a tree.
---
--- Just like 'everything', this is stolen from SYB package.
-everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
-everywhere f = f . gmapT (everywhere f)
-
-- | Variation on everywhere with an extra stop condition
-- Just like 'everything', this is stolen from SYB package.
everywhereBut :: (forall a. Data a => a -> Bool)
@@ -105,9 +71,3 @@ mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
-- Another function stolen from SYB package.
extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
extQ f g a = maybe (f a) g (cast a)
-
--- | Combine two queries into one using alternative combinator.
-combine :: Alternative f => (forall a. Data a => a -> f r)
- -> (forall a. Data a => a -> f r)
- -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 2d19003e8a..9601f0f5c9 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -66,7 +66,7 @@ type InstIfaceMap = Map Module InstalledInterface -- TODO: rename
type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
-type DeclMap = Map Name [LHsDecl GhcRn]
+type DeclMap = Map Name DeclMapEntry
type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -109,18 +109,13 @@ data Interface = Interface
-- | Declarations originating from the module. Excludes declarations without
-- names (instances and stand-alone documentation comments). Includes
-- names of subordinate declarations mapped to their parent declarations.
- , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn])
+ , ifaceDeclMap :: !DeclMap
-- | Documentation of declarations originating from the module (including
-- subordinates).
, ifaceDocMap :: !(DocMap Name)
, ifaceArgMap :: !(ArgMap Name)
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- , ifaceRnDocMap :: !(DocMap DocName)
- , ifaceRnArgMap :: !(ArgMap DocName)
-
, ifaceFixMap :: !(Map Name Fixity)
, ifaceExportItems :: [ExportItem GhcRn]
@@ -141,7 +136,7 @@ data Interface = Interface
, ifaceInstances :: [HaddockClsInst]
-- | Orphan instances
- , ifaceOrphanInstances :: [DocInstance GhcRn]
+ , ifaceOrphanInstances :: [DocInstance GhcRn]
, ifaceRnOrphanInstances :: [DocInstance DocNameI]
-- | The number of haddockable and haddocked items in the module, as a
@@ -154,6 +149,7 @@ data Interface = Interface
-- | Tokenized source code of module (available if Haddock is invoked with
-- source generation flag).
, ifaceHieFile :: !(Maybe FilePath)
+
, ifaceDynFlags :: !DynFlags
}
@@ -216,32 +212,7 @@ toInstalledIface interface = InstalledInterface
data ExportItem name
-- | An exported declaration.
- = ExportDecl
- {
- -- | A declaration.
- expItemDecl :: !(LHsDecl name)
-
- -- | Bundled patterns for a data type declaration
- , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]
-
- -- | Maybe a doc comment, and possibly docs for arguments (if this
- -- decl is a function or type-synonym).
- , expItemMbDoc :: !(DocForDecl (IdP name))
-
- -- | Subordinate names, possibly with documentation.
- , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))]
-
- -- | Instances relevant to this declaration, possibly with
- -- documentation.
- , expItemInstances :: ![DocInstance name]
-
- -- | Fixity decls relevant to this declaration (including subordinates).
- , expItemFixities :: ![(IdP name, Fixity)]
-
- -- | Whether the ExportItem is from a TH splice or not, for generating
- -- the appropriate type of Source link.
- , expItemSpliced :: !Bool
- }
+ = ExportDecl (XExportDecl name)
-- | An exported entity for which we have no documentation (perhaps because it
-- resides in another package).
@@ -249,7 +220,7 @@ data ExportItem name
{ expItemName :: !(IdP name)
-- | Subordinate names.
- , expItemSubs :: ![IdP name]
+ , expItemSubs :: [IdP name]
}
-- | A section heading.
@@ -271,9 +242,66 @@ data ExportItem name
-- | A cross-reference to another module.
| ExportModule !Module
+-- | A type family mapping a name type index to types of export declarations.
+-- The pre-renaming type index ('GhcRn') is mapped to the type of export
+-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is
+-- generated during the Haddock renaming step. The post-renaming type index
+-- ('DocNameI') is mapped to the type of export declarations which do include
+-- Hoogle output ('RnExportD').
+type family XExportDecl x where
+ XExportDecl GhcRn = ExportD GhcRn
+ XExportDecl DocNameI = RnExportD
+
+-- | Represents an export declaration that Haddock has discovered to be exported
+-- from a module. The @name@ index indicated whether the declaration has been
+-- renamed such that each 'Name' points to it's optimal link destination.
+data ExportD name = ExportD
+ {
+ -- | A declaration.
+ expDDecl :: !(LHsDecl name)
+
+ -- | Bundled patterns for a data type declaration
+ , expDPats :: [(HsDecl name, DocForDecl (IdP name))]
+
+ -- | Maybe a doc comment, and possibly docs for arguments (if this
+ -- decl is a function or type-synonym).
+ , expDMbDoc :: !(DocForDecl (IdP name))
+
+ -- | Subordinate names, possibly with documentation.
+ , expDSubDocs :: [(IdP name, DocForDecl (IdP name))]
+
+ -- | Instances relevant to this declaration, possibly with
+ -- documentation.
+ , expDInstances :: [DocInstance name]
+
+ -- | Fixity decls relevant to this declaration (including subordinates).
+ , expDFixities :: [(IdP name, Fixity)]
+
+ -- | Whether the ExportD is from a TH splice or not, for generating
+ -- the appropriate type of Source link.
+ , expDSpliced :: !Bool
+ }
+
+-- | Represents export declarations that have undergone renaming such that every
+-- 'Name' in the declaration points to an optimal link destination. Since Hoogle
+-- output is also generated during the renaming step, each declaration is also
+-- attached to its Hoogle textual database entries, /if/ Hoogle output is
+-- enabled and the module is not hidden in the generated documentation using the
+-- @{-# OPTIONS_HADDOCK hide #-}@ pragma.
+data RnExportD = RnExportD
+ {
+ -- | The renamed export declaration
+ rnExpDExpD :: !(ExportD DocNameI)
+
+ -- | If Hoogle textbase (textual database) output is enabled, the text
+ -- output lines for this declaration. If Hoogle output is not enabled, the
+ -- list will be empty.
+ , rnExpDHoogle :: [String]
+ }
+
data Documentation name = Documentation
- { documentationDoc :: Maybe (MDoc name)
- , documentationWarning :: !(Maybe (Doc name))
+ { documentationDoc :: Maybe (MDoc name)
+ , documentationWarning :: Maybe (Doc name)
} deriving Functor
-- | Arguments and result are indexed by Int, zero-based from the left,
@@ -284,6 +312,32 @@ type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
noDocForDecl = (Documentation Nothing Nothing, mempty)
+-- | As we build the declaration map, we really only care to track whether we
+-- have only seen a value declaration for a 'Name', or anything else. This type
+-- is used to represent those cases. If the only declaration attached to a
+-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the
+-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to
+-- it. If we see any other type of declaration for the 'Name', we can just use
+-- it.
+--
+-- This type saves us from storing /every/ declaration we see for a given 'Name'
+-- in the map, which is unnecessary and very problematic for overall memory
+-- usage.
+data DeclMapEntry
+ = EValD !SrcSpan
+ | EOther (LHsDecl GhcRn)
+
+instance Semigroup DeclMapEntry where
+ (EValD _) <> e = e
+ e <> _ = e
+
+-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD'
+-- declaration, only the source location will be noted (since that is all we
+-- care to store in the 'DeclMap' due to the way top-level bindings with no type
+-- signatures are handled). Otherwise, the entire declaration will be kept.
+toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry
+toDeclMapEntry (L l (ValD _ _)) = EValD (locA l)
+toDeclMapEntry d = EOther d
-----------------------------------------------------------------------------
-- * Cross-referencing
--
GitLab