summaryrefslogtreecommitdiff
path: root/libraries/ghc-boot/GHC/PackageDb.hs
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/ghc-boot/GHC/PackageDb.hs')
-rw-r--r--libraries/ghc-boot/GHC/PackageDb.hs134
1 files changed, 101 insertions, 33 deletions
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index 26bf67f98d..2e51af0dcb 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -39,8 +39,9 @@
module GHC.PackageDb (
InstalledPackageInfo(..),
DbModule(..),
+ DbUnitId(..),
BinaryStringRep(..),
- DbModuleRep(..),
+ DbUnitIdModuleRep(..),
emptyInstalledPackageInfo,
readPackageDbForGhc,
readPackageDbForGhcPkg,
@@ -67,14 +68,15 @@ import System.Directory
-- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
-- that GHC is interested in.
--
-data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod
+data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
= InstalledPackageInfo {
- unitId :: unitid,
+ unitId :: instunitid,
+ instantiatedWith :: [(modulename, mod)],
sourcePackageId :: srcpkgid,
packageName :: srcpkgname,
packageVersion :: Version,
abiHash :: String,
- depends :: [unitid],
+ depends :: [instunitid],
importDirs :: [FilePath],
hsLibraries :: [String],
extraLibraries :: [String],
@@ -97,37 +99,62 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod
-- | A convenience constraint synonym for common constraints over parameters
-- to 'InstalledPackageInfo'.
-type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename mod =
+type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod =
(BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
- BinaryStringRep unitid, BinaryStringRep modulename,
- DbModuleRep unitid modulename mod)
+ BinaryStringRep modulename, BinaryStringRep compid,
+ BinaryStringRep instunitid,
+ DbUnitIdModuleRep compid unitid modulename mod)
--- | A type-class for the types which can be converted into 'DbModule'.
+-- | 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 DbModuleRep unitid modulename mod
- | mod -> unitid, unitid -> mod, mod -> modulename where
- fromDbModule :: DbModule unitid modulename -> mod
- toDbModule :: mod -> DbModule unitid modulename
+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
-- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
--- Use 'DbModuleRep' to convert it into an actual 'Module'.
-data DbModule unitid modulename
+-- 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
= DbModule {
dbModuleUnitId :: unitid,
dbModuleName :: modulename
}
+ | DbModuleVar {
+ dbModuleVarName :: modulename
+ }
+ deriving (Eq, Show)
+
+-- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database.
+-- 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)]
+ }
+ | DbHashedUnitId {
+ dbUnitIdComponentId :: compid,
+ dbUnitIdHash :: Maybe BS.ByteString
+ }
deriving (Eq, Show)
class BinaryStringRep a where
fromStringRep :: BS.ByteString -> a
toStringRep :: a -> BS.ByteString
-emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e
- => InstalledPackageInfo a b c d e
+emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g
+ => InstalledPackageInfo a b c d e f g
emptyInstalledPackageInfo =
InstalledPackageInfo {
unitId = fromStringRep BS.empty,
+ instantiatedWith = [],
sourcePackageId = fromStringRep BS.empty,
packageName = fromStringRep BS.empty,
packageVersion = Version [] [],
@@ -154,8 +181,8 @@ emptyInstalledPackageInfo =
-- | Read the part of the package DB that GHC is interested in.
--
-readPackageDbForGhc :: RepInstalledPackageInfo a b c d e =>
- FilePath -> IO [InstalledPackageInfo a b c d e]
+readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>
+ FilePath -> IO [InstalledPackageInfo a b c d e f g]
readPackageDbForGhc file =
decodeFromFile file getDbForGhc
where
@@ -187,8 +214,8 @@ readPackageDbForGhcPkg file =
-- | Write the whole of the package DB, both parts.
--
-writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e) =>
- FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO ()
+writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>
+ FilePath -> [InstalledPackageInfo a b c d e f g] -> pkgs -> IO ()
writePackageDb file ghcPkgs ghcPkgPart =
writeFileAtomic file (runPut putDbForGhcPkg)
where
@@ -274,10 +301,10 @@ writeFileAtomic targetPath content = do
hClose handle
renameFile tmpPath targetPath)
-instance (RepInstalledPackageInfo a b c d e) =>
- Binary (InstalledPackageInfo a b c d e) where
+instance (RepInstalledPackageInfo a b c d e f g) =>
+ Binary (InstalledPackageInfo a b c d e f g) where
put (InstalledPackageInfo
- unitId sourcePackageId
+ unitId instantiatedWith sourcePackageId
packageName packageVersion
abiHash depends importDirs
hsLibraries extraLibraries extraGHCiLibraries libraryDirs
@@ -291,6 +318,8 @@ instance (RepInstalledPackageInfo a b c d e) =>
put (toStringRep packageName)
put packageVersion
put (toStringRep unitId)
+ put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
+ instantiatedWith)
put abiHash
put (map toStringRep depends)
put importDirs
@@ -306,7 +335,7 @@ instance (RepInstalledPackageInfo a b c d e) =>
put includeDirs
put haddockInterfaces
put haddockHTMLs
- put (map (\(mod_name, mod) -> (toStringRep mod_name, fmap toDbModule mod))
+ put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
exposedModules)
put (map toStringRep hiddenModules)
put exposed
@@ -317,6 +346,7 @@ instance (RepInstalledPackageInfo a b c d e) =>
packageName <- get
packageVersion <- get
unitId <- get
+ instantiatedWith <- get
abiHash <- get
depends <- get
importDirs <- get
@@ -338,6 +368,8 @@ instance (RepInstalledPackageInfo a b c d e) =>
trusted <- get
return (InstalledPackageInfo
(fromStringRep unitId)
+ (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
+ instantiatedWith)
(fromStringRep sourcePackageId)
(fromStringRep packageName) packageVersion
abiHash
@@ -348,19 +380,55 @@ instance (RepInstalledPackageInfo a b c d e) =>
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
- (map (\(mod_name, mod) ->
- (fromStringRep mod_name, fmap fromDbModule mod))
+ (map (\(mod_name, mb_mod) ->
+ (fromStringRep mod_name, fmap fromDbModule mb_mod))
exposedModules)
(map fromStringRep hiddenModules)
exposed trusted)
-instance (BinaryStringRep a, BinaryStringRep b) =>
- Binary (DbModule a b) where
+instance (BinaryStringRep modulename, BinaryStringRep compid,
+ DbUnitIdModuleRep compid unitid modulename mod) =>
+ Binary (DbModule compid unitid modulename mod) where
put (DbModule dbModuleUnitId dbModuleName) = do
- put (toStringRep dbModuleUnitId)
+ putWord8 0
+ put (toDbUnitId dbModuleUnitId)
put (toStringRep dbModuleName)
+ put (DbModuleVar dbModuleVarName) = do
+ putWord8 1
+ put (toStringRep dbModuleVarName)
+ get = do
+ b <- getWord8
+ case b of
+ 0 -> do dbModuleUnitId <- get
+ dbModuleName <- get
+ return (DbModule (fromDbUnitId dbModuleUnitId)
+ (fromStringRep dbModuleName))
+ _ -> do dbModuleVarName <- get
+ return (DbModuleVar (fromStringRep dbModuleVarName))
+
+instance (BinaryStringRep modulename, BinaryStringRep compid,
+ DbUnitIdModuleRep compid unitid modulename mod) =>
+ Binary (DbUnitId compid unitid modulename mod) where
+ put (DbHashedUnitId cid hash) = do
+ putWord8 0
+ put (toStringRep cid)
+ put hash
+ put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
+ putWord8 1
+ put (toStringRep dbUnitIdComponentId)
+ put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)
get = do
- dbModuleUnitId <- get
- dbModuleName <- get
- return (DbModule (fromStringRep dbModuleUnitId)
- (fromStringRep dbModuleName))
+ b <- getWord8
+ case b of
+ 0 -> do
+ cid <- get
+ hash <- get
+ return (DbHashedUnitId (fromStringRep cid) hash)
+ _ -> do
+ dbUnitIdComponentId <- get
+ dbUnitIdInsts <- get
+ return (DbUnitId
+ (fromStringRep dbUnitIdComponentId)
+ (map (\(mod_name, mod) -> ( fromStringRep mod_name
+ , fromDbModule mod))
+ dbUnitIdInsts))
View Lorry Controller Status