summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEdward Z. Yang <ezyang@cs.stanford.edu>2016-10-06 00:17:15 -0700
committerEdward Z. Yang <ezyang@cs.stanford.edu>2016-10-08 01:37:33 -0700
commit4e8a0607140b23561248a41aeaf837224aa6315b (patch)
tree8e03945afe5c40c13b41667e0175f14db15d0780
parent00b530d5402aaa37e4085ecdcae0ae54454736c1 (diff)
downloadhaskell-4e8a0607140b23561248a41aeaf837224aa6315b.tar.gz
Distinguish between UnitId and InstalledUnitId.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
-rw-r--r--compiler/backpack/DriverBkp.hs13
-rw-r--r--compiler/basicTypes/Module.hs376
-rw-r--r--compiler/deSugar/Desugar.hs4
-rw-r--r--compiler/ghci/Linker.hs27
-rw-r--r--compiler/iface/LoadIface.hs40
-rw-r--r--compiler/iface/MkIface.hs8
-rw-r--r--compiler/iface/TcIface.hs2
-rw-r--r--compiler/main/CodeOutput.hs6
-rw-r--r--compiler/main/DriverPipeline.hs24
-rw-r--r--compiler/main/Finder.hs203
-rw-r--r--compiler/main/GHC.hs6
-rw-r--r--compiler/main/GhcMake.hs3
-rw-r--r--compiler/main/HscMain.hs22
-rw-r--r--compiler/main/HscTypes.hs27
-rw-r--r--compiler/main/PackageConfig.hs23
-rw-r--r--compiler/main/Packages.hs186
-rw-r--r--compiler/main/SysTools.hs4
-rw-r--r--compiler/rename/RnNames.hs7
-rw-r--r--compiler/typecheck/TcBackpack.hs13
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs4
-rw-r--r--ghc/GHCi/UI.hs5
-rw-r--r--ghc/Main.hs4
-rw-r--r--libraries/ghc-boot/GHC/PackageDb.hs14
-rw-r--r--testsuite/tests/backpack/cabal/bkpcabal01/.gitignore2
-rw-r--r--testsuite/tests/cabal/cabal05/cabal05.stderr2
-rw-r--r--testsuite/tests/cabal/ghcpkg01.stdout6
-rw-r--r--testsuite/tests/cabal/ghcpkg04.stderr4
-rw-r--r--testsuite/tests/driver/driver063.stderr2
-rw-r--r--testsuite/tests/ghc-e/should_run/T2636.stderr2
-rw-r--r--testsuite/tests/module/mod1.stderr4
-rw-r--r--testsuite/tests/module/mod2.stderr4
-rw-r--r--testsuite/tests/package/package01e.stderr4
-rw-r--r--testsuite/tests/package/package06e.stderr12
-rw-r--r--testsuite/tests/package/package07e.stderr8
-rw-r--r--testsuite/tests/package/package08e.stderr8
-rw-r--r--testsuite/tests/package/package09e.stderr4
-rw-r--r--testsuite/tests/perf/compiler/parsing001.stderr4
-rw-r--r--testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr6
-rw-r--r--testsuite/tests/th/T10279.stderr12
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail082.stderr12
-rw-r--r--utils/ghc-pkg/Main.hs13
42 files changed, 700 insertions, 432 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 25d2d9252a..53a7e85812 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -161,7 +161,7 @@ withBkpSession cid insts deps session_type do_this = do
TcSession -> newUnitId cid insts
-- No hash passed if no instances
_ | null insts -> newSimpleUnitId cid
- | otherwise -> newHashedUnitId cid (Just (hashUnitId cid insts)),
+ | otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
-- Setup all of the output directories according to our hierarchy
objectDir = Just (outdir objectDir),
hiDir = Just (outdir hiDir),
@@ -207,7 +207,7 @@ compileUnit cid insts = do
lunit <- getSource cid
buildUnit CompSession cid insts lunit
--- Invariant: this NEVER returns HashedUnitId
+-- Invariant: this NEVER returns InstalledUnitId
hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps unit = concatMap get_dep (hsunitBody unit)
where
@@ -281,7 +281,7 @@ buildUnit session cid insts lunit = do
sourcePackageId = SourcePackageId compat_fs,
packageName = compat_pn,
packageVersion = makeVersion [0],
- unitId = thisPackage dflags,
+ unitId = toInstalledUnitId (thisPackage dflags),
instantiatedWith = insts,
-- Slight inefficiency here haha
exposedModules = map (\(m,n) -> (m,Just n)) mods,
@@ -293,7 +293,7 @@ buildUnit session cid insts lunit = do
-- really used for anything, so we leave it
-- blank for now.
TcSession -> []
- _ -> map (unwireUnitId dflags)
+ _ -> map (toInstalledUnitId . unwireUnitId dflags)
$ deps ++ [ moduleUnitId mod
| (_, mod) <- insts
, not (isHoleModule mod) ],
@@ -302,6 +302,9 @@ buildUnit session cid insts lunit = do
_ -> obj_files,
importDirs = [ hi_dir ],
exposed = False,
+ indefinite = case session of
+ TcSession -> True
+ _ -> False,
-- nope
hsLibraries = [],
extraLibraries = [],
@@ -353,7 +356,7 @@ addPackage pkg = do
-- liftIO $ setUnsafeGlobalDynFlags dflags
return ()
--- Precondition: UnitId is NOT HashedUnitId
+-- Precondition: UnitId is NOT InstalledUnitId
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
compileInclude n (i, uid) = do
hsc_env <- getSession
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 7057db019f..fd12c2bb2f 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -11,6 +11,7 @@ the keys.
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Module
(
@@ -34,7 +35,8 @@ module Module
unitIdKey,
unitIdComponentId,
IndefUnitId(..),
- HashedUnitId(..),
+ InstalledUnitId(..),
+ toInstalledUnitId,
ShHoleSubst,
unitIdIsDefinite,
@@ -44,7 +46,7 @@ module Module
newUnitId,
newIndefUnitId,
newSimpleUnitId,
- newHashedUnitId,
+ newDefiniteUnitId,
hashUnitId,
fsToUnitId,
stringToUnitId,
@@ -93,10 +95,21 @@ module Module
HasModule(..),
ContainsModule(..),
- -- * Virgin modules
- VirginModule,
- VirginUnitId,
- VirginModuleEnv,
+ -- * Installed unit ids and modules
+ InstalledModule(..),
+ InstalledModuleEnv,
+ installedModuleEq,
+ installedUnitIdEq,
+ installedUnitIdString,
+ newInstalledUnitId,
+ fsToInstalledUnitId,
+ stringToInstalledUnitId,
+ emptyInstalledModuleEnv,
+ lookupInstalledModuleEnv,
+ extendInstalledModuleEnv,
+ filterInstalledModuleEnv,
+ delInstalledModuleEnv,
+ DefUnitId(..),
-- * Hole module
HoleModule,
@@ -180,10 +193,9 @@ import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigM
-- 'ComponentId's.
-- - Same as Distribution.Package.ComponentId
--
--- UnitId: A ComponentId + a mapping from hole names (ModuleName) to
--- Modules. This is how the compiler identifies instantatiated
--- components, and also is the main identifier by which GHC identifies
--- things.
+-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names
+-- (ModuleName) to Modules. This is how the compiler identifies instantatiated
+-- components, and also is the main identifier by which GHC identifies things.
-- - When Backpack is not being used, UnitId = ComponentId.
-- this means a useful fiction for end-users is that there are
-- only ever ComponentIds, and some ComponentIds happen to have
@@ -193,9 +205,13 @@ import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigM
-- - The same as PackageKey in GHC 7.10 (we renamed it because
-- they don't necessarily identify packages anymore.)
-- - Same as -this-package-key/-package-name flags
+-- - An InstalledUnitId corresponds to an actual package which
+-- we have installed on disk. It could be definite or indefinite,
+-- but if it's indefinite, it has nothing instantiated (we
+-- never install partially instantiated units.)
--
--- Module: A UnitId + ModuleName. This is how the compiler identifies
--- modules (e.g. a Name is a Module + OccName)
+-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how
+-- the compiler identifies modules (e.g. a Name is a Module + OccName)
-- - Same as Language.Haskell.TH.Syntax:Module
--
-- THE LESS IMPORTANT ONES
@@ -471,8 +487,8 @@ instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where
fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts })
= newUnitId cid insts
- fromDbUnitId (DbHashedUnitId cid hash)
- = newHashedUnitId cid (fmap mkFastStringByteString hash)
+ fromDbUnitId (DbInstalledUnitId cid hash) -- TODO rename this
+ = newDefiniteUnitId cid (fmap mkFastStringByteString hash)
-- GHC never writes to the database, so it's not needed
toDbModule = error "toDbModule: not implemented"
toDbUnitId = error "toDbUnitId: not implemented"
@@ -518,36 +534,43 @@ instance Outputable ComponentId where
************************************************************************
-}
--- | A unit identifier uniquely identifies a library (e.g.,
--- a package) in GHC. In the absence of Backpack, unit identifiers
--- are just strings ('SimpleUnitId'); however, if a library is
--- parametrized over some signatures, these identifiers need
--- more structure.
+-- | A unit identifier identifies a (possibly partially) instantiated
+-- library. It is primarily used as part of 'Module', which in turn
+-- is used in 'Name', which is used to give names to entities when
+-- typechecking.
+--
+-- There are two possible forms for a 'UnitId'. It can be a
+-- 'DefiniteUnitId', in which case we just have a string that uniquely
+-- identifies some fully compiled, installed library we have on disk.
+-- However, when we are typechecking a library with missing holes,
+-- we may need to instantiate a library on the fly (in which case
+-- we don't have any on-disk representation.) In that case, you
+-- have an 'IndefiniteUnitId', which explicitly records the
+-- instantiation, so that we can substitute over it.
data UnitId
- = AnIndefUnitId {-# UNPACK #-} !IndefUnitId
- | AHashedUnitId {-# UNPACK #-} !HashedUnitId
+ = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId
+ | DefiniteUnitId {-# UNPACK #-} !DefUnitId
deriving (Typeable)
unitIdFS :: UnitId -> FastString
-unitIdFS (AnIndefUnitId x) = indefUnitIdFS x
-unitIdFS (AHashedUnitId x) = hashedUnitIdFS x
+unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x
+unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x
unitIdKey :: UnitId -> Unique
-unitIdKey (AnIndefUnitId x) = indefUnitIdKey x
-unitIdKey (AHashedUnitId x) = hashedUnitIdKey x
+unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
+unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
unitIdComponentId :: UnitId -> ComponentId
-unitIdComponentId (AnIndefUnitId x) = indefUnitIdComponentId x
-unitIdComponentId (AHashedUnitId x) = hashedUnitIdComponentId x
-
--- | A non-hashed unit identifier identifies an indefinite
--- library (with holes) which has been *on-the-fly* instantiated
--- with a substitution 'unitIdInsts_'. These unit identifiers
--- are recorded in interface files and installed package
--- database entries for indefinite libraries. We can substitute
--- over these identifiers.
+unitIdComponentId (IndefiniteUnitId x) = indefUnitIdComponentId x
+unitIdComponentId (DefiniteUnitId (DefUnitId x)) = installedUnitIdComponentId x
+
+-- | A unit identifier which identifies an indefinite
+-- library (with holes) that has been *on-the-fly* instantiated
+-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite
+-- unit identifier could have no holes, but we haven't gotten
+-- around to compiling the actual library yet.
--
--- A non-hashed unit identifier pretty-prints to something like
+-- An indefinite unit identifier pretty-prints to something like
-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the
-- brackets enclose the module substitution).
data IndefUnitId
@@ -571,44 +594,89 @@ data IndefUnitId
indefUnitIdFreeHoles :: UniqDSet ModuleName
} deriving (Typeable)
--- | A hashed unit identifier identifies an indefinite library which has
--- been fully instantiated, compiled and installed to the package database.
--- The ONLY source of hashed unit identifiers is the package database and
--- the @-this-unit-id@ flag: if a non-hashed unit id is substituted into one
--- with no holes, you don't necessarily get a hashed unit id: a hashed unit
--- id means *you have actual code*. To promote a fully instantiated unit
--- identifier into a hashed unit identifier, you have to look it up in the
--- package database.
---
--- Hashed unit identifiers don't record the full instantiation tree,
--- making them a bit more efficient to work with. This is possible
--- because substituting over a hashed unit id is always a no-op
--- (no free module variables)
+instance Eq IndefUnitId where
+ u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2
+
+instance Ord IndefUnitId where
+ u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
+
+-- | An installed unit identifier identifies a library which has
+-- been installed to the package database. These strings are
+-- provided to us via the @-this-unit-id@ flag. The library
+-- in question may be definite or indefinite; if it is indefinite,
+-- none of the holes have been filled (we never install partially
+-- instantiated libraries.) Put another way, an installed unit id
+-- is either fully instantiated, or not instantiated at all.
--
--- Hashed unit identifiers look something like @p+af23SAj2dZ219@
-data HashedUnitId =
- HashedUnitId {
+-- Installed unit identifiers look something like @p+af23SAj2dZ219@,
+-- or maybe just @p@ if they don't use Backpack.
+data InstalledUnitId =
+ InstalledUnitId {
-- | The full hashed unit identifier, including the component id
-- and the hash.
- hashedUnitIdFS :: FastString,
+ installedUnitIdFS :: FastString,
-- | Cached unique of 'unitIdFS'.
- hashedUnitIdKey :: Unique,
+ installedUnitIdKey :: Unique,
-- | The component identifier of the hashed unit identifier.
- hashedUnitIdComponentId :: !ComponentId
+ installedUnitIdComponentId :: !ComponentId
}
deriving (Typeable)
-instance Eq IndefUnitId where
- u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2
+-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
+-- it only refers to a definite library; i.e., one we have generated
+-- code for.
+newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
+ deriving (Eq, Ord, Outputable, Typeable)
-instance Ord IndefUnitId where
- u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
+instance Binary InstalledUnitId where
+ put_ bh uid
+ | cid == ComponentId fs = do
+ putByte bh 0
+ put_ bh fs
+ | otherwise = do
+ putByte bh 2
+ put_ bh cid
+ put_ bh fs
+ where
+ cid = installedUnitIdComponentId uid
+ fs = installedUnitIdFS uid
+ get bh = do b <- getByte bh
+ case b of
+ 0 -> fmap fsToInstalledUnitId (get bh)
+ _ -> do
+ cid <- get bh
+ fs <- get bh
+ return (rawNewInstalledUnitId cid fs)
-instance Outputable HashedUnitId where
+instance BinaryStringRep InstalledUnitId where
+ fromStringRep bs = rawNewInstalledUnitId (fromStringRep cid) (mkFastStringByteString bs)
+ where cid = BS.Char8.takeWhile (/='+') bs
+ -- GHC doesn't write to database
+ toStringRep = error "BinaryStringRep InstalledUnitId: not implemented"
+
+instance Eq InstalledUnitId where
+ uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2
+
+instance Ord InstalledUnitId where
+ u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2
+
+instance Uniquable InstalledUnitId where
+ getUnique = installedUnitIdKey
+
+instance Outputable InstalledUnitId where
ppr uid =
- if hashedUnitIdComponentId uid == ComponentId (hashedUnitIdFS uid)
- then ppr (hashedUnitIdComponentId uid)
- else ftext (hashedUnitIdFS uid)
+ if installedUnitIdComponentId uid == ComponentId (installedUnitIdFS uid)
+ then ppr (installedUnitIdComponentId uid)
+ else ftext (installedUnitIdFS uid)
+
+-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.
+toInstalledUnitId :: UnitId -> InstalledUnitId
+toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid
+toInstalledUnitId (IndefiniteUnitId indef) =
+ newInstalledUnitId (indefUnitIdComponentId indef) Nothing
+
+installedUnitIdString :: InstalledUnitId -> String
+installedUnitIdString = unpackFS . installedUnitIdFS
instance Outputable IndefUnitId where
ppr uid =
@@ -636,25 +704,53 @@ instance Outputable IndefUnitId where
cid = indefUnitIdComponentId uid
insts = indefUnitIdInsts uid
-{-
-newtype DefiniteUnitId = DefiniteUnitId HashedUnitId
- deriving (Eq, Ord, Outputable, Typeable)
+-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.
+data InstalledModule = InstalledModule {
+ installedModuleUnitId :: !InstalledUnitId,
+ installedModuleName :: !ModuleName
+ }
+ deriving (Eq, Ord)
-newtype InstalledUnitId = InstalledUnitId HashedUnitId
- deriving (Eq, Ord, Outputable, Typeable)
--}
+instance Outputable InstalledModule where
+ ppr (InstalledModule p n) =
+ ppr p <> char ':' <> pprModuleName n
+
+fsToInstalledUnitId :: FastString -> InstalledUnitId
+fsToInstalledUnitId fs = rawNewInstalledUnitId (ComponentId fs) fs
+
+stringToInstalledUnitId :: String -> InstalledUnitId
+stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
+
+-- | Test if a 'Module' corresponds to a given 'InstalledModule',
+-- modulo instantiation.
+installedModuleEq :: InstalledModule -> Module -> Bool
+installedModuleEq imod mod =
+ fst (splitModuleInsts mod) == imod
+
+-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',
+-- modulo instantiation.
+installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
+installedUnitIdEq iuid uid =
+ fst (splitUnitIdInsts uid) == iuid
+
+-- | A map keyed off of 'InstalledModule'
+newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
+
+emptyInstalledModuleEnv :: InstalledModuleEnv a
+emptyInstalledModuleEnv = InstalledModuleEnv Map.empty
--- | A 'VirginModule' is a 'Module' which contains a 'VirginUnitId'.
-type VirginModule = Module
+lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a
+lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e
--- | A virgin unit id is either a 'HashedUnitId',
--- or a 'UnitId' whose instantiation all have the form @A=<A>@.
--- Intuitively, virgin unit identifiers are those which are recorded
--- in the installed package database and can be read off disk.
-type VirginUnitId = UnitId
+extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a
+extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)
--- | A map keyed off of 'VirginModule'
-type VirginModuleEnv elt = ModuleEnv elt
+filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a
+filterInstalledModuleEnv f (InstalledModuleEnv e) =
+ InstalledModuleEnv (Map.filterWithKey f e)
+
+delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
+delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
-- | A hole module is a 'Module' representing a required
-- signature that we are going to merge in. The unit id
@@ -662,10 +758,10 @@ type VirginModuleEnv elt = ModuleEnv elt
-- an instantiation.
type HoleModule = (IndefUnitId, ModuleName)
--- Note [UnitId to HashedUnitId improvement]
+-- Note [UnitId to InstalledUnitId improvement]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Just because a UnitId is definite (has no holes) doesn't
--- mean it's necessarily a HashedUnitId; it could just be
+-- mean it's necessarily a InstalledUnitId; it could just be
-- that over the course of renaming UnitIds on the fly
-- while typechecking an indefinite library, we
-- ended up with a fully instantiated unit id with no hash,
@@ -678,21 +774,19 @@ type HoleModule = (IndefUnitId, ModuleName)
-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided
-- hash of a compiled instantiated library).
--
--- There is one last niggle which is not currently fixed:
--- improvement based on the package database means that
--- we might end up developing on a package that is not transitively
--- depended upon by the packages the user specified directly
--- via command line flags. This could lead to strange and
--- difficult to understand bugs if those instantiations are
--- out of date. The fix is that GHC has to be a bit more
--- careful about what instantiated packages get put in the package database.
--- I haven't implemented this yet.
+-- There is one last niggle: improvement based on the package database means
+-- that we might end up developing on a package that is not transitively
+-- depended upon by the packages the user specified directly via command line
+-- flags. This could lead to strange and difficult to understand bugs if those
+-- instantiations are out of date. The solution is to only improve a
+-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the
+-- closure of all the packages which were explicitly specified.
-- | Retrieve the set of free holes of a 'UnitId'.
unitIdFreeHoles :: UnitId -> UniqDSet ModuleName
-unitIdFreeHoles (AnIndefUnitId x) = indefUnitIdFreeHoles x
+unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x
-- Hashed unit ids are always fully instantiated
-unitIdFreeHoles (AHashedUnitId _) = emptyUniqDSet
+unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet
instance Show UnitId where
show = unitIdString
@@ -707,14 +801,12 @@ unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles
-- coincides with its 'ComponentId'. This hash is completely internal
-- to GHC and is not used for symbol names or file paths.
hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString
-hashUnitId (ComponentId fs_cid) sorted_holes
- -- Make the special-case work.
- | all (\(mod_name, m) -> mkHoleModule mod_name == m) sorted_holes = fs_cid
hashUnitId cid sorted_holes =
mkFastStringByteString
. fingerprintUnitId (toStringRep cid)
$ rawHashUnitId sorted_holes
+-- | Generate a hash for a sorted module substitution.
rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint
rawHashUnitId sorted_holes =
fingerprintByteString
@@ -739,27 +831,37 @@ fingerprintUnitId prefix (Fingerprint a b)
-- | Create a new, externally provided hashed unit id from
-- a hash.
-newHashedUnitId :: ComponentId -> Maybe FastString -> UnitId
-newHashedUnitId cid@(ComponentId cid_fs) (Just fs)
- = rawNewHashedUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
-newHashedUnitId cid@(ComponentId cid_fs) Nothing
- = rawNewHashedUnitId cid cid_fs
-
--- | Smart constructor for 'HashedUnitId'; input 'FastString'
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId cid@(ComponentId cid_fs) (Just fs)
+ = rawNewInstalledUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId cid@(ComponentId cid_fs) Nothing
+ = rawNewInstalledUnitId cid cid_fs
+
+rawNewDefiniteUnitId :: ComponentId -> FastString -> UnitId
+rawNewDefiniteUnitId cid fs =
+ DefiniteUnitId (DefUnitId (rawNewInstalledUnitId cid fs))
+
+-- | Create a new 'UnitId' for an instantiated unit id.
+newDefiniteUnitId :: ComponentId -> Maybe FastString -> UnitId
+newDefiniteUnitId cid mb_fs =
+ DefiniteUnitId (DefUnitId (newInstalledUnitId cid mb_fs))
+
+-- | Smart constructor for 'InstalledUnitId'; input 'FastString'
-- is assumed to be the FULL identifying string for this
-- UnitId (e.g., it contains the 'ComponentId').
-rawNewHashedUnitId :: ComponentId -> FastString -> UnitId
-rawNewHashedUnitId cid fs = AHashedUnitId $ HashedUnitId {
- hashedUnitIdFS = fs,
- hashedUnitIdKey = getUnique fs,
- hashedUnitIdComponentId = cid
+rawNewInstalledUnitId :: ComponentId -> FastString -> InstalledUnitId
+rawNewInstalledUnitId cid fs = InstalledUnitId {
+ installedUnitIdFS = fs,
+ installedUnitIdKey = getUnique fs,
+ installedUnitIdComponentId = cid
}
-- | Create a new, un-hashed unit identifier.
newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
-newUnitId cid insts = AnIndefUnitId $ newIndefUnitId cid insts
+newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts
+-- | Create a new 'IndefUnitId' given an explicit module substitution.
newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId cid insts =
IndefUnitId {
@@ -773,10 +875,9 @@ newIndefUnitId cid insts =
fs = hashUnitId cid sorted_insts
sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
-
pprUnitId :: UnitId -> SDoc
-pprUnitId (AHashedUnitId uid) = ppr uid
-pprUnitId (AnIndefUnitId uid) = ppr uid
+pprUnitId (DefiniteUnitId uid) = ppr uid
+pprUnitId (IndefiniteUnitId uid) = ppr uid
instance Eq UnitId where
uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2
@@ -805,7 +906,7 @@ instance Outputable UnitId where
-- Performance: would prefer to have a NameCache like thing
instance Binary UnitId where
- put_ bh (AHashedUnitId uid)
+ put_ bh (DefiniteUnitId (DefUnitId uid))
| cid == ComponentId fs = do
putByte bh 0
put_ bh fs
@@ -814,9 +915,9 @@ instance Binary UnitId where
put_ bh cid
put_ bh fs
where
- cid = hashedUnitIdComponentId uid
- fs = hashedUnitIdFS uid
- put_ bh (AnIndefUnitId uid) = do
+ cid = installedUnitIdComponentId uid
+ fs = installedUnitIdFS uid
+ put_ bh (IndefiniteUnitId uid) = do
putByte bh 1
put_ bh cid
put_ bh insts
@@ -833,13 +934,7 @@ instance Binary UnitId where
_ -> do
cid <- get bh
fs <- get bh
- return (rawNewHashedUnitId cid fs)
-
-instance BinaryStringRep UnitId where
- fromStringRep bs = rawNewHashedUnitId (fromStringRep cid) (mkFastStringByteString bs)
- where cid = BS.Char8.takeWhile (/='+') bs
- -- GHC doesn't write to database
- toStringRep = error "BinaryStringRep UnitId: not implemented"
+ return (rawNewDefiniteUnitId cid fs)
instance Binary ComponentId where
put_ bh (ComponentId fs) = put_ bh fs
@@ -852,7 +947,7 @@ newSimpleUnitId (ComponentId fs) = fsToUnitId fs
-- | Create a new simple unit identifier from a 'FastString'. Internally,
-- this is primarily used to specify wired-in unit identifiers.
fsToUnitId :: FastString -> UnitId
-fsToUnitId fs = rawNewHashedUnitId (ComponentId fs) fs
+fsToUnitId fs = rawNewDefiniteUnitId (ComponentId fs) fs
stringToUnitId :: String -> UnitId
stringToUnitId = fsToUnitId . mkFastString
@@ -902,7 +997,7 @@ renameHoleModule' pkg_map env m
renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId' pkg_map env uid =
case uid of
- (AnIndefUnitId
+ (IndefiniteUnitId
IndefUnitId{ indefUnitIdComponentId = cid
, indefUnitIdInsts = insts
, indefUnitIdFreeHoles = fh })
@@ -911,7 +1006,7 @@ renameHoleUnitId' pkg_map env uid =
-- Functorially apply the substitution to the instantiation,
-- then check the 'PackageConfigMap' to see if there is
-- a compiled version of this 'UnitId' we can improve to.
- -- See Note [UnitId to HashedUnitId] improvement
+ -- See Note [UnitId to InstalledUnitId] improvement
else improveUnitId pkg_map $
newUnitId cid
(map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
@@ -921,16 +1016,16 @@ renameHoleUnitId' pkg_map env uid =
-- a 'Module' that we definitely can find on-disk, as well as an
-- instantiation if we need to instantiate it on the fly. If the
-- instantiation is @Nothing@ no on-the-fly renaming is needed.
-splitModuleInsts :: Module -> (VirginModule, Maybe [(ModuleName, Module)])
+splitModuleInsts :: Module -> (InstalledModule, Maybe [(ModuleName, Module)])
splitModuleInsts m =
let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m)
- in (mkModule uid (moduleName m), mb_insts)
+ in (InstalledModule uid (moduleName m), mb_insts)
-- | See 'splitModuleInsts'.
-splitUnitIdInsts :: UnitId -> (VirginUnitId, Maybe [(ModuleName, Module)])
-splitUnitIdInsts (AnIndefUnitId iuid) =
- (AnIndefUnitId (generalizeIndefUnitId iuid), Just (indefUnitIdInsts iuid))
-splitUnitIdInsts uid = (uid, Nothing)
+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe [(ModuleName, Module)])
+splitUnitIdInsts (IndefiniteUnitId iuid) =
+ (newInstalledUnitId (indefUnitIdComponentId iuid) Nothing, Just (indefUnitIdInsts iuid))
+splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid
@@ -942,17 +1037,20 @@ parseModuleName = fmap mkModuleName
$ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")
parseUnitId :: ReadP UnitId
-parseUnitId = parseFullUnitId <++ parseHashedUnitId <++ parseSimpleUnitId
+parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
where
- parseFullUnitId = do cid <- parseComponentId
- insts <- parseModSubst
- return (newUnitId cid insts)
- parseHashedUnitId = do cid <- parseComponentId
- _ <- Parse.char '+'
- hash <- Parse.munch1 isAlphaNum
- return (newHashedUnitId cid (Just (mkFastString hash)))
- parseSimpleUnitId = do cid <- parseComponentId
- return (newSimpleUnitId cid)
+ parseFullUnitId = do
+ cid <- parseComponentId
+ insts <- parseModSubst
+ return (newUnitId cid insts)
+ parseDefiniteUnitId = do
+ cid <- parseComponentId
+ _ <- Parse.char '+'
+ hash <- Parse.munch1 isAlphaNum
+ return (newDefiniteUnitId cid (Just (mkFastString hash)))
+ parseSimpleUnitId = do
+ cid <- parseComponentId
+ return (newSimpleUnitId cid)
parseComponentId :: ReadP ComponentId
parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 72d2f9b2ec..1f589a98eb 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -92,12 +92,12 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
- pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports)
+ pkgs | th_used = insertList (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
- sorted_pkgs = sortBy stableUnitIdCmp pkgs
+ sorted_pkgs = sort pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 251d9a8700..0b3fd94449 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -116,7 +116,7 @@ data PersistentLinkerState
-- The currently-loaded packages; always object code
-- Held, as usual, in dependency order; though I am not sure if
-- that is really important
- pkgs_loaded :: ![UnitId],
+ pkgs_loaded :: ![LinkerUnitId],
-- we need to remember the name of previous temporary DLL/.so
-- libraries so we can link them (see #10322)
@@ -137,10 +137,10 @@ emptyPLS _ = PersistentLinkerState {
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
- where init_pkgs = [rtsUnitId]
+ where init_pkgs = map toInstalledUnitId [rtsUnitId]
-extendLoadedPkgs :: [UnitId] -> IO ()
+extendLoadedPkgs :: [InstalledUnitId] -> IO ()
extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
@@ -566,7 +566,7 @@ getLinkDeps :: HscEnv -> HomePackageTable
-> Maybe FilePath -- replace object suffices?
-> SrcSpan -- for error messages
-> [Module] -- If you need these
- -> IO ([Linkable], [UnitId]) -- ... then link these first
+ -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
getLinkDeps hsc_env hpt pls replace_osuf span mods
@@ -604,8 +604,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- tree recursively. See bug #936, testcase ghci/prog007.
follow_deps :: [Module] -- modules to follow
-> UniqDSet ModuleName -- accum. module dependencies
- -> UniqDSet UnitId -- accum. package dependencies
- -> IO ([ModuleName], [UnitId]) -- result
+ -> UniqDSet InstalledUnitId -- accum. package dependencies
+ -> IO ([ModuleName], [InstalledUnitId]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
@@ -632,7 +632,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps
--
if pkg /= this_pkg
- then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' pkg)
+ then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
acc_mods' acc_pkgs'
where
@@ -1126,12 +1126,15 @@ showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
showLS (Framework nm) = "(framework) " ++ nm
+-- TODO: Make this type more precise
+type LinkerUnitId = InstalledUnitId
+
-- | Link exactly the specified packages, and their dependents (unless of
-- course they are already linked). The dependents are linked
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-linkPackages :: HscEnv -> [UnitId] -> IO ()
+linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()
-- NOTE: in fact, since each module tracks all the packages it depends on,
-- we don't really need to use the package-config dependencies.
--
@@ -1147,7 +1150,7 @@ linkPackages hsc_env new_pkgs = do
modifyPLS_ $ \pls -> do
linkPackages' hsc_env new_pkgs pls
-linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState
+linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
@@ -1155,7 +1158,7 @@ linkPackages' hsc_env new_pks pls = do
where
dflags = hsc_dflags hsc_env
- link :: [UnitId] -> [UnitId] -> IO [UnitId]
+ link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
@@ -1163,7 +1166,7 @@ linkPackages' hsc_env new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
- | Just pkg_cfg <- lookupPackage dflags new_pkg
+ | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
= do { -- Link dependents first
pkgs' <- link pkgs (depends pkg_cfg)
-- Now link the package itself
@@ -1171,7 +1174,7 @@ linkPackages' hsc_env new_pks pls = do
; return (new_pkg : pkgs') }
| otherwise
- = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg))
+ = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
linkPackage :: HscEnv -> PackageConfig -> IO ()
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 4e1fea068e..ca11c6f59b 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -276,7 +276,8 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
; case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
- err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) }
+ -- TODO: Make sure this error message is good
+ err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }
-- | Load interface directly for a fully qualified 'Module'. (This is a fairly
-- rare operation, but in particular it is used to load orphan modules
@@ -572,7 +573,7 @@ moduleFreeHolesPrecise doc_str mod
tryEpsAndHpt dflags eps hpt =
fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
tryDepsCache eps imod insts =
- case lookupModuleEnv (eps_free_holes eps) imod of
+ case lookupInstalledModuleEnv (eps_free_holes eps) imod of
Just ifhs -> Just (renameFreeHoles ifhs insts)
_otherwise -> Nothing
readAndCache imod insts = do
@@ -582,7 +583,7 @@ moduleFreeHolesPrecise doc_str mod
let ifhs = mi_free_holes iface
-- Cache it
updateEps_ (\eps ->
- eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs })
+ eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
return (Succeeded (renameFreeHoles ifhs insts))
Failed err -> return (Failed err)
@@ -769,7 +770,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
See Trac #8320.
-}
-findAndReadIface :: SDoc -> VirginModule
+findAndReadIface :: SDoc -> InstalledModule
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
@@ -788,7 +789,8 @@ findAndReadIface doc_str mod hi_boot_file
nest 4 (text "reason:" <+> doc_str)])
-- Check for GHC.Prim, and return its static interface
- if mod == gHC_PRIM
+ -- TODO: make this check a function
+ if mod `installedModuleEq` gHC_PRIM
then do
iface <- getHooked ghcPrimIfaceHook ghcPrimIface
return (Succeeded (iface,
@@ -799,13 +801,13 @@ findAndReadIface doc_str mod hi_boot_file
hsc_env <- getTopEnv
mb_found <- liftIO (findExactModule hsc_env mod)
case mb_found of
- Found loc mod -> do
+ InstalledFound loc mod -> do
-- Found file, so read it
let file_path = addBootSuffix_maybe hi_boot_file
(ml_hi_file loc)
-- See Note [Home module load error]
- if thisPackage dflags == moduleUnitId mod &&
+ if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&
not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do r <- read_file file_path
@@ -815,14 +817,14 @@ findAndReadIface doc_str mod hi_boot_file
traceIf (text "...not found")
dflags <- getDynFlags
return (Failed (cannotFindInterface dflags
- (moduleName mod) err))
+ (installedModuleName mod) err))
where read_file file_path = do
traceIf (text "readIFace" <+> text file_path)
read_result <- readIface mod file_path
case read_result of
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface
- | mi_module iface /= mod ->
+ | not (mod `installedModuleEq` mi_module iface) ->
return (Failed (wrongIfaceModErr iface mod file_path))
| otherwise ->
return (Succeeded (iface, file_path))
@@ -852,7 +854,7 @@ findAndReadIface doc_str mod hi_boot_file
-- @readIface@ tries just the one file.
-readIface :: VirginModule -> FilePath
+readIface :: InstalledModule -> FilePath
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
@@ -862,8 +864,10 @@ readIface wanted_mod file_path
readBinIface CheckHiWay QuietBinIFaceReading file_path
; case res of
Right iface
- | wanted_mod == actual_mod -> return (Succeeded iface)
- | otherwise -> return (Failed err)
+ -- Same deal
+ | wanted_mod `installedModuleEq` actual_mod
+ -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
where
actual_mod = mi_module iface
err = hiModuleNameMismatchWarn wanted_mod actual_mod
@@ -884,7 +888,7 @@ initExternalPackageState
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
- eps_free_holes = emptyModuleEnv,
+ eps_free_holes = emptyInstalledModuleEnv,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
@@ -1114,7 +1118,7 @@ badIfaceFile file err
= vcat [text "Bad interface file:" <+> text file,
nest 4 err]
-hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
+hiModuleNameMismatchWarn :: InstalledModule -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
@@ -1127,11 +1131,11 @@ hiModuleNameMismatchWarn requested_mod read_mod =
, ppr read_mod
]
-wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
-wrongIfaceModErr iface mod_name file_path
+wrongIfaceModErr :: ModIface -> InstalledModule -> String -> SDoc
+wrongIfaceModErr iface mod file_path
= sep [text "Interface file" <+> iface_file,
text "contains module" <+> quotes (ppr (mi_module iface)) <> comma,
- text "but we were expecting module" <+> quotes (ppr mod_name),
+ text "but we were expecting module" <+> quotes (ppr mod),
sep [text "Probable cause: the source code which generated",
nest 2 iface_file,
text "has an incompatible module name"
@@ -1139,7 +1143,7 @@ wrongIfaceModErr iface mod_name file_path
]
where iface_file = doubleQuotes (text file_path)
-homeModError :: Module -> ModLocation -> SDoc
+homeModError :: InstalledModule -> ModLocation -> SDoc
-- See Note [Home module load error]
homeModError mod location
= text "attempting to use module " <> quotes (ppr mod)
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 3ab898e682..7cff9463ac 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -651,7 +651,7 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
- dep_pkgs = sortBy (stableUnitIdCmp `on` fst) (dep_pkgs d),
+ dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
@@ -1009,7 +1009,7 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
loadIface = do
let iface_path = msHiFilePath mod_summary
- read_result <- readIface (ms_mod mod_summary) iface_path
+ read_result <- readIface (ms_installed_mod mod_summary) iface_path
case read_result of
Failed err -> do
traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
@@ -1107,7 +1107,7 @@ checkHsig mod_summary iface = do
dflags <- getDynFlags
let outer_mod = ms_mod mod_summary
inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
- MASSERT( thisPackage dflags == moduleUnitId outer_mod )
+ MASSERT( moduleUnitId outer_mod == thisPackage dflags )
case inner_mod == mi_semantic_module iface of
True -> up_to_date (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
@@ -1158,7 +1158,7 @@ checkDependencies hsc_env summary iface
else
return UpToDate
| otherwise
- -> if pkg `notElem` (map fst prev_dep_pkgs)
+ -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 024cd7b732..0794a9ee67 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -378,7 +378,7 @@ tcHiBootIface hsc_src mod
-- to check consistency against, rather than just when we notice
-- that an hi-boot is necessary due to a circular import.
{ read_result <- findAndReadIface
- need mod
+ need (fst (splitModuleInsts mod))
True -- Hi-boot file
; case read_result of {
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index f172cf1259..f4681dcd27 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -50,7 +50,7 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
- -> [UnitId]
+ -> [InstalledUnitId]
-> Stream IO RawCmmGroup () -- Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}))
@@ -107,7 +107,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
- -> [UnitId]
+ -> [InstalledUnitId]
-> IO ()
outputC dflags filenm cmm_stream packages
@@ -131,7 +131,7 @@ outputC dflags filenm cmm_stream packages
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
- let pkg_names = map unitIdString packages
+ let pkg_names = map installedUnitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 30493f123e..b1f1f6c2e6 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -402,7 +402,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
-linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
+linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded dflags staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
@@ -424,7 +424,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- next, check libraries. XXX this only checks Haskell libraries,
-- not extra_libraries or -l things from the command line.
let pkg_hslibs = [ (libraryDirs c, lib)
- | Just c <- map (lookupPackage dflags) pkg_deps,
+ | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
@@ -438,7 +438,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
-checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool
+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
checkLinkInfo dflags pkg_deps exe_file
| not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
-- ToDo: Windows and OS X do not use the ELF binary format, so
@@ -1652,7 +1652,7 @@ mkExtraObjToLinkIntoBinary dflags = do
-- this was included as inline assembly in the main.c file but this
-- is pretty fragile. gas gets upset trying to calculate relative offsets
-- that span the .note section (notably .text) when debug info is present
-mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
@@ -1677,7 +1677,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
-- | Return the "link info" string
--
-- See Note [LinkInfo section]
-getLinkInfo :: DynFlags -> [UnitId] -> IO String
+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
getLinkInfo dflags dep_packages = do
package_link_opts <- getPackageLinkOpts dflags dep_packages
pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
@@ -1714,13 +1714,13 @@ not follow the specified record-based format (see #11022).
-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
-getHCFilePackages :: FilePath -> IO [UnitId]
+getHCFilePackages :: FilePath -> IO [InstalledUnitId]
getHCFilePackages filename =
Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
l <- hGetLine h
case l of
'/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
- return (map stringToUnitId (words rest))
+ return (map stringToInstalledUnitId (words rest))
_other ->
return []
@@ -1737,10 +1737,10 @@ getHCFilePackages filename =
-- read any interface files), so the user must explicitly specify all
-- the packages.
-linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
+linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary = linkBinary' False
-linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' staticLink dflags o_files dep_packages = do
let platform = targetPlatform dflags
mySettings = settings dflags
@@ -1987,7 +1987,7 @@ maybeCreateManifest dflags exe_filename
| otherwise = return []
-linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
+linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
@@ -1997,7 +1997,7 @@ linkDynLibCheck dflags o_files dep_packages
linkDynLib dflags o_files dep_packages
-linkStaticLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
+linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkStaticLibCheck dflags o_files dep_packages
= do
when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
@@ -2229,7 +2229,7 @@ haveRtsOptsFlags dflags =
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
- dirs <- getPackageIncludePath dflags [rtsUnitId]
+ dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]
found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)
case found of
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index e813e9e52c..2bcdd3360c 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -71,25 +71,25 @@ type BaseName = String -- Basename of file
-- assumed to not move around during a session.
flushFinderCaches :: HscEnv -> IO ()
flushFinderCaches hsc_env =
- atomicModifyIORef' fc_ref $ \fm -> (filterModuleEnv is_ext fm, ())
+ atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
where
this_pkg = thisPackage (hsc_dflags hsc_env)
fc_ref = hsc_FC hsc_env
- is_ext mod _ | moduleUnitId mod /= this_pkg = True
+ is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
| otherwise = False
-addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO ()
+addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache ref key val =
- atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ())
+ atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
-removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
+removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
removeFromFinderCache ref key =
- atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
+ atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
-lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult)
+lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache ref key = do
c <- readIORef ref
- return $! lookupModuleEnv c key
+ return $! lookupInstalledModuleEnv c key
-- -----------------------------------------------------------------------------
-- The three external entry points
@@ -131,11 +131,11 @@ findPluginModule hsc_env mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: HscEnv -> VirginModule -> IO FindResult
+findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
- in if moduleUnitId mod == thisPackage dflags
- then findHomeModule hsc_env (moduleName mod)
+ in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
+ then findInstalledHomeModule hsc_env (installedModuleName mod)
else findPackageModule hsc_env mod
-- -----------------------------------------------------------------------------
@@ -169,9 +169,9 @@ orIfNotFound this or_this = do
-- been done. Otherwise, do the lookup (with the IO action) and save
-- the result in the finder cache and the module location cache (if it
-- was successful.)
-homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache hsc_env mod_name do_this = do
- let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
+ let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
modLocationCache hsc_env mod do_this
findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
@@ -190,8 +190,20 @@ findExposedPluginPackageModule hsc_env mod_name
findLookupResult :: HscEnv -> LookupResult -> IO FindResult
findLookupResult hsc_env r = case r of
- LookupFound m pkg_conf ->
- findPackageModule_ hsc_env m pkg_conf
+ LookupFound m pkg_conf -> do
+ let im = fst (splitModuleInsts m)
+ r' <- findPackageModule_ hsc_env im pkg_conf
+ case r' of
+ -- TODO: ghc -M is unlikely to do the right thing
+ -- with just the location of the thing that was
+ -- instantiated; you probably also need all of the
+ -- implicit locations from the instances
+ InstalledFound loc _ -> return (Found loc m)
+ InstalledNoPackage _ -> return (NoPackage (moduleUnitId m))
+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
+ , fr_pkgs_hidden = []
+ , fr_mods_hidden = []
+ , fr_suggestions = []})
LookupMultiple rs ->
return (FoundMultiple rs)
LookupHidden pkg_hiddens mod_hiddens ->
@@ -205,7 +217,7 @@ findLookupResult hsc_env r = case r of
, fr_mods_hidden = []
, fr_suggestions = suggest })
-modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult
+modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache hsc_env mod do_this = do
m <- lookupFinderCache (hsc_FC hsc_env) mod
case m of
@@ -215,20 +227,43 @@ modLocationCache hsc_env mod do_this = do
addToFinderCache (hsc_FC hsc_env) mod result
return result
+mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
+mkHomeInstalledModule dflags mod_name =
+ let iuid = fst (splitUnitIdInsts (thisPackage dflags))
+ in InstalledModule iuid mod_name
+
+-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do
- let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
- addToFinderCache (hsc_FC hsc_env) mod (Found loc mod)
- return mod
+ let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+ addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
+ return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)
uncacheModule :: HscEnv -> ModuleName -> IO ()
-uncacheModule hsc_env mod = do
- let this_pkg = thisPackage (hsc_dflags hsc_env)
- removeFromFinderCache (hsc_FC hsc_env) (mkModule this_pkg mod)
+uncacheModule hsc_env mod_name = do
+ let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+ removeFromFinderCache (hsc_FC hsc_env) mod
-- -----------------------------------------------------------------------------
-- The internal workers
+findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule hsc_env mod_name = do
+ r <- findInstalledHomeModule hsc_env mod_name
+ return $ case r of
+ InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+ InstalledNoPackage _ -> NoPackage uid -- impossible
+ InstalledNotFound fps _ -> NotFound {
+ fr_paths = fps,
+ fr_pkg = Just uid,
+ fr_mods_hidden = [],
+ fr_pkgs_hidden = [],
+ fr_suggestions = []
+ }
+ where
+ dflags = hsc_dflags hsc_env
+ uid = thisPackage dflags
+
-- | Implements the search for a module name in the home package only. Calling
-- this function directly is usually *not* what you want; currently, it's used
-- as a building block for the following operations:
@@ -245,14 +280,14 @@ uncacheModule hsc_env mod = do
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
-- call this.)
-findHomeModule :: HscEnv -> ModuleName -> IO FindResult
-findHomeModule hsc_env mod_name =
+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult
+findInstalledHomeModule hsc_env mod_name =
homeSearchCache hsc_env mod_name $
let
dflags = hsc_dflags hsc_env
home_path = importPaths dflags
hisuf = hiSuf dflags
- mod = mkModule (thisPackage dflags) mod_name
+ mod = mkHomeInstalledModule dflags mod_name
source_exts =
[ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
@@ -275,20 +310,20 @@ findHomeModule hsc_env mod_name =
-- special case for GHC.Prim; we won't find it in the filesystem.
-- This is important only when compiling the base package (where GHC.Prim
-- is a home module).
- if mod == gHC_PRIM
- then return (Found (error "GHC.Prim ModLocation") mod)
+ if mod `installedModuleEq` gHC_PRIM
+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)
else searchPathExts home_path mod exts
-- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> VirginModule -> IO FindResult
+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
- pkg_id = moduleUnitId mod
+ pkg_id = installedModuleUnitId mod
--
- case lookupPackage dflags pkg_id of
- Nothing -> return (NoPackage pkg_id)
+ case lookupInstalledPackage dflags pkg_id of
+ Nothing -> return (InstalledNoPackage pkg_id)
Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
-- | Look up the interface file associated with module @mod@. This function
@@ -298,14 +333,14 @@ 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 -> VirginModule -> PackageConfig -> IO FindResult
+findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
- ASSERT( moduleUnitId mod == packageConfigId pkg_conf )
+ ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
- if mod == gHC_PRIM
- then return (Found (error "GHC.Prim ModLocation") mod)
+ if mod `installedModuleEq` gHC_PRIM
+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)
else
let
@@ -326,9 +361,9 @@ findPackageModule_ hsc_env mod pkg_conf =
[one] | MkDepend <- ghcMode dflags -> do
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
+ let basename = moduleNameSlashes (installedModuleName mod)
loc <- mk_hi_loc one basename
- return (Found loc mod)
+ return (InstalledFound loc mod)
_otherwise ->
searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
@@ -337,13 +372,13 @@ findPackageModule_ hsc_env mod pkg_conf =
searchPathExts
:: [FilePath] -- paths to search
- -> Module -- module name
+ -> InstalledModule -- module name
-> [ (
FileExt, -- suffix
FilePath -> BaseName -> IO ModLocation -- action
)
]
- -> IO FindResult
+ -> IO InstalledFindResult
searchPathExts paths mod exts
= do result <- search to_search
@@ -358,7 +393,7 @@ searchPathExts paths mod exts
return result
where
- basename = moduleNameSlashes (moduleName mod)
+ basename = moduleNameSlashes (installedModuleName mod)
to_search :: [(FilePath, IO ModLocation)]
to_search = [ (file, fn path basename)
@@ -369,15 +404,12 @@ searchPathExts paths mod exts
file = base <.> ext
]
- search [] = return (NotFound { fr_paths = map fst to_search
- , fr_pkg = Just (moduleUnitId mod)
- , fr_mods_hidden = [], fr_pkgs_hidden = []
- , fr_suggestions = [] })
+ search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))
search ((file, mk_result) : rest) = do
b <- doesFileExist file
if b
- then do { loc <- mk_result; return (Found loc mod) }
+ then do { loc <- mk_result; return (InstalledFound loc mod) }
else search rest
mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
@@ -539,9 +571,9 @@ cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
cannotFindModule = cantFindErr (sLit "Could not find module")
(sLit "Ambiguous module name")
-cannotFindInterface :: DynFlags -> ModuleName -> FindResult -> SDoc
-cannotFindInterface = cantFindErr (sLit "Failed to load interface for")
- (sLit "Ambiguous interface for")
+cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc
+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
+ (sLit "Ambiguous interface for")
cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult
-> SDoc
@@ -581,7 +613,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
= case find_result of
NoPackage pkg
-> text "no unit id matching" <+> quotes (ppr pkg) <+>
- text "was found" $$ looks_like_srcpkgid pkg
+ text "was found"
NotFound { fr_paths = files, fr_pkg = mb_pkg
, fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
@@ -642,18 +674,6 @@ cantFindErr cannot_find _ dflags mod_name find_result
text "to the build-depends in your .cabal file."
| otherwise = Outputable.empty
- looks_like_srcpkgid :: UnitId -> SDoc
- looks_like_srcpkgid pk
- -- Unsafely coerce a unit id FastString into a source package ID
- -- FastString and see if it means anything.
- | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (unitIdFS pk))
- = parens (text "This unit ID looks like the source package ID;" $$
- text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
- (if null pkgs then Outputable.empty
- else text "and" <+> int (length pkgs) <+> text "other candidates"))
- -- Todo: also check if it looks like a package name!
- | otherwise = Outputable.empty
-
mod_hidden pkg =
text "it is a hidden module in the package" <+> quotes (ppr pkg)
@@ -693,3 +713,64 @@ cantFindErr cannot_find _ dflags mod_name find_result
= parens (text "needs flag -package-id"
<+> ppr (packageConfigId pkg))
| otherwise = Outputable.empty
+
+cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult
+ -> SDoc
+cantFindInstalledErr cannot_find _ dflags mod_name find_result
+ = ptext cannot_find <+> quotes (ppr mod_name)
+ $$ more_info
+ where
+ more_info
+ = case find_result of
+ InstalledNoPackage pkg
+ -> text "no unit id matching" <+> quotes (ppr pkg) <+>
+ text "was found" $$ looks_like_srcpkgid pkg
+
+ InstalledNotFound files mb_pkg
+ | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)
+ -> not_found_in_package pkg files
+
+ | null files
+ -> text "It is not a module in the current program, or in any known package."
+
+ | otherwise
+ -> tried_these files
+
+ _ -> panic "cantFindInstalledErr"
+
+ build_tag = buildTag dflags
+
+ looks_like_srcpkgid :: InstalledUnitId -> SDoc
+ looks_like_srcpkgid pk
+ -- Unsafely coerce a unit id FastString into a source package ID
+ -- FastString and see if it means anything.
+ | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))
+ = parens (text "This unit ID looks like the source package ID;" $$
+ text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
+ (if null pkgs then Outputable.empty
+ else text "and" <+> int (length pkgs) <+> text "other candidates"))
+ -- Todo: also check if it looks like a package name!
+ | otherwise = Outputable.empty
+
+ not_found_in_package pkg files
+ | build_tag /= ""
+ = let
+ build = if build_tag == "p" then "profiling"
+ else "\"" ++ build_tag ++ "\""
+ in
+ text "Perhaps you haven't installed the " <> text build <>
+ text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
+ tried_these files
+
+ | otherwise
+ = text "There are files missing in the " <> quotes (ppr pkg) <>
+ text " package," $$
+ text "try running 'ghc-pkg check'." $$
+ tried_these files
+
+ tried_these files
+ | null files = Outputable.empty
+ | verbosity dflags < 3 =
+ text "Use -v to see a list of the files searched for."
+ | otherwise =
+ hang (text "Locations searched:") 2 $ vcat (map text files)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 6a3887a0e9..5122329acf 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -576,7 +576,7 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
-setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
@@ -586,7 +586,7 @@ setSessionDynFlags dflags = do
return preload
-- | Sets the program 'DynFlags'.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
+setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setProgramDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
@@ -1435,7 +1435,7 @@ isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [UnitId])
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [InstalledUnitId])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 998d68c11a..0921a58531 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1916,7 +1916,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
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,
+ return (ModSummary { ms_mod = mod,
+ ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index cd8b56843f..ae6ad7d068 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -179,7 +179,7 @@ newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us allKnownKeyNames)
- fc_var <- newIORef emptyModuleEnv
+ fc_var <- newIORef emptyInstalledModuleEnv
#ifdef GHCI
iserv_mvar <- newMVar Nothing
#endif
@@ -444,12 +444,14 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do
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)
+ mod_name = moduleName outer_mod
+ outer_mod' = mkModule (thisPackage dflags) mod_name
+ inner_mod = canonicalizeHomeModule dflags mod_name
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
+ then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
do hpm <- case mb_rdr_module of
Just hpm -> return hpm
@@ -1021,7 +1023,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [UnitId])
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [InstalledUnitId])
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
@@ -1035,15 +1037,17 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
-hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId])
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, [InstalledUnitId])
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomePkg m -> return (Nothing, pkgs)
- | otherwise -> return (Just $ moduleUnitId m, pkgs)
+ -- TODO: do we also have to check the trust of the instantiation?
+ -- Not necessary if that is reflected in dependencies
+ | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
where
- isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId])
+ isModSafe :: Module -> SrcSpan -> Hsc (Bool, [InstalledUnitId])
isModSafe m l = do
iface <- lookup' m
case iface of
@@ -1123,7 +1127,7 @@ hscCheckSafe' dflags m l = do
| otherwise = False
-- | Check the list of packages are trusted.
-checkPkgTrust :: DynFlags -> [UnitId] -> Hsc ()
+checkPkgTrust :: DynFlags -> [InstalledUnitId] -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
@@ -1131,7 +1135,7 @@ checkPkgTrust dflags pkgs =
where
errors = catMaybes $ map go pkgs
go pkg
- | trusted $ getPackageDetails dflags pkg
+ | trusted $ getInstalledPackageDetails dflags pkg
= Nothing
| otherwise
= Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index c2d2938b45..1320a57e9a 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -10,7 +10,7 @@
module HscTypes (
-- * compilation state
HscEnv(..), hscEPS,
- FinderCache, FindResult(..),
+ FinderCache, FindResult(..), InstalledFindResult(..),
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
HscStatus(..),
@@ -26,7 +26,7 @@ module HscTypes (
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal(..),
- ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
+ ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
SourceModified(..),
@@ -771,16 +771,18 @@ prepareAnnotations hsc_env mb_guts = do
-- modules along the search path. On @:load@, we flush the entire
-- contents of this cache.
--
--- Although the @FinderCache@ range is 'FindResult' for convenience,
--- in fact it will only ever contain 'Found' or 'NotFound' entries.
---
-type FinderCache = VirginModuleEnv FindResult
+type FinderCache = InstalledModuleEnv InstalledFindResult
+
+data InstalledFindResult
+ = InstalledFound ModLocation InstalledModule
+ | InstalledNoPackage InstalledUnitId
+ | InstalledNotFound [FilePath] (Maybe InstalledUnitId)
-- | 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').
+-- for interfaces (which always result in 'InstalledModule').
data FindResult
= Found ModLocation Module
-- ^ The module was found
@@ -1272,8 +1274,8 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
- cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to
- -- generate #includes for C code gen
+ cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to
+ -- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints
}
@@ -2240,7 +2242,7 @@ data Dependencies
-- I.e. modules that this one imports, or that are in the
-- dep_mods of those directly-imported modules
- , dep_pkgs :: [(UnitId, Bool)]
+ , dep_pkgs :: [(InstalledUnitId, Bool)]
-- ^ All packages transitively below this module
-- I.e. packages to which this module's direct imports belong,
-- or that are in the dep_pkgs of those modules
@@ -2449,7 +2451,7 @@ data ExternalPackageState
--
-- * Deprecations and warnings
- eps_free_holes :: ModuleEnv (UniqDSet ModuleName),
+ eps_free_holes :: InstalledModuleEnv (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
@@ -2602,6 +2604,9 @@ data ModSummary
-- ^ The actual preprocessed source, if we have it
}
+ms_installed_mod :: ModSummary -> InstalledModule
+ms_installed_mod = fst . splitModuleInsts . ms_mod
+
ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = moduleName . ms_mod
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index f16c902a7e..6e3e2f1c9b 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -12,6 +12,8 @@ module PackageConfig (
-- * UnitId
packageConfigId,
expandedPackageConfigId,
+ definitePackageConfigId,
+ installedPackageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
@@ -35,6 +37,7 @@ import FastString
import Outputable
import Module
import Unique
+import UniqDSet
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
@@ -44,7 +47,7 @@ type PackageConfig = InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
- Module.UnitId
+ Module.InstalledUnitId
Module.UnitId
Module.ModuleName
Module.Module
@@ -129,11 +132,21 @@ pprPackageConfig InstalledPackageInfo {..} =
-- version is, so these are handled specially; see #wired_in_packages#.
-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
+installedPackageConfigId :: PackageConfig -> InstalledUnitId
+installedPackageConfigId = unitId
+
packageConfigId :: PackageConfig -> UnitId
-packageConfigId = unitId
+packageConfigId p =
+ if indefinite p
+ then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+ else DefiniteUnitId (DefUnitId (unitId p))
expandedPackageConfigId :: PackageConfig -> UnitId
expandedPackageConfigId p =
- case instantiatedWith p of
- [] -> packageConfigId p
- _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p)
+ newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+
+definitePackageConfigId :: PackageConfig -> Maybe DefUnitId
+definitePackageConfigId p =
+ case packageConfigId p of
+ DefiniteUnitId def_uid -> Just def_uid
+ _ -> Nothing
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 3003e015b6..566d998899 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -20,11 +20,12 @@ module Packages (
-- * Querying the package config
lookupPackage,
lookupPackage',
+ lookupInstalledPackage,
lookupPackageName,
- lookupComponentId,
improveUnitId,
searchPackageId,
getPackageDetails,
+ getInstalledPackageDetails,
componentIdString,
listVisibleModuleNames,
lookupModuleInAllPackages,
@@ -65,6 +66,7 @@ import DynFlags
import Name ( Name, nameModule_maybe )
import UniqFM
import UniqDFM
+import UniqSet
import Module
import Util
import Panic
@@ -238,12 +240,18 @@ originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False
--- | 'UniqFM' map from 'UnitId'
-type UnitIdMap = UniqDFM
-
--- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
--- (newtyped so we can put it in boot.)
-newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig }
+-- | 'UniqFM' map from 'InstalledUnitId'
+type InstalledUnitIdMap = UniqDFM
+
+-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
+-- the transitive closure of preload packages.
+data PackageConfigMap = PackageConfigMap {
+ unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
+ -- | The set of transitively reachable packages according
+ -- to the explicitly provided command line arguments.
+ -- See Note [UnitId to InstalledUnitId improvement]
+ preloadClosure :: UniqSet InstalledUnitId
+ }
-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
type VisibilityMap = Map UnitId UnitVisibility
@@ -294,6 +302,9 @@ instance Monoid UnitVisibility where
, uv_explicit = uv_explicit uv1 || uv_explicit uv2
}
+type WiredUnitId = DefUnitId
+type PreloadUnitId = InstalledUnitId
+
-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
-- (since this is the slow path, we'll just look it up again).
@@ -314,12 +325,12 @@ data PackageState = PackageState {
-- | A mapping from wired in names to the original names from the
-- package database.
- unwireMap :: Map UnitId UnitId,
+ unwireMap :: Map WiredUnitId WiredUnitId,
-- | 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.
- preloadPackages :: [UnitId],
+ preloadPackages :: [PreloadUnitId],
-- | Packages which we explicitly depend on (from a command line flag).
-- We'll use this to generate version macros.
@@ -355,11 +366,11 @@ emptyPackageState = PackageState {
requirementContext = Map.empty
}
-type InstalledPackageIndex = Map UnitId PackageConfig
+type InstalledPackageIndex = Map InstalledUnitId PackageConfig
-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
-emptyPackageConfigMap = PackageConfigMap emptyUDFM
+emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet
-- | Find the package we know about with the given unit id, if any
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
@@ -370,14 +381,15 @@ lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState
-- 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 =
+lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
+lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
case splitUnitIdInsts uid of
(iuid, Just insts) ->
- fmap (renamePackage (PackageConfigMap pkg_map) insts)
+ fmap (renamePackage m 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.
@@ -385,6 +397,7 @@ lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
where
PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
+-}
-- | 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)
@@ -399,12 +412,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
-extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs
- = PackageConfigMap (foldl add pkg_map new_pkgs)
+extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
+ = PackageConfigMap (foldl add pkg_map new_pkgs) closure
-- 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
+ (installedPackageConfigId p) p
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
@@ -412,6 +425,17 @@ getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails dflags pid =
expectJust "getPackageDetails" (lookupPackage dflags pid)
+lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
+lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid
+
+lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
+lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid
+
+getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
+getInstalledPackageDetails dflags uid =
+ expectJust "getInstalledPackageDetails" $
+ lookupInstalledPackage dflags uid
+
-- | Get a list of entries from the package database. NB: be careful with
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
@@ -419,7 +443,7 @@ getPackageDetails dflags pid =
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUDFM pkg_map
where
- PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
+ PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)
-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state
@@ -437,7 +461,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'pkgState' in 'DynFlags' and return a list of packages to
-- link in.
-initPackages :: DynFlags -> IO (DynFlags, [UnitId])
+initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
initPackages dflags0 = do
dflags <- interpretPackageEnv dflags0
pkg_db <-
@@ -741,7 +765,7 @@ findPackages pkg_db arg pkgs unusable
else Nothing
finder (UnitIdArg uid) p
= let (iuid, mb_insts) = splitUnitIdInsts uid
- in if iuid == packageConfigId p
+ in if iuid == installedPackageConfigId p
then Just (case mb_insts of
Nothing -> p
Just insts -> renamePackage pkg_db insts p)
@@ -765,12 +789,10 @@ 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)
+ smod = renameHoleModule' pkg_map hsubst
+ new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
in conf {
- unitId = new_uid,
- depends = map suid (depends conf),
+ instantiatedWith = new_insts,
exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
(exposedModules conf)
}
@@ -783,12 +805,13 @@ matchingStr str p
= str == sourcePackageIdString p
|| str == packageNameString p
-matchingId :: UnitId -> PackageConfig -> Bool
-matchingId uid p = uid == packageConfigId p
+matchingId :: InstalledUnitId -> PackageConfig -> Bool
+matchingId uid p = uid == installedPackageConfigId p
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
-matching (UnitIdArg uid) = matchingId uid
+matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid
+matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
@@ -849,7 +872,7 @@ pprTrustFlag flag = case flag of
wired_in_pkgids :: [String]
wired_in_pkgids = map unitIdString wiredInUnitIds
-type WiredPackagesMap = Map UnitId UnitId
+type WiredPackagesMap = Map WiredUnitId WiredUnitId
findWiredInPackages
:: DynFlags
@@ -918,7 +941,7 @@ findWiredInPackages dflags pkgs vis_map = do
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
- wired_in_ids = map unitId wired_in_pkgs
+ wired_in_ids = mapMaybe definitePackageConfigId wired_in_pkgs
-- this is old: we used to assume that if there were
-- multiple versions of wired-in packages installed that
@@ -933,30 +956,38 @@ findWiredInPackages dflags pkgs vis_map = do
&& package p `notElem` map fst wired_in_ids
-}
- wiredInMap :: Map UnitId UnitId
+ wiredInMap :: Map WiredUnitId WiredUnitId
wiredInMap = foldl' add_mapping Map.empty pkgs
where add_mapping m pkg
- | let key = unitId pkg
+ | Just key <- definitePackageConfigId pkg
, key `elem` wired_in_ids
- = Map.insert key (stringToUnitId (packageNameString pkg)) m
+ = Map.insert key (DefUnitId (stringToInstalledUnitId (packageNameString pkg))) m
| otherwise = m
updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
where upd_pkg pkg
- | unitId pkg `elem` wired_in_ids
+ | Just def_uid <- definitePackageConfigId pkg
+ , def_uid `elem` wired_in_ids
= pkg {
unitId = let PackageName fs = packageName pkg
- in fsToUnitId fs
+ in fsToInstalledUnitId fs
}
| otherwise
= pkg
upd_deps pkg = pkg {
- depends = map upd_wired_in (depends pkg),
+ -- temporary harmless DefUnitId invariant violation
+ depends = map (unDefUnitId . upd_wired_in . DefUnitId) (depends pkg),
exposedModules
= map (\(k,v) -> (k, fmap upd_wired_in_mod v))
(exposedModules pkg)
}
- upd_wired_in_mod (Module uid m) = Module (upd_wired_in uid) m
+ upd_wired_in_mod (Module uid m) = Module (upd_wired_in_uid uid) m
+ upd_wired_in_uid (DefiniteUnitId def_uid) =
+ DefiniteUnitId (upd_wired_in def_uid)
+ upd_wired_in_uid (IndefiniteUnitId indef_uid) =
+ IndefiniteUnitId $ newIndefUnitId
+ (indefUnitIdComponentId indef_uid)
+ (map (\(x,y) -> (x,upd_wired_in_mod y)) (indefUnitIdInsts indef_uid))
upd_wired_in key
| Just key' <- Map.lookup key wiredInMap = key'
| otherwise = key
@@ -966,9 +997,10 @@ 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 Map.lookup from vis_map of
+ where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of
Nothing -> vm
- Just r -> Map.insert to r (Map.delete from vm)
+ Just r -> Map.insert (DefiniteUnitId to) r
+ (Map.delete (DefiniteUnitId from) vm)
-- ----------------------------------------------------------------------------
@@ -976,13 +1008,13 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap
type IsShadowed = Bool
data UnusablePackageReason
= IgnoredWithFlag
- | MissingDependencies IsShadowed [UnitId]
+ | MissingDependencies IsShadowed [InstalledUnitId]
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
+type UnusablePackages = Map InstalledUnitId
(PackageConfig, UnusablePackageReason)
pprReason :: SDoc -> UnusablePackageReason -> SDoc
@@ -1014,7 +1046,7 @@ reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
--
findBroken :: IsShadowed
-> [PackageConfig]
- -> Map UnitId PackageConfig
+ -> Map InstalledUnitId PackageConfig
-> UnusablePackages
findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
where
@@ -1031,7 +1063,7 @@ findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
depsAvailable :: InstalledPackageIndex
-> PackageConfig
- -> Either PackageConfig (PackageConfig, [UnitId])
+ -> Either PackageConfig (PackageConfig, [InstalledUnitId])
depsAvailable pkg_map pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
@@ -1058,9 +1090,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
mkPackageState
:: DynFlags
-> [(FilePath, [PackageConfig])] -- initial databases
- -> [UnitId] -- preloaded packages
+ -> [PreloadUnitId] -- preloaded packages
-> IO (PackageState,
- [UnitId]) -- new packages to preload
+ [PreloadUnitId]) -- new packages to preload
mkPackageState dflags dbs preload0 = do
-- Compute the unit id
@@ -1138,7 +1170,7 @@ mkPackageState dflags dbs preload0 = do
`Map.union` unusable)
where -- The set of UnitIds which appear in both
-- db and pkgs (to be shadowed from pkgs)
- shadow_set :: Set UnitId
+ shadow_set :: Set InstalledUnitId
shadow_set = foldr ins Set.empty db
where ins pkg s
-- If the package from the upper database is
@@ -1180,7 +1212,7 @@ mkPackageState dflags dbs preload0 = do
-- Now merge the sets together (NB: later overrides
-- earlier!)
- pkg_map' :: Map UnitId PackageConfig
+ pkg_map' :: Map InstalledUnitId PackageConfig
pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3)
(pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs
@@ -1309,7 +1341,7 @@ mkPackageState dflags dbs preload0 = do
$ (basicLinkedPackages ++ preload2)
-- Close the preload packages with their dependencies
- dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
+ dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
@@ -1333,8 +1365,9 @@ mkPackageState dflags dbs preload0 = do
-- | 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)))
+unwireUnitId dflags uid@(DefiniteUnitId def_uid) =
+ maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags)))
+unwireUnitId _ uid = uid
-- -----------------------------------------------------------------------------
-- | Makes the mapping from module to package info
@@ -1415,7 +1448,7 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
-- use.
-- | Find all the include directories in these and the preload packages
-getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String]
+getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageIncludePath dflags pkgs =
collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1423,7 +1456,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
-- | Find all the library paths in these and the preload packages
-getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String]
+getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageLibraryPath dflags pkgs =
collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1432,7 +1465,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
-getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
+getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String])
getPackageLinkOpts dflags pkgs =
collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1481,19 +1514,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
| otherwise = '_':t
-- | Find all the C-compiler options in these and the preload packages
-getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
+getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap ccOptions ps)
-- | Find all the package framework paths in these and the preload packages
-getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
+getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (nub (filter notNull (concatMap frameworkDirs ps)))
-- | Find all the package frameworks in these and the preload packages
-getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String]
+getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String]
getPackageFrameworks dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap frameworks ps)
@@ -1616,7 +1649,7 @@ listVisibleModuleNames dflags =
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
-getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig]
+getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
let
state = pkgState dflags
@@ -1625,14 +1658,14 @@ getPreloadPackagesAnd dflags pkgids =
pairs = zip pkgids (repeat Nothing)
in do
all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
- return (map (getPackageDetails dflags) all_pkgs)
+ return (map (getInstalledPackageDetails dflags) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
closeDeps :: DynFlags
-> PackageConfigMap
- -> [(UnitId, Maybe UnitId)]
- -> IO [UnitId]
+ -> [(InstalledUnitId, Maybe InstalledUnitId)]
+ -> IO [InstalledUnitId]
closeDeps dflags pkg_map ps
= throwErr dflags (closeDepsErr dflags pkg_map ps)
@@ -1644,20 +1677,20 @@ throwErr dflags m
closeDepsErr :: DynFlags
-> PackageConfigMap
- -> [(UnitId,Maybe UnitId)]
- -> MaybeErr MsgDoc [UnitId]
+ -> [(InstalledUnitId,Maybe InstalledUnitId)]
+ -> MaybeErr MsgDoc [InstalledUnitId]
closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps
-- internal helper
add_package :: DynFlags
-> PackageConfigMap
- -> [UnitId]
- -> (UnitId,Maybe UnitId)
- -> MaybeErr MsgDoc [UnitId]
+ -> [PreloadUnitId]
+ -> (PreloadUnitId,Maybe PreloadUnitId)
+ -> MaybeErr MsgDoc [PreloadUnitId]
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' (isIndefinite dflags) pkg_db p of
+ case lookupInstalledPackage' pkg_db p of
Nothing -> Failed (missingPackageMsg p <>
missingDependencyMsg mb_parent)
Just pkg -> do
@@ -1671,19 +1704,19 @@ add_package dflags pkg_db ps (p, mb_parent)
missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = text "unknown package:" <+> ppr p
-missingDependencyMsg :: Maybe UnitId -> SDoc
+missingDependencyMsg :: Maybe InstalledUnitId -> SDoc
missingDependencyMsg Nothing = Outputable.empty
missingDependencyMsg (Just parent)
- = space <> parens (text "dependency of" <+> ftext (unitIdFS parent))
+ = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent))
-- -----------------------------------------------------------------------------
componentIdString :: DynFlags -> ComponentId -> Maybe String
componentIdString dflags cid =
- fmap sourcePackageIdString (lookupComponentId dflags cid)
+ fmap sourcePackageIdString (lookupInstalledPackage dflags (newInstalledUnitId cid Nothing))
-- | Will the 'Name' come from a dynamically linked library?
-isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
+isDllName :: DynFlags -> UnitId {- not used -} -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that
-- the symbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows
@@ -1732,7 +1765,7 @@ pprPackagesWith pprIPI dflags =
-- be different from the package databases (exposure, trust)
pprPackagesSimple :: DynFlags -> SDoc
pprPackagesSimple = pprPackagesWith pprIPI
- where pprIPI ipi = let i = unitIdFS (unitId ipi)
+ where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)
e = if exposed ipi then text "E" else text " "
t = if trusted ipi then text "T" else text " "
in e <> t <> text " " <> ftext i
@@ -1752,13 +1785,20 @@ 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.
+-- 'InstalledUnitId' if we can find it in the package database.
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
+improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit
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!
+ Just pkg ->
+ -- Do NOT improve if the indefinite unit id is not
+ -- part of the closure unique set. See
+ -- Note [UnitId to InstalledUnitId improvement]
+ if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map
+ then packageConfigId pkg
+ else uid
-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
-- in the @hs-boot@ loop-breaker.
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index e40b1d679f..e901bde06e 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -1564,7 +1564,7 @@ linesPlatform xs =
#endif
-linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
+linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLib dflags0 o_files dep_packages
= do
let -- This is a rather ugly hack to fix dynamically linked
@@ -1741,7 +1741,7 @@ linkDynLib dflags0 o_files dep_packages
++ map Option pkg_link_opts
)
-getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
+getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
getPkgFrameworkOpts dflags platform dep_packages
| platformUsesFrameworks platform = do
pkg_framework_path_opts <- do
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index e1258a3d0d..70c6b5fcad 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -358,6 +358,7 @@ calculateAvails dflags iface mod_safe' want_boot =
| otherwise = dep_finsts deps
pkg = moduleUnitId (mi_module iface)
+ ipkg = toInstalledUnitId pkg
-- Does this import mean we now require our own pkg
-- to be trusted? See Note [Trust Own Package]
@@ -382,9 +383,9 @@ calculateAvails dflags iface mod_safe' want_boot =
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
- ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps))
- , ppr pkg <+> ppr (dep_pkgs deps) )
- ([], (pkg, False) : dep_pkgs deps, False)
+ ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))
+ , ppr ipkg <+> ppr (dep_pkgs deps) )
+ ([], (ipkg, False) : dep_pkgs deps, False)
in ImportAvails {
imp_mods = emptyModuleEnv, -- this gets filled in later
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index be24423123..9b4f77472d 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -223,7 +223,7 @@ findExtraSigImports' hsc_env HsigFile modname =
(initIfaceLoad hsc_env
. withException
$ moduleFreeHolesPrecise (text "findExtraSigImports")
- (mkModule (AnIndefUnitId iuid) mod_name)))
+ (mkModule (IndefiniteUnitId iuid) mod_name)))
where
reqs = requirementMerges (hsc_dflags hsc_env) modname
@@ -269,7 +269,7 @@ implicitRequirements' hsc_env normal_imports
-- not; a component may have been filled with implementations for the holes
-- that don't actually fulfill the requirements.
--
--- INVARIANT: the UnitId is NOT a HashedUnitId
+-- INVARIANT: the UnitId is NOT a InstalledUnitId
checkUnitId :: UnitId -> TcM ()
checkUnitId uid = do
case splitUnitIdInsts uid of
@@ -354,9 +354,7 @@ mergeSignatures lcl_iface0 = do
fmap fst
. withException
. flip (findAndReadIface (text "mergeSignatures")) False
- -- Blegh, temporarily violated invariant that hashed unit
- -- ids are definite
- $ mkModule (newSimpleUnitId (indefUnitIdComponentId iuid)) mod_name
+ $ fst (splitModuleInsts (mkModule (IndefiniteUnitId iuid) mod_name))
-- STEP 3: Get the unrenamed exports of all these interfaces, and
-- dO shaping on them.
@@ -478,8 +476,7 @@ tcRnInstantiateSignature hsc_env this_mod real_loc =
-- explicitly.)
checkImplements :: Module -> HoleModule -> TcRn TcGblEnv
checkImplements impl_mod (uid, mod_name) = do
- let cid = indefUnitIdComponentId uid
- insts = indefUnitIdInsts uid
+ let insts = indefUnitIdInsts uid
-- STEP 1: Load the implementing interface, and make a RdrEnv
-- for its exports
@@ -493,7 +490,7 @@ checkImplements impl_mod (uid, mod_name) = do
-- the ORIGINAL signature. We are going to eventually rename it,
-- but we must proceed slowly, because it is NOT known if the
-- instantiation is correct.
- let isig_mod = mkModule (newSimpleUnitId cid) mod_name
+ let isig_mod = fst (splitModuleInsts (mkModule (IndefiniteUnitId uid) mod_name))
mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False
isig_iface <- case mb_isig_iface of
Succeeded (iface, _) -> return iface
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index ff51891b8a..e24305dcf3 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2471,7 +2471,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, text "Dependent modules:" <+>
pprUDFM (imp_dep_mods imports) ppr
, text "Dependent packages:" <+>
- ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)]
+ ppr (sortBy compare $ imp_dep_pkgs imports)]
where -- The use of sortBy is just to reduce unnecessary
-- wobbling in testsuite output
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 2a55b695e8..39707b8944 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1171,12 +1171,12 @@ data ImportAvails
-- compiling M might not need to consult X.hi, but X
-- is still listed in M's dependencies.
- imp_dep_pkgs :: [UnitId],
+ imp_dep_pkgs :: [InstalledUnitId],
-- ^ Packages needed by the module being compiled, whether directly,
-- or via other modules in this package, or via modules imported
-- from other packages.
- imp_trust_pkgs :: [UnitId],
+ imp_trust_pkgs :: [InstalledUnitId],
-- ^ This is strictly a subset of imp_dep_pkgs and records the
-- packages the current module needs to trust for Safe Haskell
-- compilation to succeed. A package is required to be trusted if
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index e3a56d6a06..3cc3f5c575 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -54,7 +54,8 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName, hsc_dflags, msObjFilePath )
import Module
import Name
-import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
+ listVisibleModuleNames, pprFlag )
import PprTyThing
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
@@ -2056,7 +2057,7 @@ isSafeModule m = do
tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
| otherwise = partition part deps
- where part pkg = trusted $ getPackageDetails dflags pkg
+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg
-----------------------------------------------------------------------------
-- :browse
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 9fda91979c..f8049d668c 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -60,7 +60,7 @@ import MonadUtils ( liftIO )
-- Imports for --abi-hash
import LoadIface ( loadUserInterface )
import Module ( mkModuleName )
-import Finder ( findImportedModule, cannotFindInterface )
+import Finder ( findImportedModule, cannotFindModule )
import TcRnMonad ( initIfaceCheck )
import Binary ( openBinMem, put_, fingerprintBinMem )
@@ -890,7 +890,7 @@ abiHash strs = do
case r of
Found _ m -> return m
_error -> throwGhcException $ CmdLineError $ showSDoc dflags $
- cannotFindInterface dflags modname r
+ cannotFindModule dflags modname r
mods <- mapM find_it strs
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index 2e51af0dcb..eda1a696ca 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -92,6 +92,7 @@ data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulenam
haddockHTMLs :: [FilePath],
exposedModules :: [(modulename, Maybe mod)],
hiddenModules :: [modulename],
+ indefinite :: Bool,
exposed :: Bool,
trusted :: Bool
}
@@ -139,7 +140,7 @@ data DbUnitId compid unitid modulename mod
dbUnitIdComponentId :: compid,
dbUnitIdInsts :: [(modulename, mod)]
}
- | DbHashedUnitId {
+ | DbInstalledUnitId {
dbUnitIdComponentId :: compid,
dbUnitIdHash :: Maybe BS.ByteString
}
@@ -175,6 +176,7 @@ emptyInstalledPackageInfo =
haddockHTMLs = [],
exposedModules = [],
hiddenModules = [],
+ indefinite = False,
exposed = False,
trusted = False
}
@@ -313,7 +315,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
includes includeDirs
haddockInterfaces haddockHTMLs
exposedModules hiddenModules
- exposed trusted) = do
+ indefinite exposed trusted) = do
put (toStringRep sourcePackageId)
put (toStringRep packageName)
put packageVersion
@@ -338,6 +340,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
exposedModules)
put (map toStringRep hiddenModules)
+ put indefinite
put exposed
put trusted
@@ -364,6 +367,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
haddockHTMLs <- get
exposedModules <- get
hiddenModules <- get
+ indefinite <- get
exposed <- get
trusted <- get
return (InstalledPackageInfo
@@ -384,7 +388,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
(fromStringRep mod_name, fmap fromDbModule mb_mod))
exposedModules)
(map fromStringRep hiddenModules)
- exposed trusted)
+ indefinite exposed trusted)
instance (BinaryStringRep modulename, BinaryStringRep compid,
DbUnitIdModuleRep compid unitid modulename mod) =>
@@ -409,7 +413,7 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
instance (BinaryStringRep modulename, BinaryStringRep compid,
DbUnitIdModuleRep compid unitid modulename mod) =>
Binary (DbUnitId compid unitid modulename mod) where
- put (DbHashedUnitId cid hash) = do
+ put (DbInstalledUnitId cid hash) = do
putWord8 0
put (toStringRep cid)
put hash
@@ -423,7 +427,7 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
0 -> do
cid <- get
hash <- get
- return (DbHashedUnitId (fromStringRep cid) hash)
+ return (DbInstalledUnitId (fromStringRep cid) hash)
_ -> do
dbUnitIdComponentId <- get
dbUnitIdInsts <- get
diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore b/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore
new file mode 100644
index 0000000000..1c08f2f992
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore
@@ -0,0 +1,2 @@
+p/P.hs
+q/Q.hs
diff --git a/testsuite/tests/cabal/cabal05/cabal05.stderr b/testsuite/tests/cabal/cabal05/cabal05.stderr
index b38f3a5301..eb51115ab0 100644
--- a/testsuite/tests/cabal/cabal05/cabal05.stderr
+++ b/testsuite/tests/cabal/cabal05/cabal05.stderr
@@ -1,5 +1,5 @@
T.hs:3:1: error:
- Ambiguous interface for ‘Conflict’:
+ Ambiguous module name ‘Conflict’:
it is bound as p-0.1.0.0:P2 by a reexport in package p-0.1.0.0
it is bound as P by a reexport in package p-0.1.0.0
diff --git a/testsuite/tests/cabal/ghcpkg01.stdout b/testsuite/tests/cabal/ghcpkg01.stdout
index d7b35b7f88..7077b3507b 100644
--- a/testsuite/tests/cabal/ghcpkg01.stdout
+++ b/testsuite/tests/cabal/ghcpkg01.stdout
@@ -16,6 +16,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: True
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D
@@ -42,6 +43,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: True
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D
@@ -74,6 +76,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: False
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D C.E
@@ -100,6 +103,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: False
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D C.E
@@ -126,6 +130,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: True
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D
@@ -159,6 +164,7 @@ description:
category: none
author: simonmar@microsoft.com
exposed: False
+indefinite: False
exposed-modules:
A
hidden-modules: B C.D
diff --git a/testsuite/tests/cabal/ghcpkg04.stderr b/testsuite/tests/cabal/ghcpkg04.stderr
index b601f3e706..5cc97f573f 100644
--- a/testsuite/tests/cabal/ghcpkg04.stderr
+++ b/testsuite/tests/cabal/ghcpkg04.stderr
@@ -1,4 +1,4 @@
ghcpkg04.hs:1:1: error:
- Ambiguous interface for ‘A’:
- it was found in multiple packages: testpkg-1.2.3.4 newtestpkg-2.0
+ Ambiguous module name ‘A’:
+ it was found in multiple packages: newtestpkg-2.0 testpkg-1.2.3.4
diff --git a/testsuite/tests/driver/driver063.stderr b/testsuite/tests/driver/driver063.stderr
index 84ff5b6dbb..307467b27b 100644
--- a/testsuite/tests/driver/driver063.stderr
+++ b/testsuite/tests/driver/driver063.stderr
@@ -1,4 +1,4 @@
D063.hs:2:1: error:
- Failed to load interface for ‘A063’
+ Could not find module ‘A063’
It is not a module in the current program, or in any known package.
diff --git a/testsuite/tests/ghc-e/should_run/T2636.stderr b/testsuite/tests/ghc-e/should_run/T2636.stderr
index 1a7912735c..bf73e40e77 100644
--- a/testsuite/tests/ghc-e/should_run/T2636.stderr
+++ b/testsuite/tests/ghc-e/should_run/T2636.stderr
@@ -1,4 +1,4 @@
T2636.hs:1:1: error:
- Failed to load interface for ‘MissingModule’
+ Could not find module ‘MissingModule’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/module/mod1.stderr b/testsuite/tests/module/mod1.stderr
index ecc147513d..50554ae4c6 100644
--- a/testsuite/tests/module/mod1.stderr
+++ b/testsuite/tests/module/mod1.stderr
@@ -1,4 +1,4 @@
-mod1.hs:3:1:
- Failed to load interface for ‘N’
+mod1.hs:3:1: error:
+ Could not find module ‘N’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/module/mod2.stderr b/testsuite/tests/module/mod2.stderr
index 32522890ba..a070917fc4 100644
--- a/testsuite/tests/module/mod2.stderr
+++ b/testsuite/tests/module/mod2.stderr
@@ -1,4 +1,4 @@
-mod2.hs:3:1:
- Failed to load interface for ‘N’
+mod2.hs:3:1: error:
+ Could not find module ‘N’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/package/package01e.stderr b/testsuite/tests/package/package01e.stderr
index ea5f2f6975..f34ee1dd8f 100644
--- a/testsuite/tests/package/package01e.stderr
+++ b/testsuite/tests/package/package01e.stderr
@@ -1,10 +1,10 @@
package01e.hs:2:1: error:
- Failed to load interface for ‘Data.Map’
+ Could not find module ‘Data.Map’
It is a member of the hidden package ‘containers-0.5.7.1’.
Use -v to see a list of the files searched for.
package01e.hs:3:1: error:
- Failed to load interface for ‘Data.IntMap’
+ Could not find module ‘Data.IntMap’
It is a member of the hidden package ‘containers-0.5.7.1’.
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/package/package06e.stderr b/testsuite/tests/package/package06e.stderr
index 1cb27e342c..c634d2d46c 100644
--- a/testsuite/tests/package/package06e.stderr
+++ b/testsuite/tests/package/package06e.stderr
@@ -1,10 +1,10 @@
-package06e.hs:2:1:
- Failed to load interface for ‘HsTypes’
- It is a member of the hidden package ‘ghc-<VERSION>’.
+package06e.hs:2:1: error:
+ Could not find module ‘HsTypes’
+ It is a member of the hidden package ‘ghc-8.1’.
Use -v to see a list of the files searched for.
-package06e.hs:3:1:
- Failed to load interface for ‘UniqFM’
- It is a member of the hidden package ‘ghc-<VERSION>’.
+package06e.hs:3:1: error:
+ Could not find module ‘UniqFM’
+ It is a member of the hidden package ‘ghc-8.1’.
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr
index 8de07f99b2..a446a47247 100644
--- a/testsuite/tests/package/package07e.stderr
+++ b/testsuite/tests/package/package07e.stderr
@@ -1,16 +1,16 @@
package07e.hs:2:1: error:
- Failed to load interface for ‘MyHsTypes’
+ Could not find module ‘MyHsTypes’
Use -v to see a list of the files searched for.
package07e.hs:3:1: error:
- Failed to load interface for ‘HsTypes’
+ Could not find module ‘HsTypes’
Use -v to see a list of the files searched for.
package07e.hs:4:1: error:
- Failed to load interface for ‘HsUtils’
+ Could not find module ‘HsUtils’
Use -v to see a list of the files searched for.
package07e.hs:5:1: error:
- Failed to load interface for ‘UniqFM’
+ Could not find module ‘UniqFM’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr
index c5017350f0..3d8d2321b7 100644
--- a/testsuite/tests/package/package08e.stderr
+++ b/testsuite/tests/package/package08e.stderr
@@ -1,16 +1,16 @@
package08e.hs:2:1: error:
- Failed to load interface for ‘MyHsTypes’
+ Could not find module ‘MyHsTypes’
Use -v to see a list of the files searched for.
package08e.hs:3:1: error:
- Failed to load interface for ‘HsTypes’
+ Could not find module ‘HsTypes’
Use -v to see a list of the files searched for.
package08e.hs:4:1: error:
- Failed to load interface for ‘HsUtils’
+ Could not find module ‘HsUtils’
Use -v to see a list of the files searched for.
package08e.hs:5:1: error:
- Failed to load interface for ‘UniqFM’
+ Could not find module ‘UniqFM’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr
index 9cd00a2930..3ce28df519 100644
--- a/testsuite/tests/package/package09e.stderr
+++ b/testsuite/tests/package/package09e.stderr
@@ -1,5 +1,5 @@
-package09e.hs:2:1:
- Ambiguous interface for ‘M’:
+package09e.hs:2:1: error:
+ Ambiguous module name ‘M’:
it is bound as Data.Set by a package flag
it is bound as Data.Map by a package flag
diff --git a/testsuite/tests/perf/compiler/parsing001.stderr b/testsuite/tests/perf/compiler/parsing001.stderr
index 0f86f7f994..d24d77539b 100644
--- a/testsuite/tests/perf/compiler/parsing001.stderr
+++ b/testsuite/tests/perf/compiler/parsing001.stderr
@@ -1,4 +1,4 @@
-parsing001.hs:3:1:
- Failed to load interface for ‘Wibble’
+parsing001.hs:3:1: error:
+ Could not find module ‘Wibble’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
index 276c723203..d32906e4e5 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
@@ -1,7 +1,7 @@
-SafeLang07.hs:2:14: Warning:
+SafeLang07.hs:2:14: warning:
-XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
-SafeLang07.hs:15:1:
- Failed to load interface for ‘SafeLang07_A’
+SafeLang07.hs:15:1: error:
+ Could not find module ‘SafeLang07_A’
Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr
index 21688ae836..0d23a80877 100644
--- a/testsuite/tests/th/T10279.stderr
+++ b/testsuite/tests/th/T10279.stderr
@@ -1,8 +1,8 @@
T10279.hs:10:10: error:
- Failed to load interface for ‘A’
- no unit id matching ‘rts-1.0’ was found
- (This unit ID looks like the source package ID;
- the real unit ID is ‘rts’)
- In the expression: (rts-1.0:A.Foo)
- In an equation for ‘blah’: blah = (rts-1.0:A.Foo)
+ • Failed to load interface for ‘A’
+ no unit id matching ‘rts-1.0’ was found
+ (This unit ID looks like the source package ID;
+ the real unit ID is ‘rts’)
+ • In the expression: (rts-1.0:A.Foo)
+ In an equation for ‘blah’: blah = (rts-1.0:A.Foo)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail082.stderr b/testsuite/tests/typecheck/should_fail/tcfail082.stderr
index 4e3d6ce996..841b5c82f6 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail082.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail082.stderr
@@ -1,12 +1,12 @@
-tcfail082.hs:2:1:
- Failed to load interface for ‘Data82’
+tcfail082.hs:2:1: error:
+ Could not find module ‘Data82’
Use -v to see a list of the files searched for.
-tcfail082.hs:3:1:
- Failed to load interface for ‘Inst82_1’
+tcfail082.hs:3:1: error:
+ Could not find module ‘Inst82_1’
Use -v to see a list of the files searched for.
-tcfail082.hs:4:1:
- Failed to load interface for ‘Inst82_2’
+tcfail082.hs:4:1: error:
+ Could not find module ‘Inst82_2’
Use -v to see a list of the files searched for.
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 4a72ba7cc6..c0474423de 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1119,6 +1119,7 @@ convertPackageInfoToCacheFormat pkg =
GhcPkg.haddockHTMLs = haddockHTMLs pkg,
GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
GhcPkg.hiddenModules = hiddenModules pkg,
+ GhcPkg.indefinite = indefinite pkg,
GhcPkg.exposed = exposed pkg,
GhcPkg.trusted = trusted pkg
}
@@ -1156,9 +1157,12 @@ instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule w
toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
- fromDbUnitId (GhcPkg.DbHashedUnitId cid bs) = DefiniteUnitId (DefUnitId (UnitId cid (fmap fromStringRep bs)))
+ fromDbUnitId (GhcPkg.DbInstalledUnitId cid bs)
+ = DefiniteUnitId (unsafeMkDefUnitId (UnitId cid (fmap fromStringRep bs)))
toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
- toDbUnitId (DefiniteUnitId (DefUnitId (UnitId cid mb_hash))) = GhcPkg.DbHashedUnitId cid (fmap toStringRep mb_hash)
+ toDbUnitId (DefiniteUnitId def_uid)
+ | UnitId cid mb_hash <- unDefUnitId def_uid
+ = GhcPkg.DbInstalledUnitId cid (fmap toStringRep mb_hash)
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
@@ -1809,8 +1813,9 @@ checkModule :: String
-> Validate ()
checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport"
checkModule field_name db_stack pkg
- (OpenModule (DefiniteUnitId (DefUnitId definingPkgId)) definingModule) =
- let mpkg = if definingPkgId == installedUnitId pkg
+ (OpenModule (DefiniteUnitId def_uid) definingModule) =
+ let definingPkgId = unDefUnitId def_uid
+ mpkg = if definingPkgId == installedUnitId pkg
then Just pkg
else PackageIndex.lookupUnitId ipix definingPkgId
in case mpkg of