Commit 5bd8e8d3 authored by Edward Z. Yang's avatar Edward Z. Yang

Make InstalledUnitId be ONLY a FastString.

It turns out that we don't really need to be able to
extract a ComponentId from UnitId, except in one case.
So compress UnitId into a single FastString.

The one case where we do need the ComponentId is when
we are compiling an instantiated version of a package;
we need the ComponentId to look up the indefinite
version of this package from the database.  So now we
just pass it in as an argument -this-component-id.

Also: ghc-pkg now no longer will unregister a package if
you register one with the same package name, if the
instantiations don't match.

Cabal submodule update which tracks the same data type
change.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 4e8a0607
......@@ -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
This diff is collapsed.
......@@ -4,6 +4,7 @@ import FastString
data Module
data ModuleName
data UnitId
data InstalledUnitId
newtype ComponentId = ComponentId FastString
moduleName :: Module -> ModuleName
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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)
......
......@@ -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}
......
......@@ -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 =
......
......@@ -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
......
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
......@@ -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)
Subproject commit 8fa4d2ea2be385e715a10c77d6381d78e1421f7f
Subproject commit 579fd676a6f066775dcce9427c8463d0dbae101f
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment