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
data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
= InstalledPackageInfo {
unitId :: unitid,
sourcePackageId :: srcpkgid,
packageName :: srcpkgname,
packageVersion :: Version,
abiHash :: String,
depends :: [unitid],
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 unitid modulename],
hiddenModules :: [modulename],
exposed :: Bool,
trusted :: Bool
}
deriving (Eq, Show)
type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename =
(BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
BinaryStringRep unitid, BinaryStringRep modulename)
data OriginalModule unitid modulename
= OriginalModule {
originalPackageId :: unitid,
originalModuleName :: modulename
}
deriving (Eq, Show)
data ExposedModule unitid modulename
= ExposedModule {
exposedName :: modulename,
exposedReexport :: Maybe (OriginalModule unitid modulename)
}
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 =
InstalledPackageInfo {
unitId = fromStringRep BS.empty,
sourcePackageId = fromStringRep BS.empty,
packageName = fromStringRep BS.empty,
packageVersion = Version [] [],
abiHash = "",
depends = [],
importDirs = [],
hsLibraries = [],
extraLibraries = [],
extraGHCiLibraries = [],
libraryDirs = [],
frameworks = [],
frameworkDirs = [],
ldOptions = [],
ccOptions = [],
includes = [],
includeDirs = [],
haddockInterfaces = [],
haddockHTMLs = [],
exposedModules = [],
hiddenModules = [],
exposed = False,
trusted = False
}
readPackageDbForGhc :: RepInstalledPackageInfo a b c d =>
FilePath -> IO [InstalledPackageInfo a b c d]
readPackageDbForGhc file =
decodeFromFile file getDbForGhc
where
getDbForGhc = do
_version <- getHeader
_ghcPartLen <- get :: Get Word32
ghcPart <- get
return ghcPart
readPackageDbForGhcPkg :: Binary pkgs => FilePath -> IO pkgs
readPackageDbForGhcPkg file =
decodeFromFile file getDbForGhcPkg
where
getDbForGhcPkg = do
_version <- getHeader
ghcPartLen <- get :: Get Word32
_ghcPart <- skip (fromIntegral ghcPartLen)
ghcPkgPart <- get
return ghcPkgPart
writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d) =>
FilePath -> [InstalledPackageInfo a b c d] -> 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
minorVersion <- get :: Get Word32
when (majorVersion /= 1) $
fail "unsupported ghc-pkg db format version"
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"
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"
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 (RepInstalledPackageInfo a b c d) =>
Binary (InstalledPackageInfo a b c d) where
put (InstalledPackageInfo
unitId sourcePackageId
packageName packageVersion
abiHash depends importDirs
hsLibraries extraLibraries extraGHCiLibraries libraryDirs
frameworks frameworkDirs
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
exposedModules hiddenModules
exposed trusted) = do
put (toStringRep sourcePackageId)
put (toStringRep packageName)
put packageVersion
put (toStringRep unitId)
put abiHash
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 exposed
put trusted
get = do
sourcePackageId <- get
packageName <- get
packageVersion <- get
unitId <- get
abiHash <- 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
exposed <- get
trusted <- get
return (InstalledPackageInfo
(fromStringRep unitId)
(fromStringRep sourcePackageId)
(fromStringRep packageName) packageVersion
abiHash
(map fromStringRep depends)
importDirs
hsLibraries extraLibraries extraGHCiLibraries libraryDirs
frameworks frameworkDirs
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
exposedModules
(map fromStringRep hiddenModules)
exposed trusted)
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) = do
put (toStringRep exposedName)
put exposedReexport
get = do
exposedName <- get
exposedReexport <- get
return (ExposedModule (fromStringRep exposedName)
exposedReexport)