showModule,
moduleIsBootOrNotObjectLinkable,
getNameToInstancesIndex,
+ getNameToInstancesIndex2,
-- ** Inspecting types and kinds
exprType, TcRnExprMode(..),
import GhcMake
import DriverPipeline ( compileOne' )
import GhcMonad
-import TcRnMonad ( finalSafeMode, fixSafeInstances )
+import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import LoadIface ( loadSysInterface )
import TcRnTypes
import Packages
import NameSet
=> [Module] -- ^ visible modules. An orphan instance will be returned if and
-- only it is visible from at least one module in the list.
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-getNameToInstancesIndex visible_mods = do
+getNameToInstancesIndex visible_mods =
+ getNameToInstancesIndex2 visible_mods Nothing
+
+-- | Retrieve all type and family instances in the environment, indexed
+-- by 'Name'. Each name's lists will contain every instance in which that name
+-- is mentioned in the instance head.
+getNameToInstancesIndex2 :: GhcMonad m
+ => [Module] -- ^ visible modules. An orphan instance will be returned
+ -- if it is visible from at least one module in the list.
+ -> Maybe [Module] -- ^ modules to load. If this is not specified, we load
+ -- modules for everything that is in scope unqualified.
+ -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
+getNameToInstancesIndex2 visible_mods mods_to_load = do
hsc_env <- getSession
liftIO $ runTcInteractive hsc_env $
- do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+ do { case mods_to_load of
+ Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+ Just mods ->
+ let doc = text "Need interface for reporting instances in scope"
+ in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
+
; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
; let visible_mods' = mkModuleSet visible_mods
; (pkg_fie, home_fie) <- tcGetFamInstEnvs
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
import System.FilePath
import Text.Printf
+import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
import DynFlags hiding (verbosity)
import Exception
import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
-import RdrName (plusGlobalRdrEnv)
+import Name (nameIsFromExternalPackage, nameOccName)
+import OccName (isTcOcc)
+import RdrName (unQualOK, gre_name, globalRdrEnvElts)
import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
- interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+ (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
withTiming getDynFlags "attachInstances" (const ()) $ do
- attachInstances (exportedNames, mods) interfaces instIfaceMap
+ attachInstances (exportedNames, mods) interfaces instIfaceMap ms
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
--------------------------------------------------------------------------------
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces0 verbosity modules flags instIfaceMap =
-- Output dir needs to be set before calling depanal since depanal uses it to
-- compute output file names that are stored in the DynFlags of the
depanal [] False
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet)
createIfaces verbosity flags instIfaceMap mods = do
let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
out verbosity normal "Haddock coverage:"
- (ifaces, _) <- foldM f ([], Map.empty) sortedMods
- return (reverse ifaces)
+ (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
+ return (reverse ifaces, ms)
where
- f (ifaces, ifaceMap) modSummary = do
+ f (ifaces, ifaceMap, !ms) modSummary = do
x <- {-# SCC processModule #-}
withTiming getDynFlags "processModule" (const ()) $ do
processModule verbosity modSummary flags ifaceMap instIfaceMap
return $ case x of
- Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
- Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
+ 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)
+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) ++ "..."
tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
- -- We need to modify the interactive context's environment so that when
- -- Haddock later looks for instances, it also looks in the modules it
- -- encountered while typechecking.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- setSession hsc_env{ hsc_IC = old_IC {
- ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env
- } }
-
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
(interface, msg) <- {-# SCC createIterface #-}
withTiming getDynFlags "createInterface" (const ()) $ do
runWriterGhc $ createInterface tm flags modMap instIfaceMap
+
+ -- We need to modify the interactive context's environment so that when
+ -- Haddock later looks for instances, it also looks in the modules it
+ -- encountered while typechecking.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ hsc_env <- getSession
+ let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ !mods = mkModuleSet [ nameModule name
+ | gre <- globalRdrEnvElts new_rdr_env
+ , let name = gre_name gre
+ , nameIsFromExternalPackage this_pkg name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre ] -- In scope unqualified
+
liftIO $ mapM_ putStrLn msg
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
unless header $ out verbosity normal " Module header"
mapM_ (out verbosity normal . (" " ++)) undocumentedExports
interface' <- liftIO $ evaluate interface
- return (Just interface')
+ return (Just (interface', mods))
else
return Nothing
projects / ghc.git / commitdiff