summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/backpack/DriverBkp.hs27
-rw-r--r--compiler/basicTypes/Module.hs235
-rw-r--r--compiler/basicTypes/Module.hs-boot1
-rw-r--r--compiler/iface/LoadIface.hs7
-rw-r--r--compiler/main/DynFlags.hs72
-rw-r--r--compiler/main/Finder.hs2
-rw-r--r--compiler/main/GhcMake.hs4
-rw-r--r--compiler/main/HscTypes.hs7
-rw-r--r--compiler/main/PackageConfig.hs5
-rw-r--r--compiler/main/Packages.hs42
-rw-r--r--compiler/main/Packages.hs-boot3
-rw-r--r--compiler/typecheck/TcBackpack.hs25
m---------libraries/Cabal0
-rw-r--r--libraries/ghc-boot/GHC/PackageDb.hs56
-rw-r--r--utils/ghc-pkg/Main.hs17
15 files changed, 250 insertions, 253 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 53a7e85812..7b35b0c0cd 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -155,13 +155,14 @@ withBkpSession cid insts deps session_type do_this = do
hscTarget = case session_type of
TcSession -> HscNothing
_ -> hscTarget dflags,
- thisUnitIdInsts = insts,
- thisPackage =
+ thisUnitIdInsts_ = Just insts,
+ thisComponentId_ = Just cid,
+ thisInstalledUnitId =
case session_type of
- TcSession -> newUnitId cid insts
+ TcSession -> newInstalledUnitId cid Nothing
-- No hash passed if no instances
- _ | null insts -> newSimpleUnitId cid
- | otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
+ _ | null insts -> newInstalledUnitId cid Nothing
+ | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
-- Setup all of the output directories according to our hierarchy
objectDir = Just (outdir objectDir),
hiDir = Just (outdir hiDir),
@@ -186,7 +187,7 @@ withBkpSession cid insts deps session_type do_this = do
withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession deps do_this = do
- withBkpSession (unitIdComponentId mainUnitId) [] deps ExeSession do_this
+ withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource cid = do
@@ -282,6 +283,7 @@ buildUnit session cid insts lunit = do
packageName = compat_pn,
packageVersion = makeVersion [0],
unitId = toInstalledUnitId (thisPackage dflags),
+ componentId = cid,
instantiatedWith = insts,
-- Slight inefficiency here haha
exposedModules = map (\(m,n) -> (m,Just n)) mods,
@@ -366,8 +368,9 @@ compileInclude n (i, uid) = do
case lookupPackage dflags uid of
Nothing -> do
case splitUnitIdInsts uid of
- (_, Just insts) ->
- innerBkpM $ compileUnit (unitIdComponentId uid) insts
+ (_, Just indef) ->
+ innerBkpM $ compileUnit (indefUnitIdComponentId indef)
+ (indefUnitIdInsts indef)
_ -> return ()
Just _ -> return ()
@@ -778,3 +781,11 @@ hsModuleToModSummary pn hsc_src modname
ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
ms_iface_date = hi_timestamp
}
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId (ComponentId cid_fs) (Just fs)
+ = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId (ComponentId cid_fs) Nothing
+ = InstalledUnitId cid_fs
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index fd12c2bb2f..98c30a9eb4 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -11,7 +11,6 @@ the keys.
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Module
(
@@ -33,8 +32,8 @@ module Module
UnitId(..),
unitIdFS,
unitIdKey,
- unitIdComponentId,
IndefUnitId(..),
+ IndefModule(..),
InstalledUnitId(..),
toInstalledUnitId,
ShHoleSubst,
@@ -46,7 +45,6 @@ module Module
newUnitId,
newIndefUnitId,
newSimpleUnitId,
- newDefiniteUnitId,
hashUnitId,
fsToUnitId,
stringToUnitId,
@@ -101,8 +99,8 @@ module Module
installedModuleEq,
installedUnitIdEq,
installedUnitIdString,
- newInstalledUnitId,
fsToInstalledUnitId,
+ componentIdToInstalledUnitId,
stringToInstalledUnitId,
emptyInstalledModuleEnv,
lookupInstalledModuleEnv,
@@ -111,9 +109,6 @@ module Module
delInstalledModuleEnv,
DefUnitId(..),
- -- * Hole module
- HoleModule,
-
-- * The ModuleLocation type
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
@@ -172,7 +167,7 @@ import qualified FiniteMap as Map
import System.FilePath
import {-# SOURCE #-} DynFlags (DynFlags)
-import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap)
+import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)
-- Note [The identifier lexicon]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -482,13 +477,11 @@ class ContainsModule t where
class HasModule m where
getModule :: m Module
-instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where
- fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
- fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
- fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts })
- = newUnitId cid insts
- fromDbUnitId (DbInstalledUnitId cid hash) -- TODO rename this
- = newDefiniteUnitId cid (fmap mkFastStringByteString hash)
+instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
+ fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
+ fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
+ fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts
+ fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
-- GHC never writes to the database, so it's not needed
toDbModule = error "toDbModule: not implemented"
toDbUnitId = error "toDbUnitId: not implemented"
@@ -560,10 +553,6 @@ unitIdKey :: UnitId -> Unique
unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
-unitIdComponentId :: UnitId -> ComponentId
-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
@@ -600,6 +589,45 @@ instance Eq IndefUnitId where
instance Ord IndefUnitId where
u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
+instance Binary IndefUnitId where
+ put_ bh indef = do
+ put_ bh (indefUnitIdComponentId indef)
+ put_ bh (indefUnitIdInsts indef)
+ get bh = do
+ cid <- get bh
+ insts <- get bh
+ let fs = hashUnitId cid insts
+ return IndefUnitId {
+ indefUnitIdComponentId = cid,
+ indefUnitIdInsts = insts,
+ indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ indefUnitIdFS = fs,
+ indefUnitIdKey = getUnique fs
+ }
+
+-- | Create a new 'IndefUnitId' given an explicit module substitution.
+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
+newIndefUnitId cid insts =
+ IndefUnitId {
+ indefUnitIdComponentId = cid,
+ indefUnitIdInsts = sorted_insts,
+ indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ indefUnitIdFS = fs,
+ indefUnitIdKey = getUnique fs
+ }
+ where
+ fs = hashUnitId cid sorted_insts
+ sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
+
+data IndefModule = IndefModule {
+ indefModuleUnitId :: IndefUnitId,
+ indefModuleName :: ModuleName
+ } deriving (Typeable, Eq, Ord)
+
+instance Outputable IndefModule where
+ ppr (IndefModule uid m) =
+ ppr uid <> char ':' <> ppr m
+
-- | 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
@@ -610,47 +638,20 @@ instance Ord IndefUnitId where
--
-- Installed unit identifiers look something like @p+af23SAj2dZ219@,
-- or maybe just @p@ if they don't use Backpack.
-data InstalledUnitId =
+newtype InstalledUnitId =
InstalledUnitId {
-- | The full hashed unit identifier, including the component id
-- and the hash.
- installedUnitIdFS :: FastString,
- -- | Cached unique of 'unitIdFS'.
- installedUnitIdKey :: Unique,
- -- | The component identifier of the hashed unit identifier.
- installedUnitIdComponentId :: !ComponentId
+ installedUnitIdFS :: FastString
}
deriving (Typeable)
--- | 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 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)
+ put_ bh (InstalledUnitId fs) = put_ bh fs
+ get bh = do fs <- get bh; return (InstalledUnitId fs)
instance BinaryStringRep InstalledUnitId where
- fromStringRep bs = rawNewInstalledUnitId (fromStringRep cid) (mkFastStringByteString bs)
- where cid = BS.Char8.takeWhile (/='+') bs
+ fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
-- GHC doesn't write to database
toStringRep = error "BinaryStringRep InstalledUnitId: not implemented"
@@ -664,16 +665,21 @@ instance Uniquable InstalledUnitId where
getUnique = installedUnitIdKey
instance Outputable InstalledUnitId where
- ppr uid =
- if installedUnitIdComponentId uid == ComponentId (installedUnitIdFS uid)
- then ppr (installedUnitIdComponentId uid)
- else ftext (installedUnitIdFS uid)
+ ppr uid@(InstalledUnitId fs) =
+ getPprStyle $ \sty ->
+ sdocWithDynFlags $ \dflags ->
+ case displayInstalledUnitId dflags uid of
+ Just str | not (debugStyle sty) -> text str
+ _ -> ftext fs
+
+installedUnitIdKey :: InstalledUnitId -> Unique
+installedUnitIdKey = getUnique . installedUnitIdFS
-- | 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
+ componentIdToInstalledUnitId (indefUnitIdComponentId indef)
installedUnitIdString :: InstalledUnitId -> String
installedUnitIdString = unpackFS . installedUnitIdFS
@@ -716,7 +722,10 @@ instance Outputable InstalledModule where
ppr p <> char ':' <> pprModuleName n
fsToInstalledUnitId :: FastString -> InstalledUnitId
-fsToInstalledUnitId fs = rawNewInstalledUnitId (ComponentId fs) fs
+fsToInstalledUnitId fs = InstalledUnitId fs
+
+componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
+componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
stringToInstalledUnitId :: String -> InstalledUnitId
stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
@@ -733,6 +742,19 @@ installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
installedUnitIdEq iuid uid =
fst (splitUnitIdInsts uid) == iuid
+-- | 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, Typeable)
+
+instance Outputable DefUnitId where
+ ppr (DefUnitId uid) = ppr uid
+
+instance Binary DefUnitId where
+ put_ bh (DefUnitId uid) = put_ bh uid
+ get bh = do uid <- get bh; return (DefUnitId uid)
+
-- | A map keyed off of 'InstalledModule'
newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
@@ -752,12 +774,6 @@ filterInstalledModuleEnv f (InstalledModuleEnv 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
--- of such a hole module is guaranteed to be equipped with
--- an instantiation.
-type HoleModule = (IndefUnitId, ModuleName)
-
-- Note [UnitId to InstalledUnitId improvement]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Just because a UnitId is definite (has no holes) doesn't
@@ -829,52 +845,11 @@ fingerprintUnitId prefix (Fingerprint a b)
, BS.Char8.pack (toBase62Padded a)
, BS.Char8.pack (toBase62Padded b) ]
--- | Create a new, externally provided hashed unit id from
--- a hash.
-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').
-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 = IndefiniteUnitId $ newIndefUnitId cid insts
--- | Create a new 'IndefUnitId' given an explicit module substitution.
-newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
-newIndefUnitId cid insts =
- IndefUnitId {
- indefUnitIdComponentId = cid,
- indefUnitIdInsts = sorted_insts,
- indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
- indefUnitIdFS = fs,
- indefUnitIdKey = getUnique fs
- }
- where
- fs = hashUnitId cid sorted_insts
- sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
-
pprUnitId :: UnitId -> SDoc
pprUnitId (DefiniteUnitId uid) = ppr uid
pprUnitId (IndefiniteUnitId uid) = ppr uid
@@ -906,35 +881,16 @@ instance Outputable UnitId where
-- Performance: would prefer to have a NameCache like thing
instance Binary UnitId where
- put_ bh (DefiniteUnitId (DefUnitId 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
- put_ bh (IndefiniteUnitId uid) = do
+ put_ bh (DefiniteUnitId def_uid) = do
+ putByte bh 0
+ put_ bh def_uid
+ put_ bh (IndefiniteUnitId indef_uid) = do
putByte bh 1
- put_ bh cid
- put_ bh insts
- where
- cid = indefUnitIdComponentId uid
- insts = indefUnitIdInsts uid
+ put_ bh indef_uid
get bh = do b <- getByte bh
case b of
- 0 -> fmap fsToUnitId (get bh)
- 1 -> do
- cid <- get bh
- insts <- get bh
- return (newUnitId cid insts)
- _ -> do
- cid <- get bh
- fs <- get bh
- return (rawNewDefiniteUnitId cid fs)
+ 0 -> fmap DefiniteUnitId (get bh)
+ _ -> fmap IndefiniteUnitId (get bh)
instance Binary ComponentId where
put_ bh (ComponentId fs) = put_ bh fs
@@ -947,7 +903,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 = rawNewDefiniteUnitId (ComponentId fs) fs
+fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId
stringToUnitId :: String -> UnitId
stringToUnitId = fsToUnitId . mkFastString
@@ -1016,15 +972,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 -> (InstalledModule, Maybe [(ModuleName, Module)])
+splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)
splitModuleInsts m =
- let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m)
- in (InstalledModule uid (moduleName m), mb_insts)
+ let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)
+ in (InstalledModule uid (moduleName m),
+ fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)
-- | See 'splitModuleInsts'.
-splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe [(ModuleName, Module)])
+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts (IndefiniteUnitId iuid) =
- (newInstalledUnitId (indefUnitIdComponentId iuid) Nothing, Just (indefUnitIdInsts iuid))
+ (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)
splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
@@ -1044,10 +1001,8 @@ parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
insts <- parseModSubst
return (newUnitId cid insts)
parseDefiniteUnitId = do
- cid <- parseComponentId
- _ <- Parse.char '+'
- hash <- Parse.munch1 isAlphaNum
- return (newDefiniteUnitId cid (Just (mkFastString hash)))
+ s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
+ return (stringToUnitId s)
parseSimpleUnitId = do
cid <- parseComponentId
return (newSimpleUnitId cid)
diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot
index 4cb35caa2f..734855a880 100644
--- a/compiler/basicTypes/Module.hs-boot
+++ b/compiler/basicTypes/Module.hs-boot
@@ -4,6 +4,7 @@ import FastString
data Module
data ModuleName
data UnitId
+data InstalledUnitId
newtype ComponentId = ComponentId FastString
moduleName :: Module -> ModuleName
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index ca11c6f59b..6005ba5053 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -533,12 +533,12 @@ computeInterface doc_str hi_boot_file mod0 = do
MASSERT( not (isHoleModule mod0) )
dflags <- getDynFlags
case splitModuleInsts mod0 of
- (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+ (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
r <- findAndReadIface doc_str imod hi_boot_file
case r of
Succeeded (iface0, path) -> do
hsc_env <- getTopEnv
- r <- liftIO (rnModIface hsc_env insts Nothing iface0)
+ r <- liftIO (rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) Nothing iface0)
return (Succeeded (r, path))
Failed err -> return (Failed err)
(mod, _) ->
@@ -560,7 +560,8 @@ moduleFreeHolesPrecise doc_str mod
| moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
| otherwise =
case splitModuleInsts mod of
- (imod, Just insts) -> do
+ (imod, Just indef) -> do
+ let insts = indefUnitIdInsts (indefModuleUnitId indef)
traceIf (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
(eps, hpt) <- getEpsAndHpt
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 69fb8b814d..cb2866442e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -54,11 +54,12 @@ module DynFlags (
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
- thisUnitIdComponentId,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
+ thisPackage, thisComponentId, thisUnitIdInsts,
+
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
@@ -688,9 +689,9 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
- thisPackage :: UnitId, -- ^ unit id of package currently being compiled.
- -- Not properly initialized until initPackages
- thisUnitIdInsts :: [(ModuleName, Module)],
+ thisInstalledUnitId :: InstalledUnitId,
+ thisComponentId_ :: Maybe ComponentId,
+ thisUnitIdInsts_ :: Maybe [(ModuleName, Module)],
-- ways
ways :: [Way], -- ^ Way flags from the command line
@@ -1487,8 +1488,9 @@ defaultDynFlags mySettings =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
- thisPackage = mainUnitId,
- thisUnitIdInsts = [],
+ thisInstalledUnitId = toInstalledUnitId mainUnitId,
+ thisUnitIdInsts_ = Nothing,
+ thisComponentId_ = Nothing,
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -2003,6 +2005,34 @@ setOutputFile f d = d { outputFile = f}
setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f}
+thisComponentId :: DynFlags -> ComponentId
+thisComponentId dflags =
+ case thisComponentId_ dflags of
+ Just cid -> cid
+ Nothing ->
+ case thisUnitIdInsts_ dflags of
+ Just _ ->
+ throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
+ Nothing -> ComponentId (unitIdFS (thisPackage dflags))
+
+thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]
+thisUnitIdInsts dflags =
+ case thisUnitIdInsts_ dflags of
+ Just insts -> insts
+ Nothing -> []
+
+thisPackage :: DynFlags -> UnitId
+thisPackage dflags =
+ case thisUnitIdInsts_ dflags of
+ Nothing -> default_uid
+ Just insts
+ | all (\(x,y) -> mkHoleModule x == y) insts
+ -> newUnitId (thisComponentId dflags) insts
+ | otherwise
+ -> default_uid
+ where
+ default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags))
+
parseUnitIdInsts :: String -> [(ModuleName, Module)]
parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
@@ -2015,17 +2045,12 @@ parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
return (n, m)
setUnitIdInsts :: String -> DynFlags -> DynFlags
-setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
-
-updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
-updateWithInsts insts d =
- -- Overwrite the instances, the instances are "indefinite"
- d { thisPackage =
- if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
- then newUnitId (unitIdComponentId (thisPackage d)) insts
- else thisPackage d
- , thisUnitIdInsts = insts
- }
+setUnitIdInsts s d =
+ d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) }
+
+setComponentId :: String -> DynFlags -> DynFlags
+setComponentId s d =
+ d { thisComponentId_ = Just (ComponentId (fsLit s)) }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
@@ -2368,6 +2393,7 @@ dynamic_flags_deps = [
-- parallel builds is equal to the
-- result of getNumProcessors
, make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts)
+ , make_ord_flag defFlag "this-component-id" (sepArg setComponentId)
-- RTS options -------------------------------------------------------------
, make_ord_flag defFlag "H" (HasArg (\s -> upd (\d ->
@@ -4357,18 +4383,8 @@ parseUnitIdArg :: ReadP PackageArg
parseUnitIdArg =
fmap UnitIdArg parseUnitId
-
-thisUnitIdComponentId :: DynFlags -> ComponentId
-thisUnitIdComponentId = unitIdComponentId . thisPackage
-
setUnitId :: String -> DynFlags -> DynFlags
-setUnitId p d =
- updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
- where
- uid =
- case filter ((=="").snd) (readP_to_S parseUnitId p) of
- [(r, "")] -> r
- _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
+setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p }
-- | Given a 'ModuleName' of a signature in the home library, find
-- out how it is instantiated. E.g., the canonical form of
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 2bcdd3360c..d1bf1c8073 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -335,7 +335,7 @@ findPackageModule hsc_env mod = do
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
- ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf )
+ ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0921a58531..cd9fb15ae4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1264,7 +1264,9 @@ unitIdsToCheck dflags =
where
goUnitId uid =
case splitUnitIdInsts uid of
- (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
+ (_, Just indef) ->
+ let insts = indefUnitIdInsts indef
+ in uid : concatMap (goUnitId . moduleUnitId . snd) insts
_ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 1320a57e9a..7a585f3bba 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -959,10 +959,10 @@ mi_semantic_module iface = case mi_sig_of iface of
mi_free_holes :: ModIface -> UniqDSet ModuleName
mi_free_holes iface =
case splitModuleInsts (mi_module iface) of
- (_, Just insts)
+ (_, Just indef)
-- A mini-hack: we rely on the fact that 'renameFreeHoles'
-- drops things that aren't holes.
- -> renameFreeHoles (mkUniqDSet cands) insts
+ -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef))
_ -> emptyUniqDSet
where
cands = map fst (dep_mods (mi_deps iface))
@@ -1596,7 +1596,8 @@ extendInteractiveContextWithIds ictxt new_ids
setInteractivePackage :: HscEnv -> HscEnv
-- Set the 'thisPackage' DynFlag to 'interactive'
setInteractivePackage hsc_env
- = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactiveUnitId } }
+ = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
+ { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 6e3e2f1c9b..bff8cc3aa3 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -37,7 +37,6 @@ import FastString
import Outputable
import Module
import Unique
-import UniqDSet
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
@@ -138,12 +137,12 @@ installedPackageConfigId = unitId
packageConfigId :: PackageConfig -> UnitId
packageConfigId p =
if indefinite p
- then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+ then newUnitId (componentId p) (instantiatedWith p)
else DefiniteUnitId (DefUnitId (unitId p))
expandedPackageConfigId :: PackageConfig -> UnitId
expandedPackageConfigId p =
- newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+ newUnitId (componentId p) (instantiatedWith p)
definitePackageConfigId :: PackageConfig -> Maybe DefUnitId
definitePackageConfigId p =
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 566d998899..e0563da10c 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -27,6 +27,7 @@ module Packages (
getPackageDetails,
getInstalledPackageDetails,
componentIdString,
+ displayInstalledUnitId,
listVisibleModuleNames,
lookupModuleInAllPackages,
lookupModuleWithSuggestions,
@@ -268,7 +269,7 @@ data UnitVisibility = UnitVisibility
-- ^ The package name is associated with the 'UnitId'. This is used
-- to implement legacy behavior where @-package foo-0.1@ implicitly
-- hides any packages named @foo@
- , uv_requirements :: Map ModuleName (Set HoleModule)
+ , uv_requirements :: Map ModuleName (Set IndefModule)
-- ^ The signatures which are contributed to the requirements context
-- from this unit ID.
, uv_explicit :: Bool
@@ -351,7 +352,7 @@ data PackageState = PackageState {
-- and @r[C=<A>]:C@.
--
-- There's an entry in this map for each hole in our home library.
- requirementContext :: Map ModuleName [HoleModule]
+ requirementContext :: Map ModuleName [IndefModule]
}
emptyPackageState :: PackageState
@@ -384,8 +385,8 @@ lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
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 m insts)
+ (iuid, Just indef) ->
+ fmap (renamePackage m (indefUnitIdInsts indef))
(lookupUDFM pkg_map iuid)
(_, Nothing) -> lookupUDFM pkg_map uid
@@ -689,15 +690,14 @@ applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
| otherwise = Map.empty
collectHoles uid = case splitUnitIdInsts uid of
- (_, Just insts) ->
- let cid = unitIdComponentId uid
- local = [ Map.singleton
+ (_, Just indef) ->
+ let local = [ Map.singleton
(moduleName mod)
- (Set.singleton $ (newIndefUnitId cid insts, mod_name))
- | (mod_name, mod) <- insts
+ (Set.singleton $ IndefModule indef mod_name)
+ | (mod_name, mod) <- indefUnitIdInsts indef
, isHoleModule mod ]
recurse = [ collectHoles (moduleUnitId mod)
- | (_, mod) <- insts ]
+ | (_, mod) <- indefUnitIdInsts indef ]
in Map.unionsWith Set.union $ local ++ recurse
-- Other types of unit identities don't have holes
(_, Nothing) -> Map.empty
@@ -764,11 +764,11 @@ findPackages pkg_db arg pkgs unusable
then Just p
else Nothing
finder (UnitIdArg uid) p
- = let (iuid, mb_insts) = splitUnitIdInsts uid
+ = let (iuid, mb_indef) = splitUnitIdInsts uid
in if iuid == installedPackageConfigId p
- then Just (case mb_insts of
+ then Just (case mb_indef of
Nothing -> p
- Just insts -> renamePackage pkg_db insts p)
+ Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
else Nothing
selectPackages :: PackageArg -> [PackageConfig]
@@ -968,9 +968,10 @@ findWiredInPackages dflags pkgs vis_map = do
where upd_pkg pkg
| Just def_uid <- definitePackageConfigId pkg
, def_uid `elem` wired_in_ids
- = pkg {
- unitId = let PackageName fs = packageName pkg
- in fsToInstalledUnitId fs
+ = let PackageName fs = packageName pkg
+ in pkg {
+ unitId = fsToInstalledUnitId fs,
+ componentId = ComponentId fs
}
| otherwise
= pkg
@@ -1313,7 +1314,7 @@ mkPackageState dflags dbs preload0 = do
let pkgname_map = foldl add Map.empty pkgs2
where add pn_map p
- = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map
+ = Map.insert (packageName p) (componentId p) pn_map
-- The explicitPackages accurately reflects the set of packages we have turned
-- on; as such, it also is the only way one can come up with requirements.
@@ -1713,7 +1714,12 @@ missingDependencyMsg (Just parent)
componentIdString :: DynFlags -> ComponentId -> Maybe String
componentIdString dflags cid =
- fmap sourcePackageIdString (lookupInstalledPackage dflags (newInstalledUnitId cid Nothing))
+ fmap sourcePackageIdString (lookupInstalledPackage dflags
+ (componentIdToInstalledUnitId cid))
+
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
+displayInstalledUnitId dflags uid =
+ fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> UnitId {- not used -} -> Module -> Name -> Bool
diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot
index c05d392ce1..0ed59db92b 100644
--- a/compiler/main/Packages.hs-boot
+++ b/compiler/main/Packages.hs-boot
@@ -1,9 +1,10 @@
module Packages where
import {-# SOURCE #-} DynFlags(DynFlags)
-import {-# SOURCE #-} Module(ComponentId, UnitId)
+import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)
data PackageState
data PackageConfigMap
emptyPackageState :: PackageState
componentIdString :: DynFlags -> ComponentId -> Maybe String
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
getPackageConfigMap :: DynFlags -> PackageConfigMap
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index 9b4f77472d..afa2e50b60 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -190,7 +190,7 @@ check_inst sig_inst = do
-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
-requirementMerges :: DynFlags -> ModuleName -> [HoleModule]
+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
requirementMerges dflags mod_name =
fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
@@ -219,7 +219,7 @@ findExtraSigImports' :: HscEnv
-> ModuleName
-> IO (UniqDSet ModuleName)
findExtraSigImports' hsc_env HsigFile modname =
- fmap unionManyUniqDSets (forM reqs $ \(iuid, mod_name) ->
+ fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
(initIfaceLoad hsc_env
. withException
$ moduleFreeHolesPrecise (text "findExtraSigImports")
@@ -273,7 +273,8 @@ implicitRequirements' hsc_env normal_imports
checkUnitId :: UnitId -> TcM ()
checkUnitId uid = do
case splitUnitIdInsts uid of
- (_, Just insts) ->
+ (_, Just indef) ->
+ let insts = indefUnitIdInsts indef in
forM_ insts $ \(mod_name, mod) ->
-- NB: direct hole instantiations are well-typed by construction
-- (because we FORCE things to be merged in), so don't check them
@@ -282,7 +283,7 @@ checkUnitId uid = do
_ <- addErrCtxt (text "while checking that" <+> ppr mod
<+> text "implements signature" <+> ppr mod_name <+> text "in"
<+> ppr uid) $
- mod `checkImplements` (newIndefUnitId (unitIdComponentId uid) insts, mod_name)
+ mod `checkImplements` IndefModule indef mod_name
return ()
_ -> return () -- if it's hashed, must be well-typed
@@ -350,7 +351,7 @@ mergeSignatures lcl_iface0 = do
let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env))
-- STEP 2: Read in the RAW forms of all of these interfaces
- ireq_ifaces <- forM reqs $ \(iuid, mod_name) ->
+ ireq_ifaces <- forM reqs $ \(IndefModule iuid mod_name) ->
fmap fst
. withException
. flip (findAndReadIface (text "mergeSignatures")) False
@@ -359,7 +360,7 @@ mergeSignatures lcl_iface0 = do
-- STEP 3: Get the unrenamed exports of all these interfaces, and
-- dO shaping on them.
let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
- gen_subst nsubst ((iuid, _), ireq_iface) = do
+ gen_subst nsubst ((IndefModule iuid _), ireq_iface) = do
let insts = indefUnitIdInsts iuid
as1 <- liftIO $ rnModExports hsc_env insts ireq_iface
mb_r <- extend_ns nsubst as1
@@ -376,7 +377,7 @@ mergeSignatures lcl_iface0 = do
}
-- STEP 4: Rename the interfaces
- ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((iuid, _), ireq_iface) ->
+ ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((IndefModule iuid _), ireq_iface) ->
liftIO (rnModIface hsc_env (indefUnitIdInsts iuid) (Just nsubst) ireq_iface)
lcl_iface <- liftIO $ rnModIface hsc_env (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
let ifaces = lcl_iface : ext_ifaces
@@ -474,8 +475,8 @@ tcRnInstantiateSignature hsc_env this_mod real_loc =
-- | Check if module implements a signature. (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
-checkImplements :: Module -> HoleModule -> TcRn TcGblEnv
-checkImplements impl_mod (uid, mod_name) = do
+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
+checkImplements impl_mod (IndefModule uid mod_name) = do
let insts = indefUnitIdInsts uid
-- STEP 1: Load the implementing interface, and make a RdrEnv
@@ -545,5 +546,7 @@ instantiateSignature = do
-- the local one just to get the information? Hmm...
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
inner_mod `checkImplements`
- (newIndefUnitId (thisUnitIdComponentId dflags)
- (thisUnitIdInsts dflags), moduleName outer_mod)
+ IndefModule
+ (newIndefUnitId (thisComponentId dflags)
+ (thisUnitIdInsts dflags))
+ (moduleName outer_mod)
diff --git a/libraries/Cabal b/libraries/Cabal
-Subproject 8fa4d2ea2be385e715a10c77d6381d78e1421f7
+Subproject 579fd676a6f066775dcce9427c8463d0dbae101
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index eda1a696ca..f0333d4333 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -71,6 +71,7 @@ import System.Directory
data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
= InstalledPackageInfo {
unitId :: instunitid,
+ componentId :: compid,
instantiatedWith :: [(modulename, mod)],
sourcePackageId :: srcpkgid,
packageName :: srcpkgname,
@@ -104,24 +105,25 @@ type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid module
(BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
BinaryStringRep modulename, BinaryStringRep compid,
BinaryStringRep instunitid,
- DbUnitIdModuleRep compid unitid modulename mod)
+ DbUnitIdModuleRep instunitid compid unitid modulename mod)
-- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.
-- There is only one type class because these types are mutually recursive.
-- NB: The functional dependency helps out type inference in cases
-- where types would be ambiguous.
-class DbUnitIdModuleRep compid unitid modulename mod
- | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid where
- fromDbModule :: DbModule compid unitid modulename mod -> mod
- toDbModule :: mod -> DbModule compid unitid modulename mod
- fromDbUnitId :: DbUnitId compid unitid modulename mod -> unitid
- toDbUnitId :: unitid -> DbUnitId compid unitid modulename mod
+class DbUnitIdModuleRep instunitid compid unitid modulename mod
+ | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid
+ where
+ fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod
+ toDbModule :: mod -> DbModule instunitid compid unitid modulename mod
+ fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid
+ toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod
-- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
-- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.
-- It has phantom type parameters as this is the most convenient way
-- to avoid undecidable instances.
-data DbModule compid unitid modulename mod
+data DbModule instunitid compid unitid modulename mod
= DbModule {
dbModuleUnitId :: unitid,
dbModuleName :: modulename
@@ -135,15 +137,9 @@ data DbModule compid unitid modulename mod
-- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.
-- It has phantom type parameters as this is the most convenient way
-- to avoid undecidable instances.
-data DbUnitId compid unitid modulename mod
- = DbUnitId {
- dbUnitIdComponentId :: compid,
- dbUnitIdInsts :: [(modulename, mod)]
- }
- | DbInstalledUnitId {
- dbUnitIdComponentId :: compid,
- dbUnitIdHash :: Maybe BS.ByteString
- }
+data DbUnitId instunitid compid unitid modulename mod
+ = DbUnitId compid [(modulename, mod)]
+ | DbInstalledUnitId instunitid
deriving (Eq, Show)
class BinaryStringRep a where
@@ -155,6 +151,7 @@ emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g
emptyInstalledPackageInfo =
InstalledPackageInfo {
unitId = fromStringRep BS.empty,
+ componentId = fromStringRep BS.empty,
instantiatedWith = [],
sourcePackageId = fromStringRep BS.empty,
packageName = fromStringRep BS.empty,
@@ -306,7 +303,7 @@ writeFileAtomic targetPath content = do
instance (RepInstalledPackageInfo a b c d e f g) =>
Binary (InstalledPackageInfo a b c d e f g) where
put (InstalledPackageInfo
- unitId instantiatedWith sourcePackageId
+ unitId componentId instantiatedWith sourcePackageId
packageName packageVersion
abiHash depends importDirs
hsLibraries extraLibraries extraGHCiLibraries libraryDirs
@@ -320,6 +317,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
put (toStringRep packageName)
put packageVersion
put (toStringRep unitId)
+ put (toStringRep componentId)
put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
instantiatedWith)
put abiHash
@@ -349,6 +347,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
packageName <- get
packageVersion <- get
unitId <- get
+ componentId <- get
instantiatedWith <- get
abiHash <- get
depends <- get
@@ -372,6 +371,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
trusted <- get
return (InstalledPackageInfo
(fromStringRep unitId)
+ (fromStringRep componentId)
(map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
instantiatedWith)
(fromStringRep sourcePackageId)
@@ -391,8 +391,9 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
indefinite exposed trusted)
instance (BinaryStringRep modulename, BinaryStringRep compid,
- DbUnitIdModuleRep compid unitid modulename mod) =>
- Binary (DbModule compid unitid modulename mod) where
+ BinaryStringRep instunitid,
+ DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
+ Binary (DbModule instunitid compid unitid modulename mod) where
put (DbModule dbModuleUnitId dbModuleName) = do
putWord8 0
put (toDbUnitId dbModuleUnitId)
@@ -411,12 +412,12 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
return (DbModuleVar (fromStringRep dbModuleVarName))
instance (BinaryStringRep modulename, BinaryStringRep compid,
- DbUnitIdModuleRep compid unitid modulename mod) =>
- Binary (DbUnitId compid unitid modulename mod) where
- put (DbInstalledUnitId cid hash) = do
+ BinaryStringRep instunitid,
+ DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
+ Binary (DbUnitId instunitid compid unitid modulename mod) where
+ put (DbInstalledUnitId instunitid) = do
putWord8 0
- put (toStringRep cid)
- put hash
+ put (toStringRep instunitid)
put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
putWord8 1
put (toStringRep dbUnitIdComponentId)
@@ -425,9 +426,8 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
b <- getWord8
case b of
0 -> do
- cid <- get
- hash <- get
- return (DbInstalledUnitId (fromStringRep cid) hash)
+ instunitid <- get
+ return (DbInstalledUnitId (fromStringRep instunitid))
_ -> do
dbUnitIdComponentId <- get
dbUnitIdInsts <- get
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index c0474423de..4466f58878 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -998,7 +998,9 @@ registerPackage input verbosity my_flags multi_instance
removes = [ RemovePackage p
| not multi_instance,
p <- packages db_to_operate_on,
- sourcePackageId p == sourcePackageId pkg ]
+ sourcePackageId p == sourcePackageId pkg,
+ -- Only remove things that were instantiated the same way!
+ instantiatedWith p == instantiatedWith pkg ]
--
changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
@@ -1098,6 +1100,7 @@ convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
convertPackageInfoToCacheFormat pkg =
GhcPkg.InstalledPackageInfo {
GhcPkg.unitId = installedUnitId pkg,
+ GhcPkg.componentId = installedComponentId pkg,
GhcPkg.instantiatedWith = instantiatedWith pkg,
GhcPkg.sourcePackageId = sourcePackageId pkg,
GhcPkg.packageName = packageName pkg,
@@ -1147,22 +1150,20 @@ instance GhcPkg.BinaryStringRep String where
toStringRep = BS.pack . toUTF8
instance GhcPkg.BinaryStringRep UnitId where
- fromStringRep = fromMaybe (error "BinaryStringRep UnitId")
- . simpleParse . fromStringRep
+ fromStringRep = mkUnitId . fromStringRep
toStringRep = toStringRep . display
-instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule where
+instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where
fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
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.DbInstalledUnitId cid bs)
- = DefiniteUnitId (unsafeMkDefUnitId (UnitId cid (fmap fromStringRep bs)))
+ fromDbUnitId (GhcPkg.DbInstalledUnitId uid)
+ = DefiniteUnitId (unsafeMkDefUnitId uid)
toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
toDbUnitId (DefiniteUnitId def_uid)
- | UnitId cid mb_hash <- unDefUnitId def_uid
- = GhcPkg.DbInstalledUnitId cid (fmap toStringRep mb_hash)
+ = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid)
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
View Lorry Controller Status