summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
authorEdward Z. Yang <ezyang@cs.stanford.edu>2015-10-10 12:01:14 -0700
committerEdward Z. Yang <ezyang@cs.stanford.edu>2016-10-08 00:20:34 -0700
commit00b530d5402aaa37e4085ecdcae0ae54454736c1 (patch)
tree2d2963db4abdbcba9c12aea13a26e29e718e4778 /compiler/main
parent887485a45ae55e81b26b6412b6f9dcf6a497f044 (diff)
downloadhaskell-00b530d5402aaa37e4085ecdcae0ae54454736c1.tar.gz
The Backpack patch.
Summary: This patch implements Backpack for GHC. It's a big patch but I've tried quite hard to keep things, by-in-large, self-contained. The user facing specification for Backpack can be found at: https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst A guide to the implementation can be found at: https://github.com/ezyang/ghc-proposals/blob/backpack-impl/proposals/0000-backpack-impl.rst Has a submodule update for Cabal, as well as a submodule update for filepath to handle more strict checking of cabal-version. Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu> Test Plan: validate Reviewers: simonpj, austin, simonmar, bgamari, goldfire Subscribers: thomie, mpickering Differential Revision: https://phabricator.haskell.org/D1482
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DriverPipeline.hs4
-rw-r--r--compiler/main/DynFlags.hs119
-rw-r--r--compiler/main/Finder.hs10
-rw-r--r--compiler/main/GhcMake.hs123
-rw-r--r--compiler/main/HscMain.hs56
-rw-r--r--compiler/main/HscTypes.hs104
-rw-r--r--compiler/main/PackageConfig.hs23
-rw-r--r--compiler/main/PackageConfig.hs-boot7
-rw-r--r--compiler/main/Packages.hs437
-rw-r--r--compiler/main/Packages.hs-boot10
10 files changed, 661 insertions, 232 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 6e61d20dc8..30493f123e 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -144,7 +144,8 @@ compileOne' m_tc_result mHscMessage
case (status, hsc_lang) of
(HscUpToDate, _) ->
- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
+ -- TODO recomp014 triggers this assert. What's going on?!
+ -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
return hmi0 { hm_linkable = maybe_old_linkable }
(HscNotGeneratingCode, HscNothing) ->
let mb_linkable = if isHsBootOrSig src_flavour
@@ -989,6 +990,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
ms_location = location,
ms_hs_date = src_timestamp,
ms_obj_date = Nothing,
+ ms_parsed_mod = Nothing,
ms_iface_date = Nothing,
ms_textual_imps = imps,
ms_srcimps = src_imps }
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index b78d665e42..69fb8b814d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -53,8 +53,8 @@ module DynFlags (
wWarningFlags,
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
- SigOf, getSigOf,
makeDynFlagsConsistent,
+ thisUnitIdComponentId,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
@@ -97,6 +97,7 @@ module DynFlags (
setTmpDir,
setUnitId,
interpretPackageEnv,
+ canonicalizeHomeModule,
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
@@ -164,7 +165,6 @@ import CmdLineParser
import Constants
import Panic
import Util
-import UniqFM
import Maybes
import MonadUtils
import qualified Pretty
@@ -334,6 +334,7 @@ data DumpFlag
| Opt_D_dump_occur_anal
| Opt_D_dump_parsed
| Opt_D_dump_rn
+ | Opt_D_dump_shape
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
| Opt_D_dump_spec
@@ -642,11 +643,6 @@ instance Show SafeHaskellMode where
instance Outputable SafeHaskellMode where
ppr = text . show
-type SigOf = ModuleNameEnv Module
-
-getSigOf :: DynFlags -> ModuleName -> Maybe Module
-getSigOf dflags n = lookupUFM (sigOf dflags) n
-
-- | Contains not only a collection of 'GeneralFlag's but also a plethora of
-- information relating to the compilation of a single file or GHC session
data DynFlags = DynFlags {
@@ -654,8 +650,6 @@ data DynFlags = DynFlags {
ghcLink :: GhcLink,
hscTarget :: HscTarget,
settings :: Settings,
- -- See Note [Signature parameters in TcGblEnv and DynFlags]
- sigOf :: SigOf, -- ^ Compiling an hs-boot against impl.
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
optLevel :: Int, -- ^ Optimisation level
debugLevel :: Int, -- ^ How much debug information to produce
@@ -694,7 +688,9 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
- thisPackage :: UnitId, -- ^ key of package currently being compiled
+ thisPackage :: UnitId, -- ^ unit id of package currently being compiled.
+ -- Not properly initialized until initPackages
+ thisUnitIdInsts :: [(ModuleName, Module)],
-- ways
ways :: [Way], -- ^ Way flags from the command line
@@ -1159,8 +1155,11 @@ isNoLink _ = False
-- is used.
data PackageArg =
PackageArg String -- ^ @-package@, by 'PackageName'
- | UnitIdArg String -- ^ @-package-id@, by 'UnitId'
+ | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId'
deriving (Eq, Show)
+instance Outputable PackageArg where
+ ppr (PackageArg pn) = text "package" <+> text pn
+ ppr (UnitIdArg uid) = text "unit" <+> ppr uid
-- | Represents the renaming that may be associated with an exposed
-- package, e.g. the @rns@ part of @-package "foo (rns)"@.
@@ -1178,6 +1177,8 @@ data ModRenaming = ModRenaming {
modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope
-- under name @n@.
} deriving (Eq)
+instance Outputable ModRenaming where
+ ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)
-- | Flags for manipulating the set of non-broken packages.
newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@
@@ -1197,6 +1198,10 @@ data PackageFlag
-- NB: equality instance is used by InteractiveUI to test if
-- package flags have changed.
+instance Outputable PackageFlag where
+ ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)
+ ppr (HidePackage str) = text "-hide-package" <+> text str
+
defaultHscTarget :: Platform -> HscTarget
defaultHscTarget = defaultObjectTarget
@@ -1452,7 +1457,6 @@ defaultDynFlags mySettings =
ghcMode = CompManager,
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings),
- sigOf = emptyUFM,
verbosity = 0,
optLevel = 0,
debugLevel = 0,
@@ -1484,6 +1488,7 @@ defaultDynFlags mySettings =
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
thisPackage = mainUnitId,
+ thisUnitIdInsts = [],
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -1782,6 +1787,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
enableIfVerbose Opt_D_dump_vt_trace = False
enableIfVerbose Opt_D_dump_tc = False
enableIfVerbose Opt_D_dump_rn = False
+ enableIfVerbose Opt_D_dump_shape = False
enableIfVerbose Opt_D_dump_rn_stats = False
enableIfVerbose Opt_D_dump_hi_diffs = False
enableIfVerbose Opt_D_verbose_core2core = False
@@ -1997,26 +2003,29 @@ setOutputFile f d = d { outputFile = f}
setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f}
-parseSigOf :: String -> SigOf
-parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of
+parseUnitIdInsts :: String -> [(ModuleName, Module)]
+parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
- _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str)
- where parse = listToUFM <$> sepBy parseEntry (R.char ',')
+ _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)
+ where parse = sepBy parseEntry (R.char ',')
parseEntry = do
- n <- tok $ parseModuleName
- -- ToDo: deprecate this 'is' syntax?
- tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ()))
- m <- tok $ parseModule
+ n <- parseModuleName
+ _ <- R.char '='
+ m <- parseModuleId
return (n, m)
- parseModule = do
- pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.")
- _ <- R.char ':'
- m <- parseModuleName
- return (mkModule (stringToUnitId pk) m)
- tok m = skipSpaces >> m
-setSigOf :: String -> DynFlags -> DynFlags
-setSigOf s d = d { sigOf = parseSigOf s }
+setUnitIdInsts :: String -> DynFlags -> DynFlags
+setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
+
+updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
+updateWithInsts insts d =
+ -- Overwrite the instances, the instances are "indefinite"
+ d { thisPackage =
+ if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
+ then newUnitId (unitIdComponentId (thisPackage d)) insts
+ else thisPackage d
+ , thisUnitIdInsts = insts
+ }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
@@ -2358,7 +2367,7 @@ dynamic_flags_deps = [
-- as specifing that the number of
-- parallel builds is equal to the
-- result of getNumProcessors
- , make_ord_flag defFlag "sig-of" (sepArg setSigOf)
+ , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts)
-- RTS options -------------------------------------------------------------
, make_ord_flag defFlag "H" (HasArg (\s -> upd (\d ->
@@ -2719,6 +2728,8 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_worker_wrapper)
, make_ord_flag defGhcFlag "ddump-rn-trace"
(setDumpFlag Opt_D_dump_rn_trace)
+ , make_ord_flag defGhcFlag "ddump-shape"
+ (setDumpFlag Opt_D_dump_shape)
, make_ord_flag defGhcFlag "ddump-if-trace"
(setDumpFlag Opt_D_dump_if_trace)
, make_ord_flag defGhcFlag "ddump-cs-trace"
@@ -4280,22 +4291,18 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
-parseModuleName :: ReadP ModuleName
-parseModuleName = fmap mkModuleName
- $ munch1 (\c -> isAlphaNum c || c `elem` "_.")
-
parsePackageFlag :: String -- the flag
- -> (String -> PackageArg) -- type of argument
+ -> ReadP PackageArg -- type of argument
-> String -- string to parse
-> PackageFlag
-parsePackageFlag flag constr str
+parsePackageFlag flag arg_parse str
= case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
_ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)
where doc = flag ++ " " ++ str
parse = do
- pkg <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.")
- let mk_expose = ExposePackage doc (constr pkg)
+ pkg_arg <- tok arg_parse
+ let mk_expose = ExposePackage doc pkg_arg
( do _ <- tok $ string "with"
fmap (mk_expose . ModRenaming True) parseRns
<++ fmap (mk_expose . ModRenaming False) parseRns
@@ -4320,13 +4327,13 @@ exposePackage, exposePackageId, hidePackage,
exposePackage p = upd (exposePackage' p)
exposePackageId p =
upd (\s -> s{ packageFlags =
- parsePackageFlag "-package-id" UnitIdArg p : packageFlags s })
+ parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s })
exposePluginPackage p =
upd (\s -> s{ pluginPackageFlags =
- parsePackageFlag "-plugin-package" PackageArg p : pluginPackageFlags s })
+ parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })
exposePluginPackageId p =
upd (\s -> s{ pluginPackageFlags =
- parsePackageFlag "-plugin-package-id" UnitIdArg p : pluginPackageFlags s })
+ parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s })
hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
@@ -4340,10 +4347,38 @@ distrustPackage p = exposePackage p >>
exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
= dflags { packageFlags =
- parsePackageFlag "-package" PackageArg p : packageFlags dflags }
+ parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }
+
+parsePackageArg :: ReadP PackageArg
+parsePackageArg =
+ fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))
+
+parseUnitIdArg :: ReadP PackageArg
+parseUnitIdArg =
+ fmap UnitIdArg parseUnitId
+
+
+thisUnitIdComponentId :: DynFlags -> ComponentId
+thisUnitIdComponentId = unitIdComponentId . thisPackage
setUnitId :: String -> DynFlags -> DynFlags
-setUnitId p s = s{ thisPackage = stringToUnitId p }
+setUnitId p d =
+ updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
+ where
+ uid =
+ case filter ((=="").snd) (readP_to_S parseUnitId p) of
+ [(r, "")] -> r
+ _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
+
+-- | Given a 'ModuleName' of a signature in the home library, find
+-- out how it is instantiated. E.g., the canonical form of
+-- A in @p[A=q[]:A]@ is @q[]:A@.
+canonicalizeHomeModule :: DynFlags -> ModuleName -> Module
+canonicalizeHomeModule dflags mod_name =
+ case lookup mod_name (thisUnitIdInsts dflags) of
+ Nothing -> mkModule (thisPackage dflags) mod_name
+ Just mod -> mod
+
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 446cdf87e5..e813e9e52c 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -86,7 +86,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
removeFromFinderCache ref key =
atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
-lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult)
+lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult)
lookupFinderCache ref key = do
c <- readIORef ref
return $! lookupModuleEnv c key
@@ -131,7 +131,7 @@ findPluginModule hsc_env mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: HscEnv -> Module -> IO FindResult
+findExactModule :: HscEnv -> VirginModule -> IO FindResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
in if moduleUnitId mod == thisPackage dflags
@@ -205,7 +205,7 @@ findLookupResult hsc_env r = case r of
, fr_mods_hidden = []
, fr_suggestions = suggest })
-modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
+modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult
modLocationCache hsc_env mod do_this = do
m <- lookupFinderCache (hsc_FC hsc_env) mod
case m of
@@ -281,7 +281,7 @@ findHomeModule hsc_env mod_name =
-- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> Module -> IO FindResult
+findPackageModule :: HscEnv -> VirginModule -> IO FindResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
@@ -298,7 +298,7 @@ findPackageModule hsc_env mod = do
-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
-- The redundancy is to avoid an extra lookup in the package state
-- for the appropriate config.
-findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
+findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult
findPackageModule_ hsc_env mod pkg_conf =
ASSERT( moduleUnitId mod == packageConfigId pkg_conf )
modLocationCache hsc_env mod $
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0adee6e738..998d68c11a 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -14,12 +14,18 @@
-- -----------------------------------------------------------------------------
module GhcMake(
depanal,
- load, LoadHowMuch(..),
+ load, load', LoadHowMuch(..),
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
+ IsBoot(..),
+ summariseModule,
+ hscSourceToIsBoot,
+ findExtraSigImports,
+ implicitRequirements,
+
noModError, cyclicModuleErr
) where
@@ -40,6 +46,7 @@ import HscTypes
import Module
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck )
+import HscMain
import Bag ( listToBag )
import BasicTypes
@@ -55,9 +62,14 @@ import SrcLoc
import StringBuffer
import SysTools
import UniqFM
+import UniqDSet
+import TcBackpack
+import Packages
+import UniqSet
import Util
import qualified GHC.LanguageExtensions as LangExt
import NameEnv
+import TcRnDriver (findExtraSigImports, implicitRequirements)
import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
@@ -153,6 +165,14 @@ data LoadHowMuch
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much = do
mod_graph <- depanal [] False
+ load' how_much (Just batchMsg) mod_graph
+
+-- | Generalized version of 'load' which also supports a custom
+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
+-- produced by calling 'depanal'.
+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' how_much mHscMessage mod_graph = do
+ modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
guessOutputFile
hsc_env <- getSession
@@ -297,7 +317,7 @@ load how_much = do
setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
(upsweep_ok, modsUpswept)
- <- upsweep_fn pruned_hpt stable_mods cleanup mg
+ <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
@@ -741,16 +761,20 @@ parUpsweep
:: GhcMonad m
=> Int
-- ^ The number of workers we wish to run in parallel
+ -> Maybe Messager
-> HomePackageTable
-> ([ModuleName],[ModuleName])
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag,
[ModSummary])
-parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
+ when (not (null (unitIdsToCheck dflags))) $
+ throwGhcException (ProgramError "Backpack typechecking not supported with -j")
+
-- The bits of shared state we'll be using:
-- The global HscEnv is updated with the module's HMI when a module
@@ -840,7 +864,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
-- work to compile the module (see parUpsweep_one).
m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
parUpsweep_one mod home_mod_map comp_graph_loops
- lcl_dflags cleanup
+ lcl_dflags mHscMessage cleanup
par_sem hsc_env_var old_hpt_var
stable_mods mod_idx (length sccs)
@@ -939,6 +963,8 @@ parUpsweep_one
-- ^ The list of all module loops within the compilation graph.
-> DynFlags
-- ^ The thread-local DynFlags
+ -> Maybe Messager
+ -- ^ The messager
-> (HscEnv -> IO ())
-- ^ The callback for cleaning up intermediate files
-> QSem
@@ -955,7 +981,7 @@ parUpsweep_one
-- ^ The total number of modules
-> IO SuccessFlag
-- ^ The result of this compile
-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
let this_build_mod = mkBuildModule mod
@@ -1070,7 +1096,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
map (moduleName . fst) loop
-- Compile the module.
- mod_info <- upsweep_mod lcl_hsc_env'' old_hpt stable_mods
+ mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
lcl_mod mod_index num_mods
return (Just mod_info)
@@ -1122,7 +1148,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
-- There better had not be any cyclic groups here -- we check for them.
upsweep
:: GhcMonad m
- => HomePackageTable -- ^ HPT from last time round (pruned)
+ => Maybe Messager
+ -> HomePackageTable -- ^ HPT from last time round (pruned)
-> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
-> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
-> [SCC ModSummary] -- ^ Mods to do (the worklist)
@@ -1134,23 +1161,28 @@ upsweep
-- 2. The 'HscEnv' in the monad has an updated HPT
-- 3. A list of modules which succeeded loading.
-upsweep old_hpt stable_mods cleanup sccs = do
+upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
+ dflags <- getSessionDynFlags
(res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+ (unitIdsToCheck dflags) done_holes
return (res, reverse done)
where
+ done_holes = emptyUniqSet
upsweep' _old_hpt done
- [] _ _
- = return (Succeeded, done)
+ [] _ _ uids_to_check _
+ = do hsc_env <- getSession
+ liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
+ return (Succeeded, done)
upsweep' _old_hpt done
- (CyclicSCC ms:_) _ _
+ (CyclicSCC ms:_) _ _ _ _
= do dflags <- getSessionDynFlags
liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
return (Failed, done)
upsweep' old_hpt done
- (AcyclicSCC mod:mods) mod_index nmods
+ (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
@@ -1158,6 +1190,18 @@ upsweep old_hpt stable_mods cleanup sccs = do
hsc_env <- getSession
+ -- TODO: Cache this, so that we don't repeatedly re-check
+ -- our imports when you run --make.
+ let (ready_uids, uids_to_check')
+ = partition (\uid -> isEmptyUniqDSet
+ (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
+ uids_to_check
+ done_holes'
+ | ms_hsc_src mod == HsigFile
+ = addOneToUniqSet done_holes (ms_mod_name mod)
+ | otherwise = done_holes
+ liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
+
-- Remove unwanted tmp files between compilations
liftIO (cleanup hsc_env)
@@ -1178,7 +1222,7 @@ upsweep old_hpt stable_mods cleanup sccs = do
mb_mod_info
<- handleSourceError
(\err -> do logger mod (Just err); return Nothing) $ do
- mod_info <- liftIO $ upsweep_mod hsc_env2 old_hpt stable_mods
+ mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
mod mod_index nmods
logger mod Nothing -- log warnings
return (Just mod_info)
@@ -1212,7 +1256,16 @@ upsweep old_hpt stable_mods cleanup sccs = do
hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
setSession hsc_env4
- upsweep' old_hpt1 done' mods (mod_index+1) nmods
+ upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
+
+unitIdsToCheck :: DynFlags -> [UnitId]
+unitIdsToCheck dflags =
+ nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
+ where
+ goUnitId uid =
+ case splitUnitIdInsts uid of
+ (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
+ _ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate dflags location
@@ -1226,13 +1279,14 @@ maybeGetIfaceDate dflags location
-- | Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
+ -> Maybe Messager
-> HomePackageTable
-> ([ModuleName],[ModuleName])
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
-> IO HomeModInfo
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
= let
this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
@@ -1285,13 +1339,13 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it mb_linkable src_modified =
- compileOne hsc_env summary' mod_index nmods
+ compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
mb_old_iface mb_linkable src_modified
compile_it_discard_iface :: Maybe Linkable -> SourceModified
-> IO HomeModInfo
compile_it_discard_iface mb_linkable src_modified =
- compileOne hsc_env summary' mod_index nmods
+ compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
Nothing mb_linkable src_modified
-- With the HscNothing target we create empty linkables to avoid
@@ -1510,7 +1564,9 @@ topSortModuleGraph
topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
= map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
where
- (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+ -- stronglyConnCompG flips the original order, so if we reverse
+ -- the summaries we get a stable topological sort.
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
initial_graph = case mb_root_mod of
Nothing -> graph
@@ -1662,15 +1718,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
summs <- loop (concatMap calcDeps rootSummariesOk) root_map
return summs
where
- -- When we're compiling a signature file, we have an implicit
- -- dependency on what-ever the signature's implementation is.
- -- (But not when we're type checking!)
- calcDeps summ
- | HsigFile <- ms_hsc_src summ
- , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
- , moduleUnitId m == thisPackage (hsc_dflags hsc_env)
- = (noLoc (moduleName m), NotBoot) : msDeps summ
- | otherwise = msDeps summ
+ calcDeps = msDeps
dflags = hsc_dflags hsc_env
roots = hsc_targets hsc_env
@@ -1691,7 +1739,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
(L rootLoc modl) obj_allowed
maybe_buf excl_mods
case maybe_summary of
- Nothing -> return $ Left $ packageModErr dflags modl
+ Nothing -> return $ Left $ moduleNotFoundErr dflags modl
Just s -> return s
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
@@ -1865,12 +1913,17 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
hi_timestamp <- maybeGetIfaceDate dflags location
+ extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+ required_by_imports <- implicitRequirements hsc_env the_imps
+
return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
- ms_srcimps = srcimps, ms_textual_imps = the_imps,
+ ms_parsed_mod = Nothing,
+ ms_srcimps = srcimps,
+ ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
ms_hs_date = src_timestamp,
ms_iface_date = hi_timestamp,
ms_obj_date = obj_timestamp })
@@ -2003,14 +2056,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
hi_timestamp <- maybeGetIfaceDate dflags location
+ extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+ required_by_imports <- implicitRequirements hsc_env the_imps
+
return (Just (Right (ModSummary { ms_mod = mod,
ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
+ ms_parsed_mod = Nothing,
ms_srcimps = srcimps,
- ms_textual_imps = the_imps,
+ ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
ms_hs_date = src_timestamp,
ms_iface_date = hi_timestamp,
ms_obj_date = obj_timestamp })))
@@ -2070,10 +2127,10 @@ noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
noHsFileErr dflags loc path
= mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
-packageModErr :: DynFlags -> ModuleName -> ErrMsg
-packageModErr dflags mod
+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
+moduleNotFoundErr dflags mod
= mkPlainErrMsg dflags noSrcSpan $
- text "module" <+> quotes (ppr mod) <+> text "is a package module"
+ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
multiRootsErr _ [] = panic "multiRootsErr"
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 5e14e77117..cd8b56843f 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -79,6 +79,8 @@ module HscMain
, hscSimpleIface', hscNormalIface'
, oneShotMsg
, hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
+ , ioMsgMaybe
+ , showModuleIndex
) where
#ifdef GHCI
@@ -135,6 +137,7 @@ import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
+import TcEnv
import Maybes
import DynFlags
@@ -342,7 +345,9 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
-- internal version, that doesn't fail due to -Werror
hscParse' :: ModSummary -> Hsc HsParsedModule
-hscParse' mod_summary = {-# SCC "Parser" #-}
+hscParse' mod_summary
+ | Just r <- ms_parsed_mod mod_summary = return r
+ | otherwise = {-# SCC "Parser" #-}
withTiming getDynFlags
(text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(const ()) $ do
@@ -359,8 +364,11 @@ hscParse' mod_summary = {-# SCC "Parser" #-}
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
+ let parseMod | HsigFile == ms_hsc_src mod_summary
+ = parseSignature
+ | otherwise = parseModule
- case unP parseModule (mkPState dflags buf loc) of
+ case unP parseMod (mkPState dflags buf loc) of
PFailed span err ->
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
@@ -417,7 +425,7 @@ type RenamedStuff =
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
- tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
+ tc_result <- hscTypecheck True mod_summary (Just rdr_module)
-- This 'do' is in the Maybe monad!
let rn_info = do decl <- tcg_rn_decls tc_result
@@ -428,6 +436,31 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
return (tc_result, rn_info)
+hscTypecheck :: Bool -- ^ Keep renamed source?
+ -> ModSummary -> Maybe HsParsedModule
+ -> Hsc TcGblEnv
+hscTypecheck keep_rn mod_summary mb_rdr_module = do
+ hsc_env <- getHscEnv
+ let hsc_src = ms_hsc_src mod_summary
+ dflags = hsc_dflags hsc_env
+ outer_mod = ms_mod mod_summary
+ inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+ src_filename = ms_hspp_file mod_summary
+ real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+ MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+ if hsc_src == HsigFile && not (isHoleModule inner_mod)
+ then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod real_loc
+ else
+ do hpm <- case mb_rdr_module of
+ Just hpm -> return hpm
+ Nothing -> hscParse' mod_summary
+ tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm
+ if hsc_src == HsigFile
+ then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
+ ioMsgMaybe $
+ tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) iface
+ else return tc_result0
+
-- wrapper around tcRnModule to handle safe haskell extras
tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
@@ -689,11 +722,12 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
-- to retypecheck but the resulting interface is exactly
-- the same.)
Right (FrontendTypecheck tc_result, mb_old_hash) -> do
- (status, hmi, no_change) <-
- if hscTarget dflags /= HscNothing &&
- ms_hsc_src mod_summary == HsSrcFile
- then finish hsc_env mod_summary tc_result mb_old_hash
- else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
+ (status, hmi, no_change)
+ <- case ms_hsc_src mod_summary of
+ HsSrcFile | hscTarget dflags /= HscNothing ->
+ finish hsc_env mod_summary tc_result mb_old_hash
+ _ ->
+ finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary
return (status, hmi)
@@ -803,11 +837,7 @@ batchMsg hsc_env mod_index recomp mod_summary =
-- | Given a 'ModSummary', parses and typechecks it, returning the
-- 'TcGblEnv' resulting from type-checking.
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
-hscFileFrontEnd mod_summary = do
- hpm <- hscParse' mod_summary
- hsc_env <- getHscEnv
- tcg_env <- tcRnModule' hsc_env mod_summary False hpm
- return tcg_env
+hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
--------------------------------------------------------------
-- Safe Haskell
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 127775e822..c2d2938b45 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -73,6 +73,9 @@ module HscTypes (
-- * Interfaces
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceWarnCache, mi_boot, mi_fix,
+ mi_semantic_module,
+ mi_free_holes,
+ renameFreeHoles,
-- * Fixity
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
@@ -139,9 +142,9 @@ import ByteCodeTypes
import InteractiveEvalTypes ( Resume )
import GHCi.Message ( Pipe )
import GHCi.RemoteTypes
-import UniqFM
#endif
+import UniqFM
import HsSyn
import RdrName
import Avail
@@ -191,6 +194,7 @@ import Binary
import ErrUtils
import Platform
import Util
+import UniqDSet
import GHC.Serialized ( Serialized )
import Foreign
@@ -770,9 +774,13 @@ prepareAnnotations hsc_env mb_guts = do
-- Although the @FinderCache@ range is 'FindResult' for convenience,
-- in fact it will only ever contain 'Found' or 'NotFound' entries.
--
-type FinderCache = ModuleEnv FindResult
+type FinderCache = VirginModuleEnv FindResult
-- | The result of searching for an imported module.
+--
+-- NB: FindResult manages both user source-import lookups
+-- (which can result in 'Module') as well as direct imports
+-- for interfaces (which always result in 'VirginModule').
data FindResult
= Found ModLocation Module
-- ^ The module was found
@@ -936,6 +944,42 @@ mi_boot iface = mi_hsc_src iface == HsBootFile
mi_fix :: ModIface -> OccName -> Fixity
mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity
+-- | The semantic module for this interface; e.g., if it's a interface
+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'
+-- will be @<A>@.
+mi_semantic_module :: ModIface -> Module
+mi_semantic_module iface = case mi_sig_of iface of
+ Nothing -> mi_module iface
+ Just mod -> mod
+
+-- | The "precise" free holes, e.g., the signatures that this
+-- 'ModIface' depends on.
+mi_free_holes :: ModIface -> UniqDSet ModuleName
+mi_free_holes iface =
+ case splitModuleInsts (mi_module iface) of
+ (_, Just insts)
+ -- A mini-hack: we rely on the fact that 'renameFreeHoles'
+ -- drops things that aren't holes.
+ -> renameFreeHoles (mkUniqDSet cands) insts
+ _ -> emptyUniqDSet
+ where
+ cands = map fst (dep_mods (mi_deps iface))
+
+-- | Given a set of free holes, and a unit identifier, rename
+-- the free holes according to the instantiation of the unit
+-- identifier. For example, if we have A and B free, and
+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free
+-- holes are just C.
+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName
+renameFreeHoles fhs insts =
+ unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))
+ where
+ hmap = listToUFM insts
+ lookup_impl mod_name
+ | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod
+ -- It wasn't actually a hole
+ | otherwise = emptyUniqDSet
+
instance Binary ModIface where
put_ bh (ModIface {
mi_module = mod,
@@ -964,6 +1008,7 @@ instance Binary ModIface where
mi_trust = trust,
mi_trust_pkg = trust_pkg }) = do
put_ bh mod
+ put_ bh sig_of
put_ bh hsc_src
put_ bh iface_hash
put_ bh mod_hash
@@ -987,10 +1032,10 @@ instance Binary ModIface where
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
- put_ bh sig_of
get bh = do
- mod_name <- get bh
+ mod <- get bh
+ sig_of <- get bh
hsc_src <- get bh
iface_hash <- get bh
mod_hash <- get bh
@@ -1014,9 +1059,8 @@ instance Binary ModIface where
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
- sig_of <- get bh
return (ModIface {
- mi_module = mod_name,
+ mi_module = mod,
mi_sig_of = sig_of,
mi_hsc_src = hsc_src,
mi_iface_hash = iface_hash,
@@ -1997,7 +2041,10 @@ lookupType dflags hpt pte name
Just hm -> lookupNameEnv (md_types (hm_details hm)) name
Nothing -> lookupNameEnv pte name
where
- mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ mod = ASSERT2( isExternalName name, ppr name )
+ if isHoleName name
+ then mkModule (thisPackage dflags) (moduleName (nameModule name))
+ else nameModule name
-- | As 'lookupType', but with a marginally easier-to-use interface
-- if you have a 'HscEnv'
@@ -2280,6 +2327,11 @@ data Usage
-- contents don't change. This previously lead to odd
-- recompilation behaviors; see #8114
}
+ -- | A requirement which was merged into this one.
+ | UsageMergedRequirement {
+ usg_mod :: Module,
+ usg_mod_hash :: Fingerprint
+ }
deriving( Eq )
-- The export list field is (Just v) if we depend on the export list:
-- i.e. we imported the module directly, whether or not we
@@ -2314,6 +2366,11 @@ instance Binary Usage where
put_ bh (usg_file_path usg)
put_ bh (usg_file_hash usg)
+ put_ bh usg@UsageMergedRequirement{} = do
+ putByte bh 3
+ put_ bh (usg_mod usg)
+ put_ bh (usg_mod_hash usg)
+
get bh = do
h <- getByte bh
case h of
@@ -2334,6 +2391,10 @@ instance Binary Usage where
fp <- get bh
hash <- get bh
return UsageFile { usg_file_path = fp, usg_file_hash = hash }
+ 3 -> do
+ mod <- get bh
+ hash <- get bh
+ return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }
i -> error ("Binary.get(Usage): " ++ show i)
{-
@@ -2388,6 +2449,16 @@ data ExternalPackageState
--
-- * Deprecations and warnings
+ eps_free_holes :: ModuleEnv (UniqDSet ModuleName),
+ -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on
+ -- the 'eps_PIT' for this information, EXCEPT that when
+ -- we do dependency analysis, we need to look at the
+ -- 'Dependencies' of our imports to determine what their
+ -- precise free holes are ('moduleFreeHolesPrecise'). We
+ -- don't want to repeatedly reread in the interface
+ -- for every import, so cache it here. When the PIT
+ -- gets filled in we can drop these entries.
+
eps_PTE :: !PackageTypeEnv,
-- ^ Result of typechecking all the external package
-- interface files we have sucked in. The domain of
@@ -2519,6 +2590,9 @@ data ModSummary
-- ^ Source imports of the module
ms_textual_imps :: [(Maybe FastString, Located ModuleName)],
-- ^ Non-source imports of the module from the module *text*
+ ms_parsed_mod :: Maybe HsParsedModule,
+ -- ^ The parsed, nonrenamed source, if we have it. This is also
+ -- used to support "inline module syntax" in Backpack files.
ms_hspp_file :: FilePath,
-- ^ Filename of preprocessed source file
ms_hspp_opts :: DynFlags,
@@ -2577,24 +2651,12 @@ showModMsg dflags target recomp mod_summary
HscInterpreted | recomp
-> text "interpreted"
HscNothing -> text "nothing"
- _ | HsigFile == ms_hsc_src mod_summary -> text "nothing"
- | otherwise -> text (normalise $ msObjFilePath mod_summary),
+ _ -> text (normalise $ msObjFilePath mod_summary),
char ')']
where
mod = moduleName (ms_mod mod_summary)
mod_str = showPpr dflags mod
- ++ hscSourceString' dflags mod (ms_hsc_src mod_summary)
-
--- | Variant of hscSourceString which prints more information for signatures.
--- This can't live in DriverPhases because this would cause a module loop.
-hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String
-hscSourceString' _ _ HsSrcFile = ""
-hscSourceString' _ _ HsBootFile = "[boot]"
-hscSourceString' dflags mod HsigFile =
- "[" ++ (maybe "abstract sig"
- (("sig of "++).showPpr dflags)
- (getSigOf dflags mod)) ++ "]"
- -- NB: -sig-of could be missing if we're just typechecking
+ ++ hscSourceString (ms_hsc_src mod_summary)
{-
************************************************************************
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index cda8f7f12c..f16c902a7e 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards, MultiParamTypeClasses #-}
+{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}
-- |
-- Package configuration information: essentially the interface to Cabal, with
@@ -11,6 +11,7 @@ module PackageConfig (
-- * UnitId
packageConfigId,
+ expandedPackageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
@@ -40,9 +41,11 @@ import Unique
-- which is similar to a subset of the InstalledPackageInfo type from Cabal.
type PackageConfig = InstalledPackageInfo
+ ComponentId
SourcePackageId
PackageName
Module.UnitId
+ Module.UnitId
Module.ModuleName
Module.Module
@@ -50,14 +53,9 @@ type PackageConfig = InstalledPackageInfo
-- feature, but ghc doesn't currently have convenient support for any
-- other compact string types, e.g. plain ByteString or Text.
-newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord)
newtype PackageName = PackageName FastString deriving (Eq, Ord)
-instance BinaryStringRep ComponentId where
- fromStringRep = ComponentId . mkFastStringByteString
- toStringRep (ComponentId s) = fastStringToByteString s
-
instance BinaryStringRep SourcePackageId where
fromStringRep = SourcePackageId . mkFastStringByteString
toStringRep (SourcePackageId s) = fastStringToByteString s
@@ -66,18 +64,12 @@ instance BinaryStringRep PackageName where
fromStringRep = PackageName . mkFastStringByteString
toStringRep (PackageName s) = fastStringToByteString s
-instance Uniquable ComponentId where
- getUnique (ComponentId n) = getUnique n
-
instance Uniquable SourcePackageId where
getUnique (SourcePackageId n) = getUnique n
instance Uniquable PackageName where
getUnique (PackageName n) = getUnique n
-instance Outputable ComponentId where
- ppr (ComponentId str) = ftext str
-
instance Outputable SourcePackageId where
ppr (SourcePackageId str) = ftext str
@@ -125,7 +117,6 @@ pprPackageConfig InstalledPackageInfo {..} =
where
field name body = text name <> colon <+> nest 4 body
-
-- -----------------------------------------------------------------------------
-- UnitId (package names, versions and dep hash)
@@ -140,3 +131,9 @@ pprPackageConfig InstalledPackageInfo {..} =
-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
packageConfigId :: PackageConfig -> UnitId
packageConfigId = unitId
+
+expandedPackageConfigId :: PackageConfig -> UnitId
+expandedPackageConfigId p =
+ case instantiatedWith p of
+ [] -> packageConfigId p
+ _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p)
diff --git a/compiler/main/PackageConfig.hs-boot b/compiler/main/PackageConfig.hs-boot
new file mode 100644
index 0000000000..c65bf472a4
--- /dev/null
+++ b/compiler/main/PackageConfig.hs-boot
@@ -0,0 +1,7 @@
+module PackageConfig where
+import FastString
+import {-# SOURCE #-} Module
+import GHC.PackageDb
+newtype PackageName = PackageName FastString
+newtype SourcePackageId = SourcePackageId FastString
+type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 0c91af284d..3003e015b6 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -1,13 +1,14 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
-- | Package manipulation
module Packages (
module PackageConfig,
-- * Reading the package config, and processing cmdline args
- PackageState(preloadPackages, explicitPackages),
+ PackageState(preloadPackages, explicitPackages, requirementContext),
+ PackageConfigMap,
emptyPackageState,
initPackages,
readPackageConfigs,
@@ -18,8 +19,13 @@ module Packages (
-- * Querying the package config
lookupPackage,
+ lookupPackage',
+ lookupPackageName,
+ lookupComponentId,
+ improveUnitId,
searchPackageId,
getPackageDetails,
+ componentIdString,
listVisibleModuleNames,
lookupModuleInAllPackages,
lookupModuleWithSuggestions,
@@ -35,13 +41,14 @@ module Packages (
getPackageExtraCcOpts,
getPackageFrameworkPath,
getPackageFrameworks,
+ getPackageConfigMap,
getPreloadPackagesAnd,
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs,
-- * Utils
- unitIdPackageIdString,
+ unwireUnitId,
pprFlag,
pprPackages,
pprPackagesSimple,
@@ -66,9 +73,8 @@ import Maybes
import System.Environment ( getEnv )
import FastString
-import ErrUtils ( debugTraceMsg, MsgDoc )
+import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser )
import Exception
-import Unique
import System.Directory
import System.FilePath as FilePath
@@ -78,6 +84,8 @@ import Data.Char ( toUpper )
import Data.List as List
import Data.Map (Map)
import Data.Set (Set)
+import Data.Maybe (mapMaybe)
+import Data.Monoid (First(..))
#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
@@ -234,14 +242,57 @@ originEmpty _ = False
type UnitIdMap = UniqDFM
-- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
-type PackageConfigMap = UnitIdMap PackageConfig
+-- (newtyped so we can put it in boot.)
+newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig }
+
+-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
+type VisibilityMap = Map UnitId UnitVisibility
+
+-- | 'UnitVisibility' records the various aspects of visibility of a particular
+-- 'UnitId'.
+data UnitVisibility = UnitVisibility
+ { uv_expose_all :: Bool
+ -- ^ Should all modules in exposed-modules should be dumped into scope?
+ , uv_renamings :: [(ModuleName, ModuleName)]
+ -- ^ Any custom renamings that should bring extra 'ModuleName's into
+ -- scope.
+ , uv_package_name :: First FastString
+ -- ^ The package name is associated with the 'UnitId'. This is used
+ -- to implement legacy behavior where @-package foo-0.1@ implicitly
+ -- hides any packages named @foo@
+ , uv_requirements :: Map ModuleName (Set HoleModule)
+ -- ^ The signatures which are contributed to the requirements context
+ -- from this unit ID.
+ , uv_explicit :: Bool
+ -- ^ Whether or not this unit was explicitly brought into scope,
+ -- as opposed to implicitly via the 'exposed' fields in the
+ -- package database (when @-hide-all-packages@ is not passed.)
+ }
--- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which
--- are exposed should be dumped into scope, (2) any custom renamings that
--- should also be apply, and (3) what package name is associated with the
--- key, if it might be hidden
-type VisibilityMap =
- UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString)
+instance Outputable UnitVisibility where
+ ppr (UnitVisibility {
+ uv_expose_all = b,
+ uv_renamings = rns,
+ uv_package_name = First mb_pn,
+ uv_requirements = reqs,
+ uv_explicit = explicit
+ }) = ppr (b, rns, mb_pn, reqs, explicit)
+instance Monoid UnitVisibility where
+ mempty = UnitVisibility
+ { uv_expose_all = False
+ , uv_renamings = []
+ , uv_package_name = First Nothing
+ , uv_requirements = Map.empty
+ , uv_explicit = False
+ }
+ mappend uv1 uv2
+ = UnitVisibility
+ { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
+ , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
+ , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
+ , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
+ , uv_explicit = uv_explicit uv1 || uv_explicit uv2
+ }
-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
@@ -257,6 +308,14 @@ data PackageState = PackageState {
-- may have the 'exposed' flag be 'False'.)
pkgIdMap :: PackageConfigMap,
+ -- | A mapping of 'PackageName' to 'ComponentId'. This is used when
+ -- users refer to packages in Backpack includes.
+ packageNameMap :: Map PackageName ComponentId,
+
+ -- | A mapping from wired in names to the original names from the
+ -- package database.
+ unwireMap :: Map UnitId UnitId,
+
-- | The packages we're going to link in eagerly. This list
-- should be in reverse dependency order; that is, a package
-- is always mentioned before the packages it depends on.
@@ -272,30 +331,65 @@ data PackageState = PackageState {
moduleToPkgConfAll :: !ModuleToPkgConfAll,
-- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
- pluginModuleToPkgConfAll :: !ModuleToPkgConfAll
+ pluginModuleToPkgConfAll :: !ModuleToPkgConfAll,
+
+ -- | A map saying, for each requirement, what interfaces must be merged
+ -- together when we use them. For example, if our dependencies
+ -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
+ -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
+ -- and @r[C=<A>]:C@.
+ --
+ -- There's an entry in this map for each hole in our home library.
+ requirementContext :: Map ModuleName [HoleModule]
}
emptyPackageState :: PackageState
emptyPackageState = PackageState {
pkgIdMap = emptyPackageConfigMap,
+ packageNameMap = Map.empty,
+ unwireMap = Map.empty,
preloadPackages = [],
explicitPackages = [],
moduleToPkgConfAll = Map.empty,
- pluginModuleToPkgConfAll = Map.empty
+ pluginModuleToPkgConfAll = Map.empty,
+ requirementContext = Map.empty
}
type InstalledPackageIndex = Map UnitId PackageConfig
-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
-emptyPackageConfigMap = emptyUDFM
+emptyPackageConfigMap = PackageConfigMap emptyUDFM
--- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
+-- | Find the package we know about with the given unit id, if any
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
-lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
+lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))
+
+-- | A more specialized interface, which takes a boolean specifying
+-- whether or not to look for on-the-fly renamed interfaces, and
+-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
+-- be used while we're initializing 'DynFlags'
+lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
+lookupPackage' False (PackageConfigMap pkg_map) uid = lookupUDFM pkg_map uid
+lookupPackage' True (PackageConfigMap pkg_map) uid =
+ case splitUnitIdInsts uid of
+ (iuid, Just insts) ->
+ fmap (renamePackage (PackageConfigMap pkg_map) insts)
+ (lookupUDFM pkg_map iuid)
+ (_, Nothing) -> lookupUDFM pkg_map uid
+
+-- | Find the indefinite package for a given 'ComponentId'.
+-- The way this works is just by fiat'ing that every indefinite package's
+-- unit key is precisely its component ID; and that they share uniques.
+lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
+lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
+ where
+ PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
-lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
-lookupPackage' = lookupUDFM
+-- | Find the package we know about with the given package name (e.g. @foo@), if any
+-- (NB: there might be a locally defined unit name which overrides this)
+lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
+lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
@@ -305,9 +399,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
-extendPackageConfigMap pkg_map new_pkgs
- = foldl add pkg_map new_pkgs
- where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p
+extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs
+ = PackageConfigMap (foldl add pkg_map new_pkgs)
+ -- We also add the expanded version of the packageConfigId, so that
+ -- 'improveUnitId' can find it.
+ where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
+ (packageConfigId p) p
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
@@ -320,7 +417,9 @@ getPackageDetails dflags pid =
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
listPackageConfigMap :: DynFlags -> [PackageConfig]
-listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags))
+listPackageConfigMap dflags = eltsUDFM pkg_map
+ where
+ PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state
@@ -346,11 +445,10 @@ initPackages dflags0 = do
Nothing -> readPackageConfigs dflags
Just db -> return $ map (\(p, pkgs)
-> (p, setBatchPackageFlags dflags pkgs)) db
- (pkg_state, preload, this_pkg)
+ (pkg_state, preload)
<- mkPackageState dflags pkg_db []
return (dflags{ pkgDatabase = Just pkg_db,
- pkgState = pkg_state,
- thisPackage = this_pkg },
+ pkgState = pkg_state },
preload)
-- -----------------------------------------------------------------------------
@@ -522,19 +620,25 @@ applyTrustFlag dflags unusable pkgs flag =
-- we trust all matching packages. Maybe should only trust first one?
-- and leave others the same or set them untrusted
TrustPackage str ->
- case selectPackages (matchingStr str) pkgs unusable of
+ case selectPackages (PackageArg str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map trust ps ++ qs)
where trust p = p {trusted=True}
DistrustPackage str ->
- case selectPackages (matchingStr str) pkgs unusable of
+ case selectPackages (PackageArg str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map distrust ps ++ qs)
where distrust p = p {trusted=False}
+-- | A little utility to tell if the 'thisPackage' is indefinite
+-- (if it is not, we should never use on-the-fly renaming.)
+isIndefinite :: DynFlags -> Bool
+isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))
+
applyPackageFlag
:: DynFlags
+ -> PackageConfigMap
-> UnusablePackages
-> Bool -- if False, if you expose a package, it implicitly hides
-- any previously exposed packages with the same name
@@ -543,16 +647,46 @@ applyPackageFlag
-> PackageFlag -- flag to apply
-> IO VisibilityMap -- Now exposed
-applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
+applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
case flag of
ExposePackage _ arg (ModRenaming b rns) ->
- case selectPackages (matching arg) pkgs unusable of
+ case findPackages pkg_db arg pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
- Right (p:_,_) -> return vm'
+ Right (p:_) -> return vm'
where
n = fsPackageName p
- vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
- edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
+
+ -- If a user says @-unit-id p[A=<A>]@, this imposes
+ -- a requirement on us: whatever our signature A is,
+ -- it must fulfill all of p[A=<A>]:A's requirements.
+ -- This method is responsible for computing what our
+ -- inherited requirements are.
+ reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
+ | otherwise = Map.empty
+
+ collectHoles uid = case splitUnitIdInsts uid of
+ (_, Just insts) ->
+ let cid = unitIdComponentId uid
+ local = [ Map.singleton
+ (moduleName mod)
+ (Set.singleton $ (newIndefUnitId cid insts, mod_name))
+ | (mod_name, mod) <- insts
+ , isHoleModule mod ]
+ recurse = [ collectHoles (moduleUnitId mod)
+ | (_, mod) <- insts ]
+ in Map.unionsWith Set.union $ local ++ recurse
+ -- Other types of unit identities don't have holes
+ (_, Nothing) -> Map.empty
+
+
+ uv = UnitVisibility
+ { uv_expose_all = b
+ , uv_renamings = rns
+ , uv_package_name = First (Just n)
+ , uv_requirements = reqs
+ , uv_explicit = True
+ }
+ vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
-- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
-- (or if p-0.1 was registered in the pkgdb as exposed: True),
-- the second package flag would override the first one and you
@@ -574,29 +708,74 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
-- -hide-all-packages/-hide-all-plugin-packages depending on what
-- flag is in question.
vm_cleared | no_hide_others = vm
- | otherwise = filterUDFM_Directly
- (\k (_,_,n') -> k == getUnique (packageConfigId p)
- || n /= n') vm
+ -- NB: renamings never clear
+ | (_:_) <- rns = vm
+ | otherwise = Map.filterWithKey
+ (\k uv -> k == packageConfigId p
+ || First (Just n) /= uv_package_name uv) vm
_ -> panic "applyPackageFlag"
HidePackage str ->
- case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr dflags flag ps
- Right (ps,_) -> return vm'
- where vm' = delListFromUDFM vm (map packageConfigId ps)
-
-selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
+ case findPackages pkg_db (PackageArg str) pkgs unusable of
+ Left ps -> packageFlagErr dflags flag ps
+ Right ps -> return vm'
+ where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)
+
+-- | Like 'selectPackages', but doesn't return a list of unmatched
+-- packages. Furthermore, any packages it returns are *renamed*
+-- if the 'UnitArg' has a renaming associated with it.
+findPackages :: PackageConfigMap -> PackageArg -> [PackageConfig]
+ -> UnusablePackages
+ -> Either [(PackageConfig, UnusablePackageReason)]
+ [PackageConfig]
+findPackages pkg_db arg pkgs unusable
+ = let ps = mapMaybe (finder arg) pkgs
+ in if null ps
+ then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
+ (Map.elems unusable))
+ else Right (sortByVersion (reverse ps))
+ where
+ finder (PackageArg str) p
+ = if str == sourcePackageIdString p || str == packageNameString p
+ then Just p
+ else Nothing
+ finder (UnitIdArg uid) p
+ = let (iuid, mb_insts) = splitUnitIdInsts uid
+ in if iuid == packageConfigId p
+ then Just (case mb_insts of
+ Nothing -> p
+ Just insts -> renamePackage pkg_db insts p)
+ else Nothing
+
+selectPackages :: PackageArg -> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)]
([PackageConfig], [PackageConfig])
-selectPackages matches pkgs unusable
- = let (ps,rest) = partition matches pkgs
+selectPackages arg pkgs unusable
+ = let matches = matching arg
+ (ps,rest) = partition matches pkgs
in if null ps
then Left (filter (matches.fst) (Map.elems unusable))
-- NB: packages from later package databases are LATER
-- in the list. We want to prefer the latest package.
else Right (sortByVersion (reverse ps), rest)
+-- | Rename a 'PackageConfig' according to some module instantiation.
+renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
+ -> PackageConfig -> PackageConfig
+renamePackage pkg_map insts conf =
+ let hsubst = listToUFM insts
+ smod = renameHoleModule' pkg_map hsubst
+ suid = renameHoleUnitId' pkg_map hsubst
+ new_uid = suid (unitId conf)
+ in conf {
+ unitId = new_uid,
+ depends = map suid (depends conf),
+ exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
+ (exposedModules conf)
+ }
+
+
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matchingStr :: String -> PackageConfig -> Bool
@@ -604,12 +783,12 @@ matchingStr str p
= str == sourcePackageIdString p
|| str == packageNameString p
-matchingId :: String -> PackageConfig -> Bool
-matchingId str p = str == unitIdString (packageConfigId p)
+matchingId :: UnitId -> PackageConfig -> Bool
+matchingId uid p = uid == packageConfigId p
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
-matching (UnitIdArg str) = matchingId str
+matching (UnitIdArg uid) = matchingId uid
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
@@ -712,7 +891,7 @@ findWiredInPackages dflags pkgs vis_map = do
let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
all_exposed_ps =
[ p | p <- all_ps
- , elemUDFM (packageConfigId p) vis_map ] in
+ , Map.member (packageConfigId p) vis_map ] in
case all_exposed_ps of
[] -> case all_ps of
[] -> notfound
@@ -766,7 +945,8 @@ findWiredInPackages dflags pkgs vis_map = do
where upd_pkg pkg
| unitId pkg `elem` wired_in_ids
= pkg {
- unitId = stringToUnitId (packageNameString pkg)
+ unitId = let PackageName fs = packageName pkg
+ in fsToUnitId fs
}
| otherwise
= pkg
@@ -786,9 +966,9 @@ findWiredInPackages dflags pkgs vis_map = do
updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
- where f vm (from, to) = case lookupUDFM vis_map from of
+ where f vm (from, to) = case Map.lookup from vis_map of
Nothing -> vm
- Just r -> addToUDFM vm to r
+ Just r -> Map.insert to r (Map.delete from vm)
-- ----------------------------------------------------------------------------
@@ -797,6 +977,10 @@ type IsShadowed = Bool
data UnusablePackageReason
= IgnoredWithFlag
| MissingDependencies IsShadowed [UnitId]
+instance Outputable UnusablePackageReason where
+ ppr IgnoredWithFlag = text "[ignored with flag]"
+ ppr (MissingDependencies b uids) =
+ brackets (if b then text "shadowed" else empty <+> ppr uids)
type UnusablePackages = Map UnitId
(PackageConfig, UnusablePackageReason)
@@ -876,9 +1060,7 @@ mkPackageState
-> [(FilePath, [PackageConfig])] -- initial databases
-> [UnitId] -- preloaded packages
-> IO (PackageState,
- [UnitId], -- new packages to preload
- UnitId) -- this package, might be modified if the current
- -- package is a wired-in package.
+ [UnitId]) -- new packages to preload
mkPackageState dflags dbs preload0 = do
-- Compute the unit id
@@ -938,6 +1120,8 @@ mkPackageState dflags dbs preload0 = do
let other_flags = reverse (packageFlags dflags)
ignore_flags = reverse (ignorePackageFlags dflags)
+ debugTraceMsg dflags 2 $
+ text "package flags" <+> ppr other_flags
let merge (pkg_map, prev_unusable) (db_path, db) = do
debugTraceMsg dflags 2 $
@@ -1004,6 +1188,7 @@ mkPackageState dflags dbs preload0 = do
-- or not packages are visible or not)
pkgs1 <- foldM (applyTrustFlag dflags unusable)
(Map.elems pkg_map1) (reverse (trustFlags dflags))
+ let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1
--
-- Calculate the initial set of packages, prior to any package flags.
@@ -1019,18 +1204,28 @@ mkPackageState dflags dbs preload0 = do
then emptyUDFM
else foldl' calcInitial emptyUDFM pkgs1
vis_map1 = foldUDFM (\p vm ->
- if exposed p
- then addToUDFM vm (packageConfigId p)
- (True, [], fsPackageName p)
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if exposed p && unitIdIsDefinite (packageConfigId p)
+ then Map.insert (packageConfigId p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = Map.empty,
+ uv_explicit = False
+ }
+ vm
else vm)
- emptyUDFM initial
+ Map.empty initial
--
-- Compute a visibility map according to the command-line flags (-package,
-- -hide-package). This needs to know about the unusable packages, since if a
-- user tries to enable an unusable package, we should let them know.
--
- vis_map2 <- foldM (applyPackageFlag dflags unusable
+ vis_map2 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
(gopt Opt_HideAllPackages dflags) pkgs1)
vis_map1 other_flags
@@ -1040,6 +1235,7 @@ mkPackageState dflags dbs preload0 = do
-- package arguments we need to key against the old versions.
--
(pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
+ let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
-- Update the visibility map, so we treat wired packages as visible.
let vis_map = updateVisibilityMap wired_map vis_map2
@@ -1049,15 +1245,15 @@ mkPackageState dflags dbs preload0 = do
case pluginPackageFlags dflags of
-- common case; try to share the old vis_map
[] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUDFM
+ | otherwise -> return Map.empty
_ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUDFM
+ | hide_plugin_pkgs = Map.empty
-- Use the vis_map PRIOR to wired in,
-- because otherwise applyPackageFlag
-- won't work.
| otherwise = vis_map2
plugin_vis_map2
- <- foldM (applyPackageFlag dflags unusable
+ <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
(gopt Opt_HideAllPluginPackages dflags) pkgs1)
plugin_vis_map1
(reverse (pluginPackageFlags dflags))
@@ -1078,16 +1274,24 @@ mkPackageState dflags dbs preload0 = do
-- should contain at least rts & base, which is why we pretend that
-- the command line contains -package rts & -package base.
--
- let preload1 = [ let key = unitId p
- in fromMaybe key (Map.lookup key wired_map)
- | f <- other_flags, p <- get_exposed f ]
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = Map.keys (Map.filter uv_explicit vis_map)
- get_exposed (ExposePackage _ a _) = take 1 . sortByVersion
- . filter (matching a)
- $ pkgs1
- get_exposed _ = []
+ let pkgname_map = foldl add Map.empty pkgs2
+ where add pn_map p
+ = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map
+
+ -- The explicitPackages accurately reflects the set of packages we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = Map.keys vis_map
+ req_ctx = Map.map (Set.toList)
+ $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
- let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
let preload2 = preload1
@@ -1095,7 +1299,7 @@ mkPackageState dflags dbs preload0 = do
-- add base & rts to the preload packages
basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags
- = filter (flip elemUDFM pkg_db)
+ = filter (flip elemUDFM (unPackageConfigMap pkg_db))
[baseUnitId, rtsUnitId]
| otherwise = []
-- but in any case remove the current package from the set of
@@ -1108,42 +1312,58 @@ mkPackageState dflags dbs preload0 = do
dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
+ let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
+ when (dopt Opt_D_dump_mod_map dflags) $
+ printInfoForUser (dflags { pprCols = 200 })
+ alwaysQualify (pprModuleMap mod_map)
+
-- Force pstate to avoid leaking the dflags0 passed to mkPackageState
let !pstate = PackageState{
preloadPackages = dep_preload,
- explicitPackages = foldUDFM (\pkg xs ->
- if elemUDFM (packageConfigId pkg) vis_map
- then packageConfigId pkg : xs
- else xs) [] pkg_db,
+ explicitPackages = explicit_pkgs,
pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map,
- pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map
+ moduleToPkgConfAll = mod_map,
+ pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map,
+ packageNameMap = pkgname_map,
+ unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],
+ requirementContext = req_ctx
}
- return (pstate, new_dep_preload, this_package)
+ return (pstate, new_dep_preload)
+-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
+-- that it was recorded as in the package database.
+unwireUnitId :: DynFlags -> UnitId -> UnitId
+unwireUnitId dflags uid =
+ fromMaybe uid (Map.lookup uid (unwireMap (pkgState dflags)))
-- -----------------------------------------------------------------------------
-- | Makes the mapping from module to package info
+-- Slight irritation: we proceed by leafing through everything
+-- in the installed package database, which makes handling indefinite
+-- packages a bit bothersome.
+
mkModuleToPkgConfAll
:: DynFlags
-> PackageConfigMap
-> VisibilityMap
-> ModuleToPkgConfAll
mkModuleToPkgConfAll dflags pkg_db vis_map =
- foldl' extend_modmap emptyMap (eltsUDFM pkg_db)
+ Map.foldlWithKey extend_modmap emptyMap vis_map
where
emptyMap = Map.empty
sing pk m _ = Map.singleton (mkModule pk m)
addListTo = foldl' merge
merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
setOrigins m os = fmap (const os) m
- extend_modmap modmap pkg = addListTo modmap theBindings
+ extend_modmap modmap uid
+ UnitVisibility { uv_expose_all = b, uv_renamings = rns }
+ = addListTo modmap theBindings
where
+ pkg = pkg_lookup uid
+
theBindings :: [(ModuleName, Map Module ModuleOrigin)]
- theBindings | Just (b,rns,_) <- lookupUDFM vis_map (packageConfigId pkg)
- = newBindings b rns
- | otherwise = newBindings False []
+ theBindings = newBindings b rns
newBindings :: Bool
-> [(ModuleName, ModuleName)]
@@ -1177,7 +1397,8 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
pk = packageConfigId pkg
- pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
+ pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
+ `orElse` pprPanic "pkg_lookup" (ppr uid)
exposed_mods = exposedModules pkg
hidden_mods = hiddenModules pkg
@@ -1349,7 +1570,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
| originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
| otherwise -> (x:hidden_pkg, hidden_mod, exposed)
- pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
+ pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
mod_pkg = pkg_lookup . moduleUnitId
-- Filters out origins which are not associated with the given package
@@ -1403,7 +1624,7 @@ getPreloadPackagesAnd dflags pkgids =
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
- all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
+ all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
return (map (getPackageDetails dflags) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
@@ -1413,7 +1634,7 @@ closeDeps :: DynFlags
-> [(UnitId, Maybe UnitId)]
-> IO [UnitId]
closeDeps dflags pkg_map ps
- = throwErr dflags (closeDepsErr pkg_map ps)
+ = throwErr dflags (closeDepsErr dflags pkg_map ps)
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
@@ -1421,20 +1642,22 @@ throwErr dflags m
Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
Succeeded r -> return r
-closeDepsErr :: PackageConfigMap
+closeDepsErr :: DynFlags
+ -> PackageConfigMap
-> [(UnitId,Maybe UnitId)]
-> MaybeErr MsgDoc [UnitId]
-closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
+closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps
-- internal helper
-add_package :: PackageConfigMap
+add_package :: DynFlags
+ -> PackageConfigMap
-> [UnitId]
-> (UnitId,Maybe UnitId)
-> MaybeErr MsgDoc [UnitId]
-add_package pkg_db ps (p, mb_parent)
+add_package dflags pkg_db ps (p, mb_parent)
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
- case lookupPackage' pkg_db p of
+ case lookupPackage' (isIndefinite dflags) pkg_db p of
Nothing -> Failed (missingPackageMsg p <>
missingDependencyMsg mb_parent)
Just pkg -> do
@@ -1443,7 +1666,7 @@ add_package pkg_db ps (p, mb_parent)
return (p : ps')
where
add_unit_key ps key
- = add_package pkg_db ps (key, Just p)
+ = add_package dflags pkg_db ps (key, Just p)
missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = text "unknown package:" <+> ppr p
@@ -1455,10 +1678,9 @@ missingDependencyMsg (Just parent)
-- -----------------------------------------------------------------------------
-unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
-unitIdPackageIdString dflags pkg_key
- | pkg_key == mainUnitId = Just "main"
- | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
+componentIdString :: DynFlags -> ComponentId -> Maybe String
+componentIdString dflags cid =
+ fmap sourcePackageIdString (lookupComponentId dflags cid)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
@@ -1516,14 +1738,29 @@ pprPackagesSimple = pprPackagesWith pprIPI
in e <> t <> text " " <> ftext i
-- | Show the mapping of modules to where they come from.
-pprModuleMap :: DynFlags -> SDoc
-pprModuleMap dflags =
- vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
+pprModuleMap :: ModuleToPkgConfAll -> SDoc
+pprModuleMap mod_map =
+ vcat (map pprLine (Map.toList mod_map))
where
pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
+ pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry m (m',o)
| m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
| otherwise = ppr m' <+> parens (ppr o)
fsPackageName :: PackageConfig -> FastString
fsPackageName = mkFastString . packageNameString
+
+-- | Given a fully instantiated 'UnitId', improve it into a
+-- 'HashedUnitId' if we can find it in the package database.
+improveUnitId :: PackageConfigMap -> UnitId -> UnitId
+improveUnitId pkg_map uid =
+ -- Do NOT lookup indefinite ones, they won't be useful!
+ case lookupPackage' False pkg_map uid of
+ Nothing -> uid
+ Just pkg -> packageConfigId pkg -- use the hashed version!
+
+-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
+-- in the @hs-boot@ loop-breaker.
+getPackageConfigMap :: DynFlags -> PackageConfigMap
+getPackageConfigMap = pkgIdMap . pkgState
diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot
index 1197fadb57..c05d392ce1 100644
--- a/compiler/main/Packages.hs-boot
+++ b/compiler/main/Packages.hs-boot
@@ -1,7 +1,9 @@
module Packages where
--- Well, this is kind of stupid...
-import {-# SOURCE #-} Module (UnitId)
-import {-# SOURCE #-} DynFlags (DynFlags)
+import {-# SOURCE #-} DynFlags(DynFlags)
+import {-# SOURCE #-} Module(ComponentId, UnitId)
data PackageState
-unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
+data PackageConfigMap
emptyPackageState :: PackageState
+componentIdString :: DynFlags -> ComponentId -> Maybe String
+improveUnitId :: PackageConfigMap -> UnitId -> UnitId
+getPackageConfigMap :: DynFlags -> PackageConfigMap
View Lorry Controller Status