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 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)
data OriginalModule instpkgid modulename
= OriginalModule {
originalPackageId :: instpkgid,
originalModuleName :: modulename
}
deriving (Eq, Show)
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
}
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
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, 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
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, targetName) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFileWithDefaultPermissions targetDir $ targetName <.> "tmp")
(\(tmpPath, hnd) -> hClose hnd >> removeFile tmpPath)
(\(tmpPath, hnd) -> do
BS.Lazy.hPut hnd content
hClose hnd
#if mingw32_HOST_OS || mingw32_TARGET_OS
renameFile tmpPath targetPath
`catch` \err -> do
exists <- doesFileExist targetPath
if exists
then do removeFile targetPath
renameFile tmpPath targetPath
else throwIO (err :: IOException)
#else
renameFile tmpPath targetPath
#endif
)
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)