diff --git a/GHC/ForeignSrcLang.hs b/GHC/ForeignSrcLang.hs new file mode 100644 --- /dev/null +++ b/GHC/ForeignSrcLang.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | See @GHC.LanguageExtensions@ for an explanation +-- on why this is needed +module GHC.ForeignSrcLang + ( module GHC.ForeignSrcLang.Type + ) where + +import Data.Binary +import GHC.ForeignSrcLang.Type + +instance Binary ForeignSrcLang diff --git a/GHC/LanguageExtensions/Type.hs b/GHC/LanguageExtensions/Type.hs deleted file mode 100644 --- a/GHC/LanguageExtensions/Type.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module GHC.LanguageExtensions.Type ( module X ) where - -import "ghc-boot-th" GHC.LanguageExtensions.Type as X diff --git a/GHC/PackageDb.hs b/GHC/PackageDb.hs --- a/GHC/PackageDb.hs +++ b/GHC/PackageDb.hs @@ -1,4 +1,16 @@ +{-# 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 #-} ----------------------------------------------------------------------------- -- | @@ -36,10 +48,17 @@ -- module GHC.PackageDb ( InstalledPackageInfo(..), - ExposedModule(..), - OriginalModule(..), + DbModule(..), + DbUnitId(..), BinaryStringRep(..), + DbUnitIdModuleRep(..), emptyInstalledPackageInfo, + PackageDbLock, + lockPackageDb, + unlockPackageDb, + DbMode(..), + DbOpenMode(..), + isDbOpenReadMode, readPackageDbForGhc, readPackageDbForGhcPkg, writePackageDb @@ -50,6 +69,8 @@ import qualified Data.ByteString.Char8 as BS.Char8 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.Binary as Bin import Data.Binary.Put as Bin import Data.Binary.Get as Bin @@ -59,20 +80,30 @@ import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) +#if MIN_VERSION_base(4,10,0) +import GHC.IO.Handle.Lock +#endif import System.Directory -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits --- that GHC is interested in. +-- that GHC is interested in. See Cabal's documentation for a more detailed +-- description of all of the fields. -- -data InstalledPackageInfo srcpkgid srcpkgname unitid modulename +data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = InstalledPackageInfo { - unitId :: unitid, + unitId :: instunitid, + componentId :: compid, + instantiatedWith :: [(modulename, mod)], sourcePackageId :: srcpkgid, packageName :: srcpkgname, packageVersion :: Version, + sourceLibName :: Maybe srcpkgname, abiHash :: String, - depends :: [unitid], + depends :: [instunitid], + -- | Like 'depends', but each dependency is annotated with the + -- ABI hash we expect the dependency to respect. + abiDepends :: [(instunitid, String)], importDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], @@ -87,8 +118,9 @@ includeDirs :: [FilePath], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath], - exposedModules :: [ExposedModule unitid modulename], + exposedModules :: [(modulename, Maybe mod)], hiddenModules :: [modulename], + indefinite :: Bool, exposed :: Bool, trusted :: Bool } @@ -96,55 +128,65 @@ -- | A convenience constraint synonym for common constraints over parameters -- to 'InstalledPackageInfo'. -type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename = +type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname, - BinaryStringRep unitid, BinaryStringRep modulename) + BinaryStringRep modulename, BinaryStringRep compid, + BinaryStringRep instunitid, + DbUnitIdModuleRep instunitid compid unitid modulename mod) --- | An original module is a fully-qualified module name (installed package ID --- plus module name) representing where a module was *originally* defined --- (i.e., the 'exposedReexport' field of the original ExposedModule entry should --- be 'Nothing'). Invariant: an OriginalModule never points to a reexport. -data OriginalModule unitid modulename - = OriginalModule { - originalPackageId :: unitid, - originalModuleName :: modulename +-- | 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 } + | DbModuleVar { + dbModuleVarName :: modulename + } deriving (Eq, Show) --- | Represents a module name which is exported by a package, stored in the --- 'exposedModules' field. A module export may be a reexport (in which case --- 'exposedReexport' is filled in with the original source of the module). --- Thus: --- --- * @ExposedModule n Nothing@ represents an exposed module @n@ which --- was defined in this package. --- --- * @ExposedModule n (Just o)@ represents a reexported module @n@ --- which was originally defined in @o@. --- --- We use a 'Maybe' data types instead of an ADT with two branches because this --- representation allows us to treat reexports uniformly. -data ExposedModule unitid modulename - = ExposedModule { - exposedName :: modulename, - exposedReexport :: Maybe (OriginalModule unitid modulename) - } +-- | @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) class BinaryStringRep a where fromStringRep :: BS.ByteString -> a toStringRep :: a -> BS.ByteString -emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d - => InstalledPackageInfo a b c d +emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g + => InstalledPackageInfo 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, packageVersion = Version [] [], + sourceLibName = Nothing, abiHash = "", depends = [], + abiDepends = [], importDirs = [], hsLibraries = [], extraLibraries = [], @@ -161,16 +203,101 @@ haddockHTMLs = [], exposedModules = [], hiddenModules = [], + indefinite = False, exposed = False, trusted = False } +-- | Represents a lock of a package db. +newtype PackageDbLock = PackageDbLock +#if MIN_VERSION_base(4,10,0) + Handle +#else + () -- no locking primitives available in base < 4.10 +#endif + +-- | Acquire an exclusive lock related to package DB under given location. +lockPackageDb :: FilePath -> IO PackageDbLock + +-- | Release the lock related to package DB. +unlockPackageDb :: PackageDbLock -> IO () + +#if MIN_VERSION_base(4,10,0) + +-- | Acquire a lock of given type related to package DB under given location. +lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock +lockPackageDbWith mode file = do + -- We are trying to open the lock file and then lock it. Thus the lock file + -- needs to either exist or we need to be able to create it. Ideally we + -- would not assume that the lock file always exists in advance. When we are + -- dealing with a package DB where we have write access then if the lock + -- file does not exist then we can create it by opening the file in + -- read/write mode. On the other hand if we are dealing with a package DB + -- where we do not have write access (e.g. a global DB) then we can only + -- open in read mode, and the lock file had better exist already or we're in + -- trouble. So for global read-only DBs on platforms where we must lock the + -- DB for reading then we will require that the installer/packaging has + -- included the lock file. + -- + -- Thus the logic here is to first try opening in read-only mode (to handle + -- global read-only DBs) and if the file does not exist then try opening in + -- read/write mode to create the lock file. If either succeed then lock the + -- file. IO exceptions (other than the first open attempt failing due to the + -- file not existing) simply propagate. + catchJust + (\e -> if isDoesNotExistError e then Just () else Nothing) + (lockFileOpenIn ReadMode) + (const $ lockFileOpenIn ReadWriteMode) + where + lock = file <.> "lock" + + lockFileOpenIn io_mode = bracketOnError + (openBinaryFile lock io_mode) + hClose + -- If file locking support is not available, ignore the error and proceed + -- normally. Without it the only thing we lose on non-Windows platforms is + -- the ability to safely issue concurrent updates to the same package db. + $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return () + return $ PackageDbLock hnd + +lockPackageDb = lockPackageDbWith ExclusiveLock +unlockPackageDb (PackageDbLock hnd) = hClose hnd + +-- MIN_VERSION_base(4,10,0) +#else + +lockPackageDb _file = return $ PackageDbLock () +unlockPackageDb _lock = return () + +-- MIN_VERSION_base(4,10,0) +#endif + +-- | Mode to open a package db in. +data DbMode = DbReadOnly | DbReadWrite + +-- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So +-- it is like 'Maybe' but with a type argument for the mode to enforce that the +-- mode is used consistently. +data DbOpenMode (mode :: DbMode) t where + DbOpenReadOnly :: DbOpenMode 'DbReadOnly t + DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t + +deriving instance Functor (DbOpenMode mode) +deriving instance F.Foldable (DbOpenMode mode) +deriving instance F.Traversable (DbOpenMode mode) + +isDbOpenReadMode :: DbOpenMode mode t -> Bool +isDbOpenReadMode = \case + DbOpenReadOnly -> True + DbOpenReadWrite{} -> False + -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: RepInstalledPackageInfo a b c d => - FilePath -> IO [InstalledPackageInfo a b c d] +readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g => + FilePath -> IO [InstalledPackageInfo a b c d e f g] readPackageDbForGhc file = - decodeFromFile file getDbForGhc + decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case + (pkgs, DbOpenReadOnly) -> return pkgs where getDbForGhc = do _version <- getHeader @@ -185,9 +312,14 @@ -- is not defined in this package. This is because ghc-pkg uses Cabal types -- (and Binary instances for these) which this package does not depend on. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> IO pkgs -readPackageDbForGhcPkg file = - decodeFromFile file getDbForGhcPkg +-- If we open the package db in read only mode, we get its contents. Otherwise +-- we additionally receive a PackageDbLock that represents a lock on the +-- database, so that we can safely update it later. +-- +readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> + IO (pkgs, DbOpenMode mode PackageDbLock) +readPackageDbForGhcPkg file mode = + decodeFromFile file mode getDbForGhcPkg where getDbForGhcPkg = do _version <- getHeader @@ -200,10 +332,11 @@ -- | Write the whole of the package DB, both parts. -- -writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d) => - FilePath -> [InstalledPackageInfo a b c d] -> 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) + writeFileAtomic file (runPut putDbForGhcPkg) where putDbForGhcPkg = do putHeader @@ -259,11 +392,28 @@ -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> Get a -> IO a -decodeFromFile file decoder = - withBinaryFile file ReadMode $ \hnd -> - feed hnd (runGetIncremental decoder) +decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> + IO (pkgs, DbOpenMode mode PackageDbLock) +decodeFromFile file mode decoder = case mode of + DbOpenReadOnly -> do + -- When we open the package db in read only mode, there is no need to acquire + -- shared lock on non-Windows platform because we update the database with an + -- atomic rename, so readers will always see the database in a consistent + -- state. +#if MIN_VERSION_base(4,10,0) && defined(mingw32_HOST_OS) + bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do +#endif + (, DbOpenReadOnly) <$> decodeFileContents + DbOpenReadWrite{} -> do + -- When we open the package db in read/write mode, acquire an exclusive lock + -- on the database and return it so we can keep it for the duration of the + -- update. + bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do + (, DbOpenReadWrite lock) <$> decodeFileContents where + decodeFileContents = withBinaryFile file ReadMode $ \hnd -> + feed hnd (runGetIncremental decoder) + feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize if BS.null chunk then feed hnd (k Nothing) @@ -287,12 +437,13 @@ hClose handle renameFile tmpPath targetPath) -instance (RepInstalledPackageInfo a b c d) => - Binary (InstalledPackageInfo a b c d) 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 componentId instantiatedWith sourcePackageId packageName packageVersion - abiHash depends importDirs + sourceLibName + abiHash depends abiDepends importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs libraryDynDirs frameworks frameworkDirs @@ -300,13 +451,18 @@ includes includeDirs haddockInterfaces haddockHTMLs exposedModules hiddenModules - exposed trusted) = do + indefinite exposed trusted) = do put (toStringRep sourcePackageId) put (toStringRep packageName) put packageVersion + put (fmap toStringRep sourceLibName) put (toStringRep unitId) + put (toStringRep componentId) + put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) + instantiatedWith) put abiHash put (map toStringRep depends) + put (map (\(k,v) -> (toStringRep k, v)) abiDepends) put importDirs put hsLibraries put extraLibraries @@ -321,8 +477,10 @@ put includeDirs put haddockInterfaces put haddockHTMLs - put exposedModules + put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod)) + exposedModules) put (map toStringRep hiddenModules) + put indefinite put exposed put trusted @@ -330,9 +488,13 @@ sourcePackageId <- get packageName <- get packageVersion <- get - unitId <- get + sourceLibName <- get + unitId <- get + componentId <- get + instantiatedWith <- get abiHash <- get depends <- get + abiDepends <- get importDirs <- get hsLibraries <- get extraLibraries <- get @@ -349,14 +511,20 @@ haddockHTMLs <- get exposedModules <- get hiddenModules <- get + indefinite <- get exposed <- get trusted <- get return (InstalledPackageInfo (fromStringRep unitId) + (fromStringRep componentId) + (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod)) + instantiatedWith) (fromStringRep sourcePackageId) (fromStringRep packageName) packageVersion + (fmap fromStringRep sourceLibName) abiHash (map fromStringRep depends) + (map (\(k,v) -> (fromStringRep k, v)) abiDepends) importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs libraryDynDirs @@ -364,28 +532,55 @@ ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs - exposedModules + (map (\(mod_name, mb_mod) -> + (fromStringRep mod_name, fmap fromDbModule mb_mod)) + exposedModules) (map fromStringRep hiddenModules) - exposed trusted) + indefinite exposed trusted) -instance (BinaryStringRep a, BinaryStringRep b) => - Binary (OriginalModule a b) where - put (OriginalModule originalPackageId originalModuleName) = do - put (toStringRep originalPackageId) - put (toStringRep originalModuleName) +instance (BinaryStringRep modulename, BinaryStringRep compid, + 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) + put (toStringRep dbModuleName) + put (DbModuleVar dbModuleVarName) = do + putWord8 1 + put (toStringRep dbModuleVarName) get = do - originalPackageId <- get - originalModuleName <- get - return (OriginalModule (fromStringRep originalPackageId) - (fromStringRep originalModuleName)) + 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 a, BinaryStringRep b) => - Binary (ExposedModule a b) where - put (ExposedModule exposedName exposedReexport) = do - put (toStringRep exposedName) - put exposedReexport +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 + putWord8 0 + put (toStringRep instunitid) + put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do + putWord8 1 + put (toStringRep dbUnitIdComponentId) + put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts) get = do - exposedName <- get - exposedReexport <- get - return (ExposedModule (fromStringRep exposedName) - exposedReexport) + 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)) diff --git a/GHC/Serialized.hs b/GHC/Serialized.hs --- a/GHC/Serialized.hs +++ b/GHC/Serialized.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -26,15 +28,22 @@ data Serialized = Serialized TypeRep [Word8] -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later -toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized +toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized toSerialized serialize what = Serialized (typeOf what) (serialize what) -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. -- Otherwise return @Nothing@. fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a +#if MIN_VERSION_base(4,10,0) fromSerialized deserialize (Serialized the_type bytes) + | the_type == rep = Just (deserialize bytes) + | otherwise = Nothing + where rep = typeRep (Proxy :: Proxy a) +#else +fromSerialized deserialize (Serialized the_type bytes) | the_type == typeOf (undefined :: a) = Just (deserialize bytes) | otherwise = Nothing +#endif -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' serializeWithData :: Data a => a -> [Word8] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,7 +1,3 @@ -## 8.0.2 *Jan 2017* - - * Bundled with GHC 8.0.2 - ## 8.0.1 *May 2016* * Bundled with GHC 8.0.1 diff --git a/ghc-boot.cabal b/ghc-boot.cabal --- a/ghc-boot.cabal +++ b/ghc-boot.cabal @@ -1,9 +1,5 @@ --- WARNING: ghc-boot.cabal is automatically generated from ghc-boot.cabal.in by --- ../../configure. Make sure you are editing ghc-boot.cabal.in, not --- ghc-boot.cabal. - name: ghc-boot -version: 8.0.2 +version: 8.2.1 license: BSD3 license-file: LICENSE category: GHC @@ -22,7 +18,7 @@ The package database format and this library are constructed in such a way that while ghc-pkg depends on Cabal, the GHC library and program do not have to depend on Cabal. -cabal-version: >=1.10 +cabal-version: >=1.22 build-type: Simple extra-source-files: changelog.md @@ -37,13 +33,13 @@ exposed-modules: GHC.LanguageExtensions - GHC.LanguageExtensions.Type GHC.PackageDb GHC.Serialized + GHC.ForeignSrcLang - build-depends: base >= 4.7 && < 4.10, + build-depends: base >= 4.7 && < 4.11, binary == 0.8.*, bytestring == 0.10.*, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5, - ghc-boot-th == 8.0.2 + ghc-boot-th == 8.2.1