diff options
Diffstat (limited to 'libraries/ghc-boot/GHC/PackageDb.hs')
| -rw-r--r-- | libraries/ghc-boot/GHC/PackageDb.hs | 411 |
1 files changed, 411 insertions, 0 deletions
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs new file mode 100644 index 0000000000..672b7ebbe3 --- /dev/null +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE CPP #-} +-- This module deliberately defines orphan instances for now (Binary Version). +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.PackageDb +-- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014 +-- +-- Maintainer : ghc-devs@haskell.org +-- Portability : portable +-- +-- This module provides the view of GHC's database of registered packages that +-- is shared between GHC the compiler\/library, and the ghc-pkg program. It +-- defines the database format that is shared between GHC and ghc-pkg. +-- +-- The database format, and this library are constructed so that GHC does not +-- have to depend on the Cabal library. The ghc-pkg program acts as the +-- gateway between the external package format (which is defined by Cabal) and +-- the internal package format which is specialised just for GHC. +-- +-- GHC the compiler only needs some of the information which is kept about +-- registerd packages, such as module names, various paths etc. On the other +-- hand ghc-pkg has to keep all the information from Cabal packages and be able +-- to regurgitate it for users and other tools. +-- +-- The first trick is that we duplicate some of the information in the package +-- database. We essentially keep two versions of the datbase in one file, one +-- version used only by ghc-pkg which keeps the full information (using the +-- serialised form of the 'InstalledPackageInfo' type defined by the Cabal +-- library); and a second version written by ghc-pkg and read by GHC which has +-- just the subset of information that GHC needs. +-- +-- The second trick is that this module only defines in detail the format of +-- the second version -- the bit GHC uses -- and the part managed by ghc-pkg +-- is kept in the file but here we treat it as an opaque blob of data. That way +-- this library avoids depending on Cabal. +-- +module GHC.PackageDb ( + InstalledPackageInfo(..), + ExposedModule(..), + OriginalModule(..), + BinaryStringRep(..), + emptyInstalledPackageInfo, + readPackageDbForGhc, + readPackageDbForGhcPkg, + writePackageDb + ) where + +import Data.Version (Version(..)) +import qualified Data.ByteString as BS +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 Data.Binary as Bin +import Data.Binary.Put as Bin +import Data.Binary.Get as Bin +import Control.Exception as Exception +import Control.Monad (when) +import System.FilePath +import System.IO +import System.IO.Error +import GHC.IO.Exception (IOErrorType(InappropriateType)) +import System.Directory + + +-- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits +-- that GHC is interested in. +-- +data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename + = InstalledPackageInfo { + installedPackageId :: instpkgid, + sourcePackageId :: srcpkgid, + packageName :: srcpkgname, + packageVersion :: Version, + packageKey :: pkgkey, + depends :: [instpkgid], + importDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries :: [String], + libraryDirs :: [FilePath], + frameworks :: [String], + frameworkDirs :: [FilePath], + ldOptions :: [String], + ccOptions :: [String], + includes :: [String], + includeDirs :: [FilePath], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath], + exposedModules :: [ExposedModule instpkgid modulename], + hiddenModules :: [modulename], + instantiatedWith :: [(modulename,OriginalModule instpkgid modulename)], + exposed :: Bool, + trusted :: Bool + } + deriving (Eq, Show) + +-- | 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 instpkgid modulename + = OriginalModule { + originalPackageId :: instpkgid, + originalModuleName :: 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), +-- and may be a signature (in which case 'exposedSignature is filled in with +-- what the signature was compiled against). Thus: +-- +-- * @ExposedModule n Nothing Nothing@ represents an exposed module @n@ which +-- was defined in this package. +-- +-- * @ExposedModule n (Just o) Nothing@ represents a reexported module @n@ +-- which was originally defined in @o@. +-- +-- * @ExposedModule n Nothing (Just s)@ represents an exposed signature @n@ +-- which was compiled against the implementation @s@. +-- +-- * @ExposedModule n (Just o) (Just s)@ represents a reexported signature +-- which was originally defined in @o@ and was compiled against the +-- implementation @s@. +-- +-- We use two 'Maybe' data types instead of an ADT with four branches or +-- four fields because this representation allows us to treat +-- reexports/signatures uniformly. +data ExposedModule instpkgid modulename + = ExposedModule { + exposedName :: modulename, + exposedReexport :: Maybe (OriginalModule instpkgid modulename), + exposedSignature :: Maybe (OriginalModule instpkgid modulename) + } + deriving (Eq, Show) + +class BinaryStringRep a where + fromStringRep :: BS.ByteString -> a + toStringRep :: a -> BS.ByteString + +emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, + BinaryStringRep c, BinaryStringRep d) + => InstalledPackageInfo a b c d e +emptyInstalledPackageInfo = + InstalledPackageInfo { + installedPackageId = fromStringRep BS.empty, + sourcePackageId = fromStringRep BS.empty, + packageName = fromStringRep BS.empty, + packageVersion = Version [] [], + packageKey = fromStringRep BS.empty, + depends = [], + importDirs = [], + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries = [], + libraryDirs = [], + frameworks = [], + frameworkDirs = [], + ldOptions = [], + ccOptions = [], + includes = [], + includeDirs = [], + haddockInterfaces = [], + haddockHTMLs = [], + exposedModules = [], + hiddenModules = [], + instantiatedWith = [], + exposed = False, + trusted = False + } + +-- | Read the part of the package DB that GHC is interested in. +-- +readPackageDbForGhc :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, + BinaryStringRep d, BinaryStringRep e) => + FilePath -> IO [InstalledPackageInfo a b c d e] +readPackageDbForGhc file = + decodeFromFile file getDbForGhc + where + getDbForGhc = do + _version <- getHeader + _ghcPartLen <- get :: Get Word32 + ghcPart <- get + -- the next part is for ghc-pkg, but we stop here. + return ghcPart + +-- | Read the part of the package DB that ghc-pkg is interested in +-- +-- Note that the Binary instance for ghc-pkg's representation of packages +-- 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 + where + getDbForGhcPkg = do + _version <- getHeader + -- skip over the ghc part + ghcPartLen <- get :: Get Word32 + _ghcPart <- skip (fromIntegral ghcPartLen) + -- the next part is for ghc-pkg + ghcPkgPart <- get + return ghcPkgPart + +-- | Write the whole of the package DB, both parts. +-- +writePackageDb :: (Binary pkgs, BinaryStringRep a, BinaryStringRep b, + BinaryStringRep c, BinaryStringRep d, BinaryStringRep e) => + FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO () +writePackageDb file ghcPkgs ghcPkgPart = + writeFileAtomic file (runPut putDbForGhcPkg) + where + putDbForGhcPkg = do + putHeader + put ghcPartLen + putLazyByteString ghcPart + put ghcPkgPart + where + ghcPartLen :: Word32 + ghcPartLen = fromIntegral (BS.Lazy.length ghcPart) + ghcPart = encode ghcPkgs + +getHeader :: Get (Word32, Word32) +getHeader = do + magic <- getByteString (BS.length headerMagic) + when (magic /= headerMagic) $ + fail "not a ghc-pkg db file, wrong file magic number" + + majorVersion <- get :: Get Word32 + -- The major version is for incompatible changes + + minorVersion <- get :: Get Word32 + -- The minor version is for compatible extensions + + when (majorVersion /= 1) $ + fail "unsupported ghc-pkg db format version" + -- If we ever support multiple major versions then we'll have to change + -- this code + + -- The header can be extended without incrementing the major version, + -- we ignore fields we don't know about (currently all). + headerExtraLen <- get :: Get Word32 + skip (fromIntegral headerExtraLen) + + return (majorVersion, minorVersion) + +putHeader :: Put +putHeader = do + putByteString headerMagic + put majorVersion + put minorVersion + put headerExtraLen + where + majorVersion = 1 :: Word32 + minorVersion = 0 :: Word32 + headerExtraLen = 0 :: Word32 + +headerMagic :: BS.ByteString +headerMagic = BS.Char8.pack "\0ghcpkg\0" + + +-- TODO: we may be able to replace the following with utils from the binary +-- package in future. + +-- | 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) + where + feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize + if BS.null chunk + then feed hnd (k Nothing) + else feed hnd (k (Just chunk)) + feed _ (Done _ _ res) = return res + feed _ (Fail _ _ msg) = ioError err + where + err = mkIOError InappropriateType loc Nothing (Just file) + `ioeSetErrorString` msg + loc = "GHC.PackageDb.readPackageDb" + +-- Copied from Cabal's Distribution.Simple.Utils. +writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + BS.Lazy.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, + BinaryStringRep d, BinaryStringRep e) => + Binary (InstalledPackageInfo a b c d e) where + put (InstalledPackageInfo + installedPackageId sourcePackageId + packageName packageVersion packageKey + depends importDirs + hsLibraries extraLibraries extraGHCiLibraries libraryDirs + frameworks frameworkDirs + ldOptions ccOptions + includes includeDirs + haddockInterfaces haddockHTMLs + exposedModules hiddenModules instantiatedWith + exposed trusted) = do + put (toStringRep installedPackageId) + put (toStringRep sourcePackageId) + put (toStringRep packageName) + put packageVersion + put (toStringRep packageKey) + put (map toStringRep depends) + put importDirs + put hsLibraries + put extraLibraries + put extraGHCiLibraries + put libraryDirs + put frameworks + put frameworkDirs + put ldOptions + put ccOptions + put includes + put includeDirs + put haddockInterfaces + put haddockHTMLs + put exposedModules + put (map toStringRep hiddenModules) + put (map (\(k,v) -> (toStringRep k, v)) instantiatedWith) + put exposed + put trusted + + get = do + installedPackageId <- get + sourcePackageId <- get + packageName <- get + packageVersion <- get + packageKey <- get + depends <- get + importDirs <- get + hsLibraries <- get + extraLibraries <- get + extraGHCiLibraries <- get + libraryDirs <- get + frameworks <- get + frameworkDirs <- get + ldOptions <- get + ccOptions <- get + includes <- get + includeDirs <- get + haddockInterfaces <- get + haddockHTMLs <- get + exposedModules <- get + hiddenModules <- get + instantiatedWith <- get + exposed <- get + trusted <- get + return (InstalledPackageInfo + (fromStringRep installedPackageId) + (fromStringRep sourcePackageId) + (fromStringRep packageName) packageVersion + (fromStringRep packageKey) + (map fromStringRep depends) + importDirs + hsLibraries extraLibraries extraGHCiLibraries libraryDirs + frameworks frameworkDirs + ldOptions ccOptions + includes includeDirs + haddockInterfaces haddockHTMLs + exposedModules + (map fromStringRep hiddenModules) + (map (\(k,v) -> (fromStringRep k, v)) instantiatedWith) + exposed trusted) + +instance Binary Version where + put (Version a b) = do + put a + put b + get = do + a <- get + b <- get + return (Version a b) + +instance (BinaryStringRep a, BinaryStringRep b) => + Binary (OriginalModule a b) where + put (OriginalModule originalPackageId originalModuleName) = do + put (toStringRep originalPackageId) + put (toStringRep originalModuleName) + get = do + originalPackageId <- get + originalModuleName <- get + return (OriginalModule (fromStringRep originalPackageId) + (fromStringRep originalModuleName)) + +instance (BinaryStringRep a, BinaryStringRep b) => + Binary (ExposedModule a b) where + put (ExposedModule exposedName exposedReexport exposedSignature) = do + put (toStringRep exposedName) + put exposedReexport + put exposedSignature + get = do + exposedName <- get + exposedReexport <- get + exposedSignature <- get + return (ExposedModule (fromStringRep exposedName) + exposedReexport + exposedSignature) |