aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal3
-rw-r--r--haddock-api/src/Haddock.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs5
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs11
-rw-r--r--haddock-api/src/Haddock/Interface.hs312
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs596
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs5
-rw-r--r--haddock-api/src/Haddock/Options.hs9
-rw-r--r--haddock-api/src/Haddock/Types.hs75
10 files changed, 607 insertions, 420 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 0274eee7..52191e13 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -44,7 +44,7 @@ library
-- this package typically supports only single major versions
build-depends: base ^>= 4.16.0
- , ghc ^>= 9.0
+ , ghc ^>= 9.1
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.9.0
, xhtml ^>= 3000.2.2
@@ -60,6 +60,7 @@ library
, exceptions
, filepath
, ghc-boot
+ , mtl
, transformers
hs-source-dirs: src
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8c549304..2b6e2d57 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -153,12 +153,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do
sinceQual <- rightOrThrowE (sinceQualification flags)
-- inject dynamic-too into flags before we proceed
- flags' <- ghc flags $ do
+ flags'' <- ghc flags $ do
df <- getDynFlags
case lookup "GHC Dynamic" (compilerInfo df) of
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ flags' <- pure $ case optParCount flags'' of
+ Nothing -> flags''
+ Just Nothing -> Flag_OptGhc "-j" : flags''
+ Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''
+
-- bypass the interface version check
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d3f3b79b..52d73265 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -12,7 +12,7 @@ import qualified Data.ByteString as BS
import GHC.Types.SourceText
import GHC.Driver.Session
-import GHC.Utils.Error ( pprLocErrMsg )
+import GHC.Utils.Error ( pprLocMsgEnvelope )
import GHC.Data.FastString ( mkFastString )
import GHC.Parser.Errors.Ppr ( pprError )
import GHC.Parser.Lexer as Lexer
@@ -42,7 +42,7 @@ parse dflags fpath bs = case unP (go False []) initState of
PFailed pst ->
let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
panic $ showSDoc dflags $
- text "Hyperlinker parse error:" $$ pprLocErrMsg err
+ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
where
initState = initParserState pflags buf start
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index f8c22e0a..1bdbf81b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -223,10 +223,7 @@ moduleInfo iface =
("Language", lg)
] ++ extsForm
where
- lg inf = case hmi_language inf of
- Nothing -> Nothing
- Just Haskell98 -> Just "Haskell98"
- Just Haskell2010 -> Just "Haskell2010"
+ lg inf = fmap show (hmi_language inf)
multilineRow :: String -> [String] -> HtmlTable
multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 34297a0a..546e2941 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -35,7 +35,6 @@ import GHC.Driver.Ppr (showPpr )
import GHC.Types.Name
import GHC.Unit.Module
import GHC
-import GHC.Core.Class
import GHC.Driver.Session
import GHC.Types.Basic
import GHC.Types.SrcLoc ( advanceSrcLoc )
@@ -190,7 +189,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
getMainDeclBinderI (TyClD _ d) = [tcdNameI d]
getMainDeclBinderI (ValD _ d) =
- case collectHsBindBinders d of
+ case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
@@ -526,14 +525,6 @@ modifySessionDynFlags f = do
return ()
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
- mty <- lookupGlobalName n
- case mty of
- Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
- _ -> return Nothing
-
-------------------------------------------------------------------------------
-- * DynFlags
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 141325be..fa1f3ee5 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -29,7 +29,8 @@
-- using this environment.
-----------------------------------------------------------------------------
module Haddock.Interface (
- processModules
+ plugin
+ , processModules
) where
@@ -43,8 +44,8 @@ import Haddock.Types
import Haddock.Utils
import Control.Monad
-import Control.Monad.IO.Class ( liftIO )
-import Control.Exception (evaluate)
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.IORef
import Data.List (foldl', isPrefixOf, nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -58,14 +59,19 @@ import GHC.Data.Graph.Directed
import GHC.Driver.Session hiding (verbosity)
import GHC hiding (verbosity)
import GHC.Driver.Env
+import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (tcg_rdr_env)
+import GHC.Tc.Types (TcM, TcGblEnv(..))
+import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
+import GHC.Tc.Utils.Env (tcLookupGlobal)
import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
import GHC.Utils.Error (withTimingD)
import GHC.HsToCore.Docs
import GHC.Runtime.Loader (initializePlugins)
+import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..),
+ defaultPlugin, keepRenamedSource)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -91,8 +97,14 @@ processModules verbosity modules flags extIfaces = do
#endif
out verbosity verbose "Creating interfaces..."
- let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
- , iface <- ifInstalledIfaces ext ]
+ let
+ instIfaceMap :: InstIfaceMap
+ instIfaceMap = Map.fromList
+ [ (instMod iface, iface)
+ | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext
+ ]
+
(interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap
let exportedNames =
@@ -128,101 +140,203 @@ processModules verbosity modules flags extIfaces = do
createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces verbosity modules flags instIfaceMap = do
- -- Ask GHC to tell us what the module graph is
+ (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
+ verbosity flags instIfaceMap
+
+ let
+ installHaddockPlugin :: HscEnv -> HscEnv
+ installHaddockPlugin hsc_env = hsc_env
+ {
+ hsc_dflags =
+ gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy
+ , hsc_static_plugins =
+ haddockPlugin : hsc_static_plugins hsc_env
+ }
+
+ -- Note that we would rather use withTempSession but as long as we
+ -- have the separate attachInstances step we need to keep the session
+ -- alive to be able to find all the instances.
+ modifySession installHaddockPlugin
+
targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
setTargets targets
- modGraph <- depanal [] False
- -- Visit modules in that order
- let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing
- out verbosity normal "Haddock coverage:"
- (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
- return (reverse ifaces, ms)
- where
- f state (InstantiationNode _) = pure state
- f (ifaces, ifaceMap, !ms) (ModuleNode ems) = do
- x <- {-# SCC processModule #-}
- withTimingD "processModule" (const ()) $ do
- processModule verbosity (emsModSummary ems) flags ifaceMap instIfaceMap
- return $ case x of
- Just (iface, ms') -> ( iface:ifaces
- , Map.insert (ifaceMod iface) iface ifaceMap
- , unionModuleSet ms ms' )
- Nothing -> ( ifaces
- , ifaceMap
- , ms ) -- Boot modules don't generate ifaces.
-
-
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
-processModule verbosity modsum flags modMap instIfaceMap = do
- out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
-
- -- Since GHC 8.6, plugins are initialized on a per module basis
- hsc_env' <- getSession
- hsc_env'' <- liftIO $ initializePlugins (hsc_env' { hsc_dflags = ms_hspp_opts modsum })
- setSession hsc_env''
- let modsum' = modsum { ms_hspp_opts = (hsc_dflags hsc_env'') }
-
- tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum'
-
- case isBootSummary modsum of
- IsBoot ->
- return Nothing
- NotBoot -> do
- unit_state <- hsc_units <$> getSession
- out verbosity verbose "Creating interface..."
- (interface, msgs) <- {-# SCC createIterface #-}
- withTimingD "createInterface" (const ()) $ do
- runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap
-
- -- We need to keep track of which modules were somehow in scope so that when
- -- Haddock later looks for instances, it also looks in these modules too.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- home_unit = hsc_home_unit hsc_env
- !mods = mkModuleSet [ nameModule name
- | gre <- globalRdrEnvElts new_rdr_env
- , let name = greMangledName gre
- , nameIsFromExternalPackage home_unit name
- , isTcOcc (nameOccName name) -- Types and classes only
- , unQualOK gre ] -- In scope unqualified
-
- liftIO $ mapM_ putStrLn (nub msgs)
- dflags <- getDynFlags
- let (haddockable, haddocked) = ifaceHaddockCoverage interface
- percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
- modString = moduleString (ifaceMod interface)
- coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
- header = case ifaceDoc interface of
- Documentation Nothing _ -> False
- _ -> True
- undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface ]
- where
- formatName :: SrcSpan -> HsDecl GhcRn -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
- RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
- _ -> ""
-
- p [] = ""
- p (x:_) = let n = pretty dflags x
- ms = modString ++ "."
- in if ms `isPrefixOf` n
- then drop (length ms) n
- else n
-
- when (OptHide `notElem` ifaceOptions interface) $ do
- out verbosity normal coverageMsg
- when (Flag_NoPrintMissingDocs `notElem` flags
- && not (null undocumentedExports && header)) $ do
- out verbosity normal " Missing documentation for:"
- unless header $ out verbosity normal " Module header"
- mapM_ (out verbosity normal . (" " ++)) undocumentedExports
- interface' <- liftIO $ evaluate interface
- return (Just (interface', mods))
+ loadOk <- withTimingD "load" (const ()) $
+ {-# SCC load #-} GHC.load LoadAllTargets
+
+ case loadOk of
+ Failed ->
+ throwE "Cannot typecheck modules"
+ Succeeded -> do
+ modGraph <- GHC.getModuleGraph
+ ifaceMap <- liftIO getIfaces
+ moduleSet <- liftIO getModules
+
+ let
+ ifaces :: [Interface]
+ ifaces =
+ [ Map.findWithDefault
+ (error "haddock:iface")
+ (ms_mod (emsModSummary ems))
+ ifaceMap
+ | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+ ]
+
+ return (ifaces, moduleSet)
+
+
+-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock
+-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
+-- parallelize the compilation process.
+plugin
+ :: MonadIO m
+ => Verbosity
+ -> [Flag]
+ -> InstIfaceMap
+ -> 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
+
+ let
+ processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
+ processTypeCheckedResult mod_summary tc_gbl_env
+ -- Don't do anything for hs-boot modules
+ | IsBoot <- isBootSummary mod_summary =
+ pure ()
+ | otherwise = do
+ hsc_env <- getTopEnv
+ ifaces <- liftIO $ readIORef ifaceMapRef
+ (iface, modules) <- withTimingD "processModule" (const ()) $
+ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
+
+ liftIO $ do
+ atomicModifyIORef' ifaceMapRef $ \xs ->
+ (Map.insert (ms_mod mod_summary) iface xs, ())
+
+ atomicModifyIORef' moduleSetRef $ \xs ->
+ (modules `unionModuleSet` xs, ())
+
+ staticPlugin :: StaticPlugin
+ staticPlugin = StaticPlugin
+ {
+ spPlugin = PluginWithArgs
+ {
+ paPlugin = defaultPlugin
+ {
+ renamedResultAction = keepRenamedSource
+ , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+ processTypeCheckedResult mod_summary tc_gbl_env
+ pure tc_gbl_env
+
+ }
+ , paArguments = []
+ }
+ }
+
+ pure
+ ( staticPlugin
+ , liftIO (readIORef ifaceMapRef)
+ , liftIO (readIORef moduleSetRef)
+ )
+
+
+processModule1
+ :: Verbosity
+ -> [Flag]
+ -> IfaceMap
+ -> InstIfaceMap
+ -> HscEnv
+ -> ModSummary
+ -> TcGblEnv
+ -> TcM (Interface, ModuleSet)
+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do
+ out verbosity verbose "Creating interface..."
+
+ let
+ TcGblEnv { tcg_rdr_env } = tc_gbl_env
+
+ unit_state = hsc_units hsc_env
+
+ (!interface, messages) <- {-# SCC createInterface #-}
+ withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+ createInterface1 flags unit_state mod_summary tc_gbl_env
+ ifaces inst_ifaces
+
+ -- We need to keep track of which modules were somehow in scope so that when
+ -- Haddock later looks for instances, it also looks in these modules too.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ let
+ mods :: ModuleSet
+ !mods = mkModuleSet
+ [ nameModule name
+ | gre <- globalRdrEnvElts tcg_rdr_env
+ , let name = greMangledName gre
+ , nameIsFromExternalPackage (hsc_home_unit hsc_env) name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre -- In scope unqualified
+ ]
+
+ liftIO $ mapM_ putStrLn (nub messages)
+ dflags <- getDynFlags
+
+ let
+ (haddockable, haddocked) =
+ ifaceHaddockCoverage interface
+
+ percentage :: Int
+ percentage =
+ round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)
+
+ modString :: String
+ modString = moduleString (ifaceMod interface)
+
+ coverageMsg :: String
+ coverageMsg =
+ printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+
+ header :: Bool
+ header = case ifaceDoc interface of
+ Documentation Nothing _ -> False
+ _ -> True
+
+ undocumentedExports :: [String]
+ undocumentedExports =
+ [ formatName s n
+ | ExportDecl { expItemDecl = L s n
+ , expItemMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface
+ ]
+ where
+ formatName :: SrcSpan -> HsDecl GhcRn -> String
+ formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
+ show (srcSpanStartLine rss) ++ ")"
+ _ -> ""
+
+ p :: Outputable a => [a] -> String
+ p [] = ""
+ p (x:_) = let n = pretty dflags x
+ ms = modString ++ "."
+ in if ms `isPrefixOf` n
+ then drop (length ms) n
+ else n
+
+ when (OptHide `notElem` ifaceOptions interface) $ do
+ out verbosity normal coverageMsg
+ when (Flag_NoPrintMissingDocs `notElem` flags
+ && not (null undocumentedExports && header)) $ do
+ out verbosity normal " Missing documentation for:"
+ unless header $ out verbosity normal " Module header"
+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports
+
+ pure (interface, mods)
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 76baf624..272b8f02 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -18,43 +20,43 @@
-- which creates a Haddock 'Interface' from the typechecking
-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface) where
+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where
import Documentation.Haddock.Doc (metaDocAppend)
-import Haddock.Types
+import Haddock.Types hiding (liftErrMsg)
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
-import Data.Bifunctor
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict hiding (tell)
import Data.Bitraversable
import qualified Data.Map as M
-import qualified Data.Set as S
import Data.Map (Map)
-import Data.List (find, foldl')
+import Data.List
import Data.Maybe
-import Control.Monad
import Data.Traversable
-import GHC.Stack (HasCallStack)
+import GHC.Stack
+import GHC.Tc.Utils.Monad (finalSafeMode)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
import qualified GHC.Unit.Module as Module
-import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModSummary
import qualified GHC.Types.SrcLoc as SrcLoc
import GHC.Types.SourceFile
+import GHC.Core.Class
import GHC.Core.ConLike (ConLike(..))
-import GHC
+import GHC hiding (lookupName)
import GHC.Driver.Ppr
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State
import GHC.Types.Name.Reader
-import GHC.Tc.Types
+import GHC.Tc.Types hiding (IfM)
import GHC.Data.FastString ( unpackFS, bytesFS )
import GHC.Types.Basic ( PromotionFlag(..) )
import GHC.Types.SourceText
@@ -64,194 +66,275 @@ import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import GHC.Unit.Module.Warnings
-mkExceptionContext :: TypecheckedModule -> String
-mkExceptionContext =
- ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-
--- | Use a 'TypecheckedModule' to produce an 'Interface'.
--- To do this, we need access to already processed modules in the topological
--- sort. That's what's in the 'IfaceMap'.
-createInterface :: HasCallStack
- => TypecheckedModule
- -> UnitState
- -> [Flag] -- Boolean flags
- -> IfaceMap -- Locally processed modules
- -> InstIfaceMap -- External, already installed interfaces
- -> ErrMsgGhc Interface
-createInterface tm unit_state flags modMap instIfaceMap =
- withExceptionContext (mkExceptionContext tm) $ do
-
- let ms = pm_mod_summary . tm_parsed_module $ tm
- mi = moduleInfo tm
- L _ hsm = parsedSource tm
- !safety = modInfoSafe mi
- mdl = ms_mod ms
- sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
- is_sig = ms_hsc_src ms == HsigFile
- dflags = ms_hspp_opts ms
- !instances = modInfoInstances mi
- !fam_instances = md_fam_insts md
- !exportedNames = modInfoExportsWithSelectors mi
- (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl)
- pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
-
- (TcGblEnv { tcg_rdr_env = gre
- , tcg_warns = warnings
- , tcg_exports = all_exports0
- }, md) = tm_internals_ tm
- all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre
-
- -- 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) <-
- case renamedSource tm of
- Nothing -> do
- liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
- return (emptyRnGroup, [], Nothing, Nothing)
- Just x -> return x
-
- opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
+newtype IfEnv m = IfEnv
+ {
+ -- | Lookup names in the enviroment.
+ ife_lookup_name :: Name -> m (Maybe TyThing)
+ }
+
+
+-- | A monad in which we create Haddock interfaces. Not to be confused with
+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
+--
+-- In the past `createInterface` was running in the `Ghc` monad but proved hard
+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
+-- over the Ghc specific clarifies where side effects happen.
+newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a }
+
+
+deriving newtype instance Functor m => Functor (IfM m)
+deriving newtype instance Applicative m => Applicative (IfM m)
+deriving newtype instance Monad m => Monad (IfM m)
+deriving newtype instance MonadIO m => MonadIO (IfM m)
+deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)
+deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)
+
+
+-- | Run an `IfM` action.
+runIfM
+ -- | Lookup a global name in the current session. Used in cases
+ -- where declarations don't
+ :: (Name -> m (Maybe TyThing))
+ -- | The action to run.
+ -> IfM m a
+ -- | Result and accumulated error/warning messages.
+ -> m (a, [ErrMsg])
+runIfM lookup_name action = do
+ let
+ if_env = IfEnv
+ {
+ ife_lookup_name = lookup_name
+ }
+ runWriterT (runReaderT (unIfM action) if_env)
+
+
+liftErrMsg :: Monad m => ErrMsgM a -> IfM m a
+liftErrMsg action = do
+ writer (runWriter action)
+
+
+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
+lookupName name = IfM $ do
+ lookup_name <- asks ife_lookup_name
+ lift $ lift (lookup_name name)
+
+
+createInterface1
+ :: MonadIO m
+ => [Flag]
+ -> UnitState
+ -> ModSummary
+ -> TcGblEnv
+ -> IfaceMap
+ -> InstIfaceMap
+ -> IfM m Interface
+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
+
+ let
+ ModSummary
+ {
+ -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
+ -- pragmas in the modules source code. Used to infer
+ -- safety of module.
+ ms_hspp_opts
+ , ms_location = ModLocation
+ {
+ ml_hie_file
+ }
+ } = mod_sum
+
+ TcGblEnv
+ {
+ tcg_mod
+ , tcg_src
+ , tcg_semantic_mod
+ , tcg_rdr_env
+ , tcg_exports
+ , tcg_insts
+ , tcg_fam_insts
+ , tcg_warns
+
+ -- Renamed source
+ , tcg_rn_imports
+ , tcg_rn_exports
+ , tcg_rn_decls
+
+ , tcg_doc_hdr
+ } = tc_gbl_env
+
+ dflags = ms_hspp_opts
+
+ is_sig = tcg_src == HsigFile
+
+ (pkg_name_fs, _) =
+ modulePackageInfo unit_state flags (Just tcg_mod)
+
+ pkg_name :: Maybe Package
+ pkg_name =
+ let
+ unpack (PackageName name) = unpackFS name
+ in
+ fmap unpack pkg_name_fs
+
+ fixities :: FixMap
+ fixities = case tcg_rn_decls of
+ Nothing -> mempty
+ Just dx -> mkFixMap dx
+
+ -- Locations of all the TH splices
+ loc_splices :: [SrcSpan]
+ loc_splices = case tcg_rn_decls of
+ Nothing -> []
+ Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]
+
+ decls <- case tcg_rn_decls of
+ Nothing -> do
+ tell [ "Warning: Renamed source is not available" ]
+ pure []
+ Just dx ->
+ pure (topDecls dx)
+
+ -- Derive final options to use for haddocking this module
+ doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod
+
+ let
+ -- All elements of an explicit export list, if present
+ export_list :: Maybe [(IE GhcRn, Avails)]
+ export_list
+ | OptIgnoreExports `elem` doc_opts =
+ Nothing
+ | Just rn_exports <- tcg_rn_exports =
+ Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]
+ | otherwise =
+ Nothing
+
+ -- All the exported Names of this module.
+ exported_names :: [Name]
+ exported_names =
+ concatMap availNamesWithSelectors tcg_exports
+
+ -- Module imports of the form `import X`. Note that there is
+ -- a) no qualification and
+ -- b) no import list
+ imported_modules :: Map ModuleName [ModuleName]
+ imported_modules
+ | Just{} <- export_list =
+ unrestrictedModuleImports (map unLoc tcg_rn_imports)
+ | otherwise =
+ M.empty
+
+ -- TyThings that have instances defined in this module
+ local_instances :: [Name]
+ local_instances =
+ [ name
+ | name <- map getName tcg_insts ++ map getName tcg_fam_insts
+ , nameIsLocalOrFrom tcg_semantic_mod name
+ ]
+
+ -- Infer module safety
+ safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)
-- Process the top-level module header documentation.
- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
-
- let declsWithDocs = topDecls group_
-
- exports0 = fmap (map (first unLoc)) mayExports
- (all_exports, exports)
- | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
- | otherwise = (all_exports0, exports0)
-
- unrestrictedImportedMods
- -- module re-exports are only possible with
- -- explicit export list
- | Just{} <- exports
- = unrestrictedModuleImports (map unLoc imports)
- | otherwise = M.empty
-
- fixMap = mkFixMap group_
- (decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom sem_mdl)
- $ map getName fam_instances
- ++ map getName instances
- -- Locations of all TH splices
- splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
-
- warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
-
- maps@(!docMap, !argMap, !declMap, _) <-
- 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 pkgName mdl sem_mdl allWarnings gre
- exportedNames decls maps fixMap unrestrictedImportedMods
- splices exports all_exports instIfaceMap dflags
-
- let !visibleNames = mkVisibleNames maps exportItems opts
-
- -- Measure haddock documentation coverage.
- let prunedExportItems0 = pruneExportItems exportItems
- !haddockable = 1 + length exportItems -- module + exports
- !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
- !coverage = (haddockable, haddocked)
-
- -- Prune the export list to just those declarations that have
- -- documentation, if the 'prune' option is on.
- let prunedExportItems'
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
- !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
-
- let !aliases = mkAliasMap unit_state $ tm_renamed_source tm
-
- modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
-
- -- Prune the docstring 'Map's to keep only docstrings that are not private.
- --
- -- Besides all the names that GHC has told us this module exports, we also
- -- keep the docs for locally defined class instances. This is more names than
- -- we need, but figuring out which instances are fully private is tricky.
- --
- -- We do this pruning to avoid having to rename, emit warnings, and save
- -- docstrings which will anyways never be rendered.
- let !localVisibleNames = S.fromList (localInsts ++ exportedNames)
- !prunedDocMap = M.restrictKeys docMap localVisibleNames
- !prunedArgMap = M.restrictKeys argMap localVisibleNames
-
- return $! Interface {
- ifaceMod = mdl
- , ifaceIsSig = is_sig
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = prunedDocMap
- , ifaceArgMap = prunedArgMap
- , ifaceRnDocMap = M.empty -- Filled in `renameInterface`
- , ifaceRnArgMap = M.empty -- Filled in `renameInterface`
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = [] -- Filled in `renameInterface`
- , ifaceExports = exportedNames
- , ifaceVisibleExports = visibleNames
- , ifaceDeclMap = declMap
- , ifaceFixMap = fixMap
- , ifaceModuleAliases = aliases
- , ifaceInstances = instances
- , ifaceFamInstances = fam_instances
- , ifaceOrphanInstances = [] -- Filled in `attachInstances`
- , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
- , ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warningMap
- , ifaceHieFile = Just $ ml_hie_file $ ms_location ms
- , ifaceDynFlags = dflags
- }
+ (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
+ tcg_rdr_env safety tcg_doc_hdr
+
+ -- Warnings on declarations in this module
+ decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
+
+ -- Warning on the module header
+ mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)
+
+ let
+ -- Warnings in this module and transitive warnings from dependend modules
+ warnings :: Map Name (Doc Name)
+ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))
+
+ maps@(!docs, !arg_docs, !decl_map, _) <-
+ liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)
+
+ export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod
+ warnings tcg_rdr_env exported_names (map fst decls) maps fixities
+ imported_modules loc_splices export_list tcg_exports inst_ifaces dflags
+
+ let
+ visible_names :: [Name]
+ visible_names = mkVisibleNames maps export_items doc_opts
+
+ -- Measure haddock documentation coverage.
+ pruned_export_items :: [ExportItem GhcRn]
+ pruned_export_items = pruneExportItems export_items
+
+ !haddockable = 1 + length export_items -- module + exports
+ !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items
+
+ coverage :: (Int, Int)
+ !coverage = (haddockable, haddocked)
+
+ aliases :: Map Module ModuleName
+ aliases = mkAliasMap unit_state tcg_rn_imports
+
+ return $! Interface
+ {
+ ifaceMod = tcg_mod
+ , ifaceIsSig = is_sig
+ , ifaceOrigFilename = msHsFilePath mod_sum
+ , ifaceHieFile = Just ml_hie_file
+ , ifaceInfo = info
+ , ifaceDoc = Documentation header_doc mod_warning
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , 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 = []
+ , ifaceExports = exported_names
+ , ifaceVisibleExports = visible_names
+ , ifaceDeclMap = decl_map
+ , ifaceFixMap = fixities
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = tcg_insts
+ , ifaceFamInstances = tcg_fam_insts
+ , ifaceOrphanInstances = [] -- Filled in attachInstances
+ , ifaceRnOrphanInstances = [] -- Filled in attachInstances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warnings
+ , ifaceDynFlags = dflags
+ }
-- | 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
-- will go in 'ifaceModuleAliases'.
-mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap state mRenamedSource =
- case mRenamedSource of
- Nothing -> M.empty
- Just (_,impDecls,_,_) ->
- M.fromList $
- mapMaybe (\(SrcLoc.L _ impDecl) -> do
- SrcLoc.L _ alias <- ideclAs impDecl
- return $
- (lookupModuleDyn state
- -- TODO: This is supremely dodgy, because in general the
- -- UnitId isn't going to look anything like the package
- -- qualifier (even with old versions of GHC, the
- -- IPID would be p-0.1, but a package qualifier never
- -- has a version number it. (Is it possible that in
- -- Haddock-land, the UnitIds never have version numbers?
- -- I, ezyang, have not quite understand Haddock's package
- -- identifier model.)
- --
- -- Additionally, this is simulating some logic GHC already
- -- has for deciding how to qualify names when it outputs
- -- them to the user. We should reuse that information;
- -- or at least reuse the renamed imports, which know what
- -- they import!
- (fmap Module.fsToUnit $
- fmap sl_fs $ ideclPkgQual impDecl)
- (case ideclName impDecl of SrcLoc.L _ name -> name),
- alias))
- impDecls
+mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName
+mkAliasMap state impDecls =
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ SrcLoc.L _ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn state
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
+ (fmap Module.fsToUnit $
+ fmap sl_fs $ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
-- We want to know which modules are imported without any qualification. This
-- way we can display module reexports more compactly. This mapping also looks
@@ -476,7 +559,7 @@ mkFixMap group_ =
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: HasCallStack
+ :: Monad m
=> Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
@@ -494,7 +577,7 @@ mkExportItems
-> Avails -- exported stuff from this module
-> InstIfaceMap
-> DynFlags
- -> ErrMsgGhc [ExportItem GhcRn]
+ -> IfM m [ExportItem GhcRn]
mkExportItems
is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
maps fixMap unrestricted_imp_mods splices exportList allExports
@@ -515,7 +598,7 @@ mkExportItems
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unLoc d | d <- decls ] >>= \case
+ findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
@@ -536,25 +619,39 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: HasCallStack
- => Bool -- is it a signature
- -> IfaceMap
- -> Module -- this module
- -> Module -- semantic module
- -> WarningMap
- -> [Name] -- exported names (orig)
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> InstIfaceMap
- -> DynFlags
- -> AvailInfo
- -> ErrMsgGhc [ExportItem GhcRn]
+
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)
+minimalDef n = do
+ mty <- lookupName n
+ case mty of
+ Just (ATyCon (tyConClass_maybe -> Just c)) ->
+ return . Just $ classMinimalDef c
+ _ ->
+ return Nothing
+
+
+availExportItem
+ :: forall m
+ . Monad m
+ => Bool -- is it a signature
+ -> IfaceMap
+ -> Module -- this module
+ -> Module -- semantic module
+ -> WarningMap
+ -> [Name] -- exported names (orig)
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> AvailInfo
+ -> IfM m [ExportItem GhcRn]
availExportItem is_sig modMap thisMod semMod warnings exportedNames
(docMap, argMap, declMap, _) fixMap splices instIfaceMap
dflags availInfo = declWith availInfo
where
- declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]
+ declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]
declWith avail = do
let t = availName avail
r <- findDecl avail
@@ -564,13 +661,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unLoc decl)
+ let declNames = getMainDeclBinder (unL decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unLoc decl) ->
+ Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
@@ -591,7 +688,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
in availExportDecl avail newDecl docs_
L loc (TyClD _ cl@ClassDecl{}) -> do
- mdef <- liftGhcToErrMsgGhc $ minimalDef t
+ mdef <- minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
(L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_
@@ -620,7 +717,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
- availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+ availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl declName parentDecl =
case extractDecl declMap declName parentDecl of
Right d -> pure d
@@ -632,7 +729,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
- -> ErrMsgGhc [ ExportItem GhcRn ]
+ -> IfM m [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
| availExportsDecl avail = do
extractedDecl <- availDecl (availName avail) decl
@@ -678,7 +775,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
- findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl avail
| m == semMod =
case M.lookup n declMap of
@@ -707,10 +804,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
n = availName avail
m = nameModule n
- findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+ findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
findBundledPatterns avail = do
patsyns <- for constructor_names $ \name -> do
- mtyThing <- liftGhcToErrMsgGhc (lookupName name)
+ mtyThing <- lookupName name
case mtyThing of
Just (AConLike PatSynCon{}) -> do
export_items <- declWith (Avail.avail name)
@@ -740,10 +837,9 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
--- | Reify a declaration from the GHC internal 'TyThing' representation.
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
+hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl dflags t = do
- mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ mayTyThing <- lookupName t
case mayTyThing of
Nothing -> do
liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
@@ -762,8 +858,9 @@ hiDecl dflags t = do
-- It gets the type signature from GHC and that means it's not going to
-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
-- declaration and use it instead - 'nLoc' here.
-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
- -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)
+hiValExportItem
+ :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+ -> Maybe Fixity -> IfM m (ExportItem GhcRn)
hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
@@ -793,12 +890,14 @@ lookupDocs avail warnings docMap argMap =
-- | Export the given module as `ExportModule`. We are not concerned with the
-- single export items of the given module.
-moduleExport :: Module -- ^ Module A (identity, NOT semantic)
- -> DynFlags -- ^ The flags used when typechecking A
- -> IfaceMap -- ^ Already created interfaces
- -> InstIfaceMap -- ^ Interfaces in other packages
- -> ModuleName -- ^ The exported module
- -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items
+moduleExport
+ :: Monad m
+ => Module -- ^ Module A (identity, NOT semantic)
+ -> DynFlags -- ^ The flags used when typechecking A
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> ModuleName -- ^ The exported module
+ -> IfM m [ExportItem GhcRn] -- ^ Resulting export items
moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- NB: we constructed the identity module when looking up in
-- the IfaceMap.
@@ -812,9 +911,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
- liftErrMsg $
- tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty dflags expMod]
+ liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
return []
where
m = mkModule (moduleUnit thisMod) expMod -- Identity module!
@@ -840,22 +938,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- every locally defined declaration is exported; thus, we just
-- zip through the renamed declarations.
-fullModuleContents :: Bool -- is it a signature
- -> IfaceMap
- -> Maybe Package -- this package
- -> Module -- this module
- -> Module -- semantic module
- -> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment
- -> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> InstIfaceMap
- -> DynFlags
- -> Avails
- -> ErrMsgGhc [ExportItem GhcRn]
+fullModuleContents
+ :: Monad m
+ => Bool -- is it a signature
+ -> IfaceMap
+ -> Maybe Package -- this package
+ -> Module -- this module
+ -> Module -- semantic module
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> [Name] -- exported names (orig)
+ -> [LHsDecl GhcRn] -- renamed source declarations
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> Avails
+ -> IfM m [ExportItem GhcRn]
fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
let availEnv = availsToNameEnv (nubAvails avails)
@@ -868,7 +968,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
return [[ExportDoc doc]]
(L _ (ValD _ valDecl))
- | name:_ <- collectHsBindBinders valDecl
+ | name:_ <- collectHsBindBinders CollNoDictBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> return []
_ ->
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index fa36d83b..2df2bbbf 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -21,8 +22,8 @@ module Haddock.Interface.LexParseRn
import Control.Arrow
import Control.Monad
-import Data.Functor (($>))
-import Data.List (maximumBy, (\\))
+import Data.Functor
+import Data.List ((\\), maximumBy)
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
import GHC.Driver.Session (languageExtensions)
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index dd7b38cb..4d22505f 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -24,6 +24,7 @@ module Haddock.Options (
optSourceCssFile,
sourceUrls,
wikiUrls,
+ optParCount,
optDumpInterfaceFile,
optShowInterfaceFile,
optLaTeXStyle,
@@ -110,6 +111,7 @@ data Flag
| Flag_Reexport String
| Flag_SinceQualification String
| Flag_IgnoreLinkSymbol String
+ | Flag_ParCount (Maybe Int)
deriving (Eq, Show)
@@ -223,7 +225,9 @@ options backwardsCompat =
Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
"package qualification of @since, one of\n'always' (default) or 'only-external'",
Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
- "name of a symbol which does not trigger a warning in case of link issue"
+ "name of a symbol which does not trigger a warning in case of link issue",
+ Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
+ "load modules in parallel"
]
@@ -306,10 +310,11 @@ optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-
optMathjax :: [Flag] -> Maybe String
optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ]
+optParCount :: [Flag] -> Maybe (Maybe Int)
+optParCount flags = optLast [ n | Flag_ParCount n <- flags ]
qualification :: [Flag] -> Either String QualOption
qualification flags =
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 2e7f6df4..7fd11d69 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -3,6 +3,9 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -25,14 +28,17 @@ module Haddock.Types (
, HsDocString, LHsDocString
, Fixity(..)
, module Documentation.Haddock.Types
+
+ -- $ Reexports
+ , runWriter
+ , tell
) where
-import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Control.Exception (throw)
-import Control.Monad (ap)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
@@ -306,10 +312,12 @@ data DocName
data DocNameI
+type instance NoGhcTc DocNameI = DocNameI
+
type instance IdP DocNameI = DocName
instance CollectPass DocNameI where
- collectXXPat _ ext = noExtCon ext
+ collectXXPat _ _ ext = noExtCon ext
instance NamedThing DocName where
getName (Documented name _) = name
@@ -626,26 +634,7 @@ data SinceQual
type ErrMsg = String
-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
-
-
-instance Functor ErrMsgM where
- fmap f (Writer (a, msgs)) = Writer (f a, msgs)
-
-instance Applicative ErrMsgM where
- pure a = Writer (a, [])
- (<*>) = ap
-
-instance Monad ErrMsgM where
- return = pure
- m >>= k = Writer $ let
- (a, w) = runWriter m
- (b, w') = runWriter (k a)
- in (b, w ++ w')
-
-
-tell :: [ErrMsg] -> ErrMsgM ()
-tell w = Writer ((), w)
+type ErrMsgM = Writer [ErrMsg]
-- Exceptions
@@ -679,40 +668,24 @@ withExceptionContext ctxt =
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
-- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
---instance MonadIO ErrMsgGhc where
--- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
---er, implementing GhcMonad involves annoying ExceptionMonad and
---WarnLogMonad classes, so don't bother.
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = WriterGhc . return . runWriter
--- for now, use (liftErrMsg . tell) for this
---tell :: [ErrMsg] -> ErrMsgGhc ()
---tell msgs = WriterGhc $ return ( (), msgs )
+newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a }
-instance Functor ErrMsgGhc where
- fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
+deriving newtype instance Functor ErrMsgGhc
+deriving newtype instance Applicative ErrMsgGhc
+deriving newtype instance Monad ErrMsgGhc
+deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc
+deriving newtype instance MonadIO ErrMsgGhc
-instance Applicative ErrMsgGhc where
- pure a = WriterGhc (return (a, []))
- (<*>) = ap
-instance Monad ErrMsgGhc where
- return = pure
- m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
- fmap (second (msgs1 ++)) (runWriterGhc (k a))
+runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])
+runWriterGhc = runWriterT . unErrMsgGhc
-instance MonadIO ErrMsgGhc where
- liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
-
-instance MonadThrow ErrMsgGhc where
- throwM e = WriterGhc (throwM e)
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = ErrMsgGhc . lift
-instance MonadCatch ErrMsgGhc where
- catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f))
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = writer . runWriter
-----------------------------------------------------------------------------
-- * Pass sensitive types
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:55:04 +0000