diff options
| -rw-r--r-- | compiler/GHC/Driver/Packages.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Types/Module.hs | 29 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Info.hs | 34 | ||||
| -rw-r--r-- | libraries/ghc-boot/GHC/PackageDb.hs | 225 | ||||
| -rw-r--r-- | utils/ghc-pkg/Main.hs | 69 |
5 files changed, 158 insertions, 201 deletions
diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index 345f0dc1ed..3b0cf0525a 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -592,7 +592,7 @@ readPackageDatabase dflags conf_file = do conf_file' = dropTrailingPathSeparator conf_file top_dir = topDir dflags pkgroot = takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot) + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . toUnitInfo) proto_pkg_configs -- return $ PackageDatabase conf_file' pkg_configs1 diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs index 76bc026ea3..eb27d6a153 100644 --- a/compiler/GHC/Types/Module.hs +++ b/compiler/GHC/Types/Module.hs @@ -150,7 +150,6 @@ import GHC.Utils.Misc import Data.List (sortBy, sort) import Data.Ord import Data.Version -import GHC.PackageDb import GHC.Utils.Fingerprint import qualified Data.ByteString as BS @@ -344,10 +343,6 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) -instance BinaryStringRep ModuleName where - fromStringRep = mkModuleNameFS . mkFastStringByteString - toStringRep = bytesFS . moduleNameFS - instance Data ModuleName where -- don't traverse? toConstr _ = abstractConstr "ModuleName" @@ -492,15 +487,6 @@ class ContainsModule t where class HasModule m where getModule :: m Module -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" - {- ************************************************************************ * * @@ -535,10 +521,6 @@ data ComponentDetails = ComponentDetails , componentSourcePkdId :: String } -instance BinaryStringRep ComponentId where - fromStringRep bs = ComponentId (mkFastStringByteString bs) Nothing - toStringRep (ComponentId s _) = bytesFS s - instance Uniquable ComponentId where getUnique (ComponentId n _) = getUnique n @@ -700,11 +682,6 @@ instance Binary InstalledUnitId where put_ bh (InstalledUnitId fs) = put_ bh fs get bh = do fs <- get bh; return (InstalledUnitId fs) -instance BinaryStringRep InstalledUnitId where - fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" - instance Eq InstalledUnitId where uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 @@ -858,7 +835,7 @@ unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString hashUnitId cid sorted_holes = mkFastStringByteString - . fingerprintUnitId (toStringRep cid) + . fingerprintUnitId (bytesFS (componentIdRaw cid)) $ rawHashUnitId sorted_holes -- | Generate a hash for a sorted module substitution. @@ -867,9 +844,9 @@ rawHashUnitId sorted_holes = fingerprintByteString . BS.concat $ do (m, b) <- sorted_holes - [ toStringRep m, BS.Char8.singleton ' ', + [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - toStringRep (moduleName b), BS.Char8.singleton '\n'] + bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b) diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 010bb5ebf3..8a6558f94c 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -17,6 +17,7 @@ module GHC.Unit.Info ( -- * The UnitInfo type: information about a unit UnitInfo, + toUnitInfo, GenericUnitInfo(..), ComponentId(..), PackageId(..), @@ -33,6 +34,7 @@ import GHC.Prelude import GHC.PackageDb import Data.Version +import Data.Bifunctor import GHC.Data.FastString import GHC.Utils.Outputable @@ -48,10 +50,32 @@ type UnitInfo = GenericUnitInfo PackageId PackageName Module.InstalledUnitId - Module.UnitId Module.ModuleName Module.Module +-- | Convert a DbUnitInfo (read from a package database) into `UnitInfo` +toUnitInfo :: DbUnitInfo -> UnitInfo +toUnitInfo = mapGenericUnitInfo + mkUnitId' + mkComponentId' + mkPackageIdentifier' + mkPackageName' + mkModuleName' + mkModule' + where + mkPackageIdentifier' = PackageId . mkFastStringByteString + mkPackageName' = PackageName . mkFastStringByteString + mkUnitId' = InstalledUnitId . mkFastStringByteString + mkModuleName' = mkModuleNameFS . mkFastStringByteString + mkComponentId' cid = ComponentId (mkFastStringByteString cid) Nothing + mkInstUnitId' i = case i of + DbInstUnitId cid insts -> newUnitId (mkComponentId' cid) (fmap (bimap mkModuleName' mkModule') insts) + DbUnitId uid -> DefiniteUnitId (DefUnitId (mkUnitId' uid)) + mkModule' m = case m of + DbModule uid n -> mkModule (mkInstUnitId' uid) (mkModuleName' n) + DbModuleVar n -> mkHoleModule (mkModuleName' n) + + -- TODO: there's no need for these to be FastString, as we don't need the uniq -- feature, but ghc doesn't currently have convenient support for any -- other compact string types, e.g. plain ByteString or Text. @@ -62,14 +86,6 @@ newtype PackageName = PackageName } deriving (Eq, Ord) -instance BinaryStringRep PackageId where - fromStringRep = PackageId . mkFastStringByteString - toStringRep (PackageId s) = bytesFS s - -instance BinaryStringRep PackageName where - fromStringRep = PackageName . mkFastStringByteString - toStringRep (PackageName s) = bytesFS s - instance Uniquable PackageId where getUnique (PackageId n) = getUnique n diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs index bc6cdbcc6d..e8daedda66 100644 --- a/libraries/ghc-boot/GHC/PackageDb.hs +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -1,17 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.PackageDb @@ -48,6 +49,10 @@ -- module GHC.PackageDb ( GenericUnitInfo(..) + , type DbUnitInfo + , DbModule (..) + , DbInstUnitId (..) + , mapGenericUnitInfo -- * Read and write , DbMode(..) , DbOpenMode(..) @@ -59,11 +64,6 @@ module GHC.PackageDb , PackageDbLock , lockPackageDb , unlockPackageDb - -- * Misc - , DbModule(..) - , DbUnitId(..) - , BinaryStringRep(..) - , DbUnitIdModuleRep(..) ) where @@ -75,6 +75,7 @@ import qualified Data.ByteString.Lazy as BS.Lazy import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize) import qualified Data.Foldable as F import qualified Data.Traversable as F +import Data.Bifunctor import Data.Binary as Bin import Data.Binary.Put as Bin import Data.Binary.Get as Bin @@ -87,6 +88,8 @@ import GHC.IO.Exception (IOErrorType(InappropriateType)) import GHC.IO.Handle.Lock import System.Directory +-- | @ghc-boot@'s UnitInfo, serialized to the database. +type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule -- | Information about an unit (a unit is an installed module library). -- @@ -96,8 +99,8 @@ import System.Directory -- Some types are left as parameters to be instantiated differently in ghc-pkg -- and in ghc itself. -- -data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = GenericUnitInfo - { unitId :: instunitid +data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo + { unitId :: uid -- ^ Unique unit identifier that is used during compilation (e.g. to -- generate symbols). @@ -138,10 +141,10 @@ data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod -- ^ ABI hash used to avoid mixing up units compiled with different -- dependencies, compiler, options, etc. - , unitDepends :: [instunitid] + , unitDepends :: [uid] -- ^ Identifiers of the units this one depends on - , unitAbiDepends :: [(instunitid, String)] + , unitAbiDepends :: [(uid, String)] -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash -- we expect the dependency to respect. @@ -234,52 +237,52 @@ data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod } deriving (Eq, Show) --- | A convenience constraint synonym for common constraints over parameters --- to 'GenericUnitInfo'. -type RepGenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = - (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname, - BinaryStringRep modulename, BinaryStringRep compid, - BinaryStringRep instunitid, - 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 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 instunitid compid unitid modulename mod - = DbModule { - dbModuleUnitId :: unitid, - dbModuleName :: modulename +-- | Convert between GenericUnitInfo instances +mapGenericUnitInfo + :: (uid1 -> uid2) + -> (cid1 -> cid2) + -> (srcpkg1 -> srcpkg2) + -> (srcpkgname1 -> srcpkgname2) + -> (modname1 -> modname2) + -> (mod1 -> mod2) + -> (GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1 + -> GenericUnitInfo cid2 srcpkg2 srcpkgname2 uid2 modname2 mod2) +mapGenericUnitInfo fuid fcid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) = + g { unitId = fuid unitId + , unitInstanceOf = fcid unitInstanceOf + , unitInstantiations = fmap (bimap fmodname fmod) unitInstantiations + , unitPackageId = fsrcpkg unitPackageId + , unitPackageName = fsrcpkgname unitPackageName + , unitComponentName = fmap fsrcpkgname unitComponentName + , unitDepends = fmap fuid unitDepends + , unitAbiDepends = fmap (first fuid) unitAbiDepends + , unitExposedModules = fmap (bimap fmodname (fmap fmod)) unitExposedModules + , unitHiddenModules = fmap fmodname unitHiddenModules } - | 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 instunitid compid unitid modulename mod - = DbUnitId compid [(modulename, mod)] - | DbInstalledUnitId instunitid - deriving (Eq, Show) +-- | @ghc-boot@'s 'Module', serialized to the database. +data DbModule + = DbModule + { dbModuleUnitId :: DbInstUnitId + , dbModuleName :: BS.ByteString + } + | DbModuleVar + { dbModuleVarName :: BS.ByteString + } + deriving (Eq, Show) + +-- | @ghc-boot@'s instantiated unit id, serialized to the database. +data DbInstUnitId + + -- | Instantiated unit + = DbInstUnitId + BS.ByteString -- component id + [(BS.ByteString, DbModule)] -- instantiations: [(modulename,module)] -class BinaryStringRep a where - fromStringRep :: BS.ByteString -> a - toStringRep :: a -> BS.ByteString + -- | Uninstantiated unit + | DbUnitId + BS.ByteString -- unit id + deriving (Eq, Show) -- | Represents a lock of a package db. newtype PackageDbLock = PackageDbLock Handle @@ -358,8 +361,7 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: RepGenericUnitInfo a b c d e f g => - FilePath -> IO [GenericUnitInfo a b c d e f g] +readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] readPackageDbForGhc file = decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case (pkgs, DbOpenReadOnly) -> return pkgs @@ -397,9 +399,7 @@ readPackageDbForGhcPkg file mode = -- | Write the whole of the package DB, both parts. -- -writePackageDb :: (Binary pkgs, RepGenericUnitInfo a b c d e f g) => - FilePath -> [GenericUnitInfo a b c d e f g] -> - pkgs -> IO () +writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = writeFileAtomic file (runPut putDbForGhcPkg) where @@ -504,8 +504,7 @@ writeFileAtomic targetPath content = do hClose handle renameFile tmpPath targetPath) -instance (RepGenericUnitInfo a b c d e f g) => - Binary (GenericUnitInfo a b c d e f g) where +instance Binary DbUnitInfo where put (GenericUnitInfo unitId unitInstanceOf unitInstantiations unitPackageId @@ -520,17 +519,16 @@ instance (RepGenericUnitInfo a b c d e f g) => unitHaddockInterfaces unitHaddockHTMLs unitExposedModules unitHiddenModules unitIsIndefinite unitIsExposed unitIsTrusted) = do - put (toStringRep unitPackageId) - put (toStringRep unitPackageName) + put unitPackageId + put unitPackageName put unitPackageVersion - put (fmap toStringRep unitComponentName) - put (toStringRep unitId) - put (toStringRep unitInstanceOf) - put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) - unitInstantiations) + put unitComponentName + put unitId + put unitInstanceOf + put unitInstantiations put unitAbiHash - put (map toStringRep unitDepends) - put (map (\(k,v) -> (toStringRep k, v)) unitAbiDepends) + put unitDepends + put unitAbiDepends put unitImportDirs put unitLibraries put unitExtDepLibsSys @@ -545,9 +543,8 @@ instance (RepGenericUnitInfo a b c d e f g) => put unitIncludeDirs put unitHaddockInterfaces put unitHaddockHTMLs - put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod)) - unitExposedModules) - put (map toStringRep unitHiddenModules) + put unitExposedModules + put unitHiddenModules put unitIsIndefinite put unitIsExposed put unitIsTrusted @@ -583,16 +580,16 @@ instance (RepGenericUnitInfo a b c d e f g) => unitIsExposed <- get unitIsTrusted <- get return (GenericUnitInfo - (fromStringRep unitId) - (fromStringRep unitInstanceOf) - (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod)) - unitInstantiations) - (fromStringRep unitPackageId) - (fromStringRep unitPackageName) unitPackageVersion - (fmap fromStringRep unitComponentName) + unitId + unitInstanceOf + unitInstantiations + unitPackageId + unitPackageName + unitPackageVersion + unitComponentName unitAbiHash - (map fromStringRep unitDepends) - (map (\(k,v) -> (fromStringRep k, v)) unitAbiDepends) + unitDepends + unitAbiDepends unitImportDirs unitLibraries unitExtDepLibsSys unitExtDepLibsGhc libraryDirs libraryDynDirs @@ -600,55 +597,35 @@ instance (RepGenericUnitInfo a b c d e f g) => unitLinkerOptions unitCcOptions unitIncludes unitIncludeDirs unitHaddockInterfaces unitHaddockHTMLs - (map (\(mod_name, mb_mod) -> - (fromStringRep mod_name, fmap fromDbModule mb_mod)) - unitExposedModules) - (map fromStringRep unitHiddenModules) + unitExposedModules + unitHiddenModules unitIsIndefinite unitIsExposed unitIsTrusted) -instance (BinaryStringRep modulename, BinaryStringRep compid, - BinaryStringRep instunitid, - DbUnitIdModuleRep instunitid compid unitid modulename mod) => - Binary (DbModule instunitid compid unitid modulename mod) where +instance Binary DbModule where put (DbModule dbModuleUnitId dbModuleName) = do putWord8 0 - put (toDbUnitId dbModuleUnitId) - put (toStringRep dbModuleName) + put dbModuleUnitId + put dbModuleName put (DbModuleVar dbModuleVarName) = do putWord8 1 - put (toStringRep dbModuleVarName) + put 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, - BinaryStringRep instunitid, - DbUnitIdModuleRep instunitid compid unitid modulename mod) => - Binary (DbUnitId instunitid compid unitid modulename mod) where - put (DbInstalledUnitId instunitid) = do + 0 -> DbModule <$> get <*> get + _ -> DbModuleVar <$> get + +instance Binary DbInstUnitId where + put (DbUnitId uid) = do putWord8 0 - put (toStringRep instunitid) - put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do + put uid + put (DbInstUnitId dbUnitIdComponentId dbUnitIdInsts) = do putWord8 1 - put (toStringRep dbUnitIdComponentId) - put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts) + put dbUnitIdComponentId + put dbUnitIdInsts + get = do b <- getWord8 case b of - 0 -> do - instunitid <- get - return (DbInstalledUnitId (fromStringRep instunitid)) - _ -> do - dbUnitIdComponentId <- get - dbUnitIdInsts <- get - return (DbUnitId - (fromStringRep dbUnitIdComponentId) - (map (\(mod_name, mod) -> ( fromStringRep mod_name - , fromDbModule mod)) - dbUnitIdInsts)) + 0 -> DbUnitId <$> get + _ -> DbInstUnitId <$> get <*> get diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 23ddc5159b..2e2238ccb8 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -31,7 +31,7 @@ module Main (main) where import qualified GHC.PackageDb as GhcPkg -import GHC.PackageDb (BinaryStringRep(..)) +import GHC.PackageDb import GHC.HandleEncoding import GHC.BaseDir (getBaseDir) import GHC.Settings.Platform (getTargetPlatform) @@ -50,11 +50,12 @@ import Distribution.Package hiding (installedUnitId) import Distribution.Text import Distribution.Version import Distribution.Backpack +import Distribution.Pretty (Pretty (..)) import Distribution.Types.UnqualComponentName import Distribution.Types.LibraryName import Distribution.Types.MungedPackageName import Distribution.Types.MungedPackageId -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, writeUTF8File, readUTF8File) +import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File) import qualified Data.Version as Version import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix @@ -67,6 +68,7 @@ import Prelude import System.Console.GetOpt import qualified Control.Exception as Exception import Data.Maybe +import Data.Bifunctor import Data.Char ( toLower ) import Control.Monad @@ -1297,7 +1299,8 @@ updateDBCache verbosity db db_stack = do when (verbosity > Normal) $ infoLn ("writing cache " ++ filename) - GhcPkg.writePackageDb filename (map fst pkgsGhcCacheFormat) pkgsCabalFormat + let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat + GhcPkg.writePackageDb filename d pkgsCabalFormat `catchIO` \e -> if isPermissionError e then die $ filename ++ ": you don't have permission to modify this file" @@ -1311,7 +1314,6 @@ type PackageCacheFormat = GhcPkg.GenericUnitInfo PackageIdentifier PackageName UnitId - OpenUnitId ModuleName OpenModule @@ -1363,6 +1365,28 @@ recomputeValidAbiDeps db pkg = abiDepsUpdated = GhcPkg.unitAbiDepends pkg /= newAbiDeps + +-- | Convert from PackageCacheFormat to DbUnitInfo (the format used in +-- Ghc.PackageDb to store into the database) +fromPackageCacheFormat :: PackageCacheFormat -> GhcPkg.DbUnitInfo +fromPackageCacheFormat = GhcPkg.mapGenericUnitInfo + mkUnitId' mkComponentId' mkPackageIdentifier' mkPackageName' mkModuleName' mkModule' + where + displayBS :: Pretty a => a -> BS.ByteString + displayBS = toUTF8BS . display + mkPackageIdentifier' = displayBS + mkPackageName' = displayBS + mkComponentId' = displayBS + mkUnitId' = displayBS + mkModuleName' = displayBS + mkInstUnitId' i = case i of + IndefFullUnitId cid insts -> DbInstUnitId (mkComponentId' cid) + (fmap (bimap mkModuleName' mkModule') (Map.toList insts)) + DefiniteUnitId uid -> DbUnitId (mkUnitId' (unDefUnitId uid)) + mkModule' m = case m of + OpenModule uid n -> DbModule (mkInstUnitId' uid) (mkModuleName' n) + OpenModuleVar n -> DbModuleVar (mkModuleName' n) + convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat convertPackageInfoToCacheFormat pkg = GhcPkg.GenericUnitInfo { @@ -1400,43 +1424,6 @@ convertPackageInfoToCacheFormat pkg = where convertExposed (ExposedModule n reexport) = (n, reexport) -instance GhcPkg.BinaryStringRep ComponentId where - fromStringRep = mkComponentId . fromStringRep - toStringRep = toStringRep . display - -instance GhcPkg.BinaryStringRep PackageName where - fromStringRep = mkPackageName . fromStringRep - toStringRep = toStringRep . display - -instance GhcPkg.BinaryStringRep PackageIdentifier where - fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier") - . simpleParse . fromStringRep - toStringRep = toStringRep . display - -instance GhcPkg.BinaryStringRep ModuleName where - fromStringRep = ModuleName.fromString . fromStringRep - toStringRep = toStringRep . display - -instance GhcPkg.BinaryStringRep String where - fromStringRep = fromUTF8BS - toStringRep = toUTF8BS - -instance GhcPkg.BinaryStringRep UnitId where - fromStringRep = mkUnitId . fromStringRep - toStringRep = toStringRep . display - -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 uid) - = DefiniteUnitId (unsafeMkDefUnitId uid) - toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts) - toDbUnitId (DefiniteUnitId def_uid) - = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid) - -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar |