{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE RecordWildCards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Unit.Database
-- 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
-- registered 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 database 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.Unit.Database
   ( GenericUnitInfo(..)
   , type DbUnitInfo
   , DbModule (..)
   , DbInstUnitId (..)
   , mapGenericUnitInfo
   -- * Read and write
   , DbMode(..)
   , DbOpenMode(..)
   , isDbOpenReadMode
   , readPackageDbForGhc
   , readPackageDbForGhcPkg
   , writePackageDb
   -- * Locking
   , PackageDbLock
   , lockPackageDb
   , unlockPackageDb
   -- * Misc
   , mkMungePathUrl
   , mungeUnitInfoPaths
   )
where

import Prelude -- See note [Why do we import Prelude here?]
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 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
import Control.Exception as Exception
import Control.Monad (when)
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO
import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import GHC.IO.Handle.Lock
import System.Directory
import Data.List (stripPrefix)

-- | @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).
--
-- This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
-- that GHC is interested in.
--
-- Some types are left as parameters to be instantiated differently in ghc-pkg
-- and in ghc itself.
--
data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo
   { GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId             :: uid
      -- ^ Unique unit identifier that is used during compilation (e.g. to
      -- generate symbols).

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf     :: compid
      -- ^ Identifier of an indefinite unit (i.e. with module holes) that this
      -- unit is an instance of.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations :: [(modulename, mod)]
      -- ^ How this unit instantiates some of its module holes. Map hole module
      -- names to actual module

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
unitPackageId      :: srcpkgid
      -- ^ Source package identifier.
      --
      -- Cabal instantiates this with Distribution.Types.PackageId.PackageId
      -- type which only contains the source package name and version. Notice
      -- that it doesn't contain the Hackage revision, nor any kind of hash.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName    :: srcpkgname
      -- ^ Source package name

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion :: Version
      -- ^ Source package version

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Maybe srcpkgname
unitComponentName  :: Maybe srcpkgname
      -- ^ Name of the component.
      --
      -- Cabal supports more than one components (libraries, executables,
      -- testsuites) in the same package. Each component has a name except the
      -- default one (that can only be a library component) for which we use
      -- "Nothing".
      --
      -- GHC only deals with "library" components as they are the only kind of
      -- components that can be registered in a database and used by other
      -- modules.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
unitAbiHash        :: String
      -- ^ ABI hash used to avoid mixing up units compiled with different
      -- dependencies, compiler, options, etc.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends        :: [uid]
      -- ^ Identifiers of the units this one depends on

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(uid, String)]
unitAbiDepends     :: [(uid, String)]
     -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash
     -- we expect the dependency to respect.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitImportDirs     :: [FilePath]
      -- ^ Directories containing module interfaces

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraries      :: [String]
      -- ^ Names of the Haskell libraries provided by this unit

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsSys  :: [String]
      -- ^ Names of the external system libraries that this unit depends on. See
      -- also `unitExtDepLibsGhc` field.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsGhc  :: [String]
      -- ^ Because of slight differences between the GHC dynamic linker (in
      -- GHC.Runtime.Linker) and the
      -- native system linker, some packages have to link with a different list
      -- of libraries when using GHC's. Examples include: libs that are actually
      -- gnu ld scripts, and the possibility that the .a libs do not exactly
      -- match the .so/.dll equivalents.
      --
      -- If this field is set, then we use that instead of the
      -- `unitExtDepLibsSys` field.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDirs    :: [FilePath]
      -- ^ Directories containing libraries provided by this unit. See also
      -- `unitLibraryDynDirs`.
      --
      -- It seems to be used to store paths to external library dependencies
      -- too.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDynDirs :: [FilePath]
      -- ^ Directories containing the dynamic libraries provided by this unit.
      -- See also `unitLibraryDirs`.
      --
      -- It seems to be used to store paths to external dynamic library
      -- dependencies too.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworks :: [String]
      -- ^ Names of the external MacOS frameworks that this unit depends on.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworkDirs :: [FilePath]
      -- ^ Directories containing MacOS frameworks that this unit depends
      -- on.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLinkerOptions  :: [String]
      -- ^ Linker (e.g. ld) command line options

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitCcOptions      :: [String]
      -- ^ C compiler options that needs to be passed to the C compiler when we
      -- compile some C code against this unit.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludes       :: [String]
      -- ^ C header files that are required by this unit (provided by this unit
      -- or external)

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludeDirs    :: [FilePath]
      -- ^ Directories containing C header files that this unit depends
      -- on.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitHaddockInterfaces :: [FilePath]
      -- ^ Paths to Haddock interface files for this unit

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitHaddockHTMLs   :: [FilePath]
      -- ^ Paths to Haddock directories containing HTML files

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules :: [(modulename, Maybe mod)]
      -- ^ Modules exposed by the unit.
      --
      -- A module can be re-exported from another package. In this case, we
      -- indicate the module origin in the second parameter.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules  :: [modulename]
      -- ^ Hidden modules.
      --
      -- These are useful for error reporting (e.g. if a hidden module is
      -- imported)

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite   :: Bool
      -- ^ True if this unit has some module holes that need to be instantiated
      -- with real modules to make the unit usable (a.k.a. Backpack).

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsExposed      :: Bool
      -- ^ True if the unit is exposed. A unit could be installed in a database
      -- by "disabled" by not being exposed.

   , GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted      :: Bool
      -- ^ True if the unit is trusted (cf Safe Haskell)

   }
   deriving (GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
(GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
 -> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
 -> Bool)
-> (GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
    -> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
    -> Bool)
-> Eq
     (GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall compid srcpkgid srcpkgname uid modulename mod.
(Eq uid, Eq compid, Eq modulename, Eq mod, Eq srcpkgid,
 Eq srcpkgname) =>
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
/= :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
$c/= :: forall compid srcpkgid srcpkgname uid modulename mod.
(Eq uid, Eq compid, Eq modulename, Eq mod, Eq srcpkgid,
 Eq srcpkgname) =>
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
== :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
$c== :: forall compid srcpkgid srcpkgname uid modulename mod.
(Eq uid, Eq compid, Eq modulename, Eq mod, Eq srcpkgid,
 Eq srcpkgname) =>
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
Eq, Int
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> ShowS
[GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod]
-> ShowS
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
(Int
 -> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
 -> ShowS)
-> (GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
    -> String)
-> ([GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod]
    -> ShowS)
-> Show
     (GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
Int
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> ShowS
forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
[GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod]
-> ShowS
forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
showList :: [GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod]
-> ShowS
$cshowList :: forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
[GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod]
-> ShowS
show :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
$cshow :: forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
showsPrec :: Int
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> ShowS
$cshowsPrec :: forall compid srcpkgid srcpkgname uid modulename mod.
(Show uid, Show compid, Show modulename, Show mod, Show srcpkgid,
 Show srcpkgname) =>
Int
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> ShowS
Show)

-- | 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 :: (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 uid1 -> uid2
fuid cid1 -> cid2
fcid srcpkg1 -> srcpkg2
fsrcpkg srcpkgname1 -> srcpkgname2
fsrcpkgname modname1 -> modname2
fmodname mod1 -> mod2
fmod g :: GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1
g@(GenericUnitInfo {uid1
cid1
srcpkg1
srcpkgname1
Bool
[uid1]
[modname1]
String
[String]
[(uid1, String)]
[(modname1, mod1)]
[(modname1, Maybe mod1)]
Maybe srcpkgname1
Version
unitIsTrusted :: Bool
unitIsExposed :: Bool
unitIsIndefinite :: Bool
unitHiddenModules :: [modname1]
unitExposedModules :: [(modname1, Maybe mod1)]
unitHaddockHTMLs :: [String]
unitHaddockInterfaces :: [String]
unitIncludeDirs :: [String]
unitIncludes :: [String]
unitCcOptions :: [String]
unitLinkerOptions :: [String]
unitExtDepFrameworkDirs :: [String]
unitExtDepFrameworks :: [String]
unitLibraryDynDirs :: [String]
unitLibraryDirs :: [String]
unitExtDepLibsGhc :: [String]
unitExtDepLibsSys :: [String]
unitLibraries :: [String]
unitImportDirs :: [String]
unitAbiDepends :: [(uid1, String)]
unitDepends :: [uid1]
unitAbiHash :: String
unitComponentName :: Maybe srcpkgname1
unitPackageVersion :: Version
unitPackageName :: srcpkgname1
unitPackageId :: srcpkg1
unitInstantiations :: [(modname1, mod1)]
unitInstanceOf :: cid1
unitId :: uid1
unitIsTrusted :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsExposed :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitHiddenModules :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitExposedModules :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitHaddockHTMLs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitHaddockInterfaces :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludeDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludes :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitCcOptions :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLinkerOptions :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworkDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworks :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDynDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsGhc :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsSys :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraries :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitImportDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitAbiDepends :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(uid, String)]
unitDepends :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitAbiHash :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
unitComponentName :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Maybe srcpkgname
unitPackageVersion :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageName :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageId :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
unitInstantiations :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstanceOf :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitId :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
..}) =
   GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1
g { unitId :: uid2
unitId              = uid1 -> uid2
fuid uid1
unitId
     , unitInstanceOf :: cid2
unitInstanceOf      = cid1 -> cid2
fcid cid1
unitInstanceOf
     , unitInstantiations :: [(modname2, mod2)]
unitInstantiations  = ((modname1, mod1) -> (modname2, mod2))
-> [(modname1, mod1)] -> [(modname2, mod2)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((modname1 -> modname2)
-> (mod1 -> mod2) -> (modname1, mod1) -> (modname2, mod2)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap modname1 -> modname2
fmodname mod1 -> mod2
fmod) [(modname1, mod1)]
unitInstantiations
     , unitPackageId :: srcpkg2
unitPackageId       = srcpkg1 -> srcpkg2
fsrcpkg srcpkg1
unitPackageId
     , unitPackageName :: srcpkgname2
unitPackageName     = srcpkgname1 -> srcpkgname2
fsrcpkgname srcpkgname1
unitPackageName
     , unitComponentName :: Maybe srcpkgname2
unitComponentName   = (srcpkgname1 -> srcpkgname2)
-> Maybe srcpkgname1 -> Maybe srcpkgname2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap srcpkgname1 -> srcpkgname2
fsrcpkgname Maybe srcpkgname1
unitComponentName
     , unitDepends :: [uid2]
unitDepends         = (uid1 -> uid2) -> [uid1] -> [uid2]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap uid1 -> uid2
fuid [uid1]
unitDepends
     , unitAbiDepends :: [(uid2, String)]
unitAbiDepends      = ((uid1, String) -> (uid2, String))
-> [(uid1, String)] -> [(uid2, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((uid1 -> uid2) -> (uid1, String) -> (uid2, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first uid1 -> uid2
fuid) [(uid1, String)]
unitAbiDepends
     , unitExposedModules :: [(modname2, Maybe mod2)]
unitExposedModules  = ((modname1, Maybe mod1) -> (modname2, Maybe mod2))
-> [(modname1, Maybe mod1)] -> [(modname2, Maybe mod2)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((modname1 -> modname2)
-> (Maybe mod1 -> Maybe mod2)
-> (modname1, Maybe mod1)
-> (modname2, Maybe mod2)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap modname1 -> modname2
fmodname ((mod1 -> mod2) -> Maybe mod1 -> Maybe mod2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap mod1 -> mod2
fmod)) [(modname1, Maybe mod1)]
unitExposedModules
     , unitHiddenModules :: [modname2]
unitHiddenModules   = (modname1 -> modname2) -> [modname1] -> [modname2]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap modname1 -> modname2
fmodname [modname1]
unitHiddenModules
     }

-- | @ghc-boot@'s 'Module', serialized to the database.
data DbModule
   = DbModule
      { DbModule -> DbInstUnitId
dbModuleUnitId  :: DbInstUnitId
      , DbModule -> ByteString
dbModuleName    :: BS.ByteString
      }
   | DbModuleVar
      { DbModule -> ByteString
dbModuleVarName :: BS.ByteString
      }
   deriving (DbModule -> DbModule -> Bool
(DbModule -> DbModule -> Bool)
-> (DbModule -> DbModule -> Bool) -> Eq DbModule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbModule -> DbModule -> Bool
$c/= :: DbModule -> DbModule -> Bool
== :: DbModule -> DbModule -> Bool
$c== :: DbModule -> DbModule -> Bool
Eq, Int -> DbModule -> ShowS
[DbModule] -> ShowS
DbModule -> String
(Int -> DbModule -> ShowS)
-> (DbModule -> String) -> ([DbModule] -> ShowS) -> Show DbModule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbModule] -> ShowS
$cshowList :: [DbModule] -> ShowS
show :: DbModule -> String
$cshow :: DbModule -> String
showsPrec :: Int -> DbModule -> ShowS
$cshowsPrec :: Int -> DbModule -> ShowS
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)]

   -- | Uninstantiated unit
   | DbUnitId
      BS.ByteString               -- unit id
  deriving (DbInstUnitId -> DbInstUnitId -> Bool
(DbInstUnitId -> DbInstUnitId -> Bool)
-> (DbInstUnitId -> DbInstUnitId -> Bool) -> Eq DbInstUnitId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbInstUnitId -> DbInstUnitId -> Bool
$c/= :: DbInstUnitId -> DbInstUnitId -> Bool
== :: DbInstUnitId -> DbInstUnitId -> Bool
$c== :: DbInstUnitId -> DbInstUnitId -> Bool
Eq, Int -> DbInstUnitId -> ShowS
[DbInstUnitId] -> ShowS
DbInstUnitId -> String
(Int -> DbInstUnitId -> ShowS)
-> (DbInstUnitId -> String)
-> ([DbInstUnitId] -> ShowS)
-> Show DbInstUnitId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbInstUnitId] -> ShowS
$cshowList :: [DbInstUnitId] -> ShowS
show :: DbInstUnitId -> String
$cshow :: DbInstUnitId -> String
showsPrec :: Int -> DbInstUnitId -> ShowS
$cshowsPrec :: Int -> DbInstUnitId -> ShowS
Show)

-- | Represents a lock of a package db.
newtype PackageDbLock = PackageDbLock Handle

-- | 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 ()

-- | Acquire a lock of given type related to package DB under given location.
lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
lockPackageDbWith :: LockMode -> String -> IO PackageDbLock
lockPackageDbWith LockMode
mode String
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-write mode
  -- and if that fails we try read-only (to handle global read-only DBs).
  -- If either succeed then lock the file. IO exceptions (other than the first
  -- open attempt failing due to the file not existing) simply propagate.
  --
  -- Note that there is a complexity here which was discovered in #13945: some
  -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was
  -- opened for write access. We would previously try opening the lockfile for
  -- read-only access first, however this failed when run on such filesystems.
  -- Consequently, we now try read-write access first, falling back to read-only
  -- if we are denied permission (e.g. in the case of a global database).
  (IOError -> Maybe ())
-> IO PackageDbLock -> (() -> IO PackageDbLock) -> IO PackageDbLock
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust
    (\IOError
e -> if IOError -> Bool
isPermissionError IOError
e then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
    (IOMode -> IO PackageDbLock
lockFileOpenIn IOMode
ReadWriteMode)
    (IO PackageDbLock -> () -> IO PackageDbLock
forall a b. a -> b -> a
const (IO PackageDbLock -> () -> IO PackageDbLock)
-> IO PackageDbLock -> () -> IO PackageDbLock
forall a b. (a -> b) -> a -> b
$ IOMode -> IO PackageDbLock
lockFileOpenIn IOMode
ReadMode)
  where
    lock :: String
lock = String
file String -> ShowS
<.> String
"lock"

    lockFileOpenIn :: IOMode -> IO PackageDbLock
lockFileOpenIn IOMode
io_mode = IO Handle
-> (Handle -> IO ())
-> (Handle -> IO PackageDbLock)
-> IO PackageDbLock
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
      (String -> IOMode -> IO Handle
openBinaryFile String
lock IOMode
io_mode)
      Handle -> IO ()
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.
      ((Handle -> IO PackageDbLock) -> IO PackageDbLock)
-> (Handle -> IO PackageDbLock) -> IO PackageDbLock
forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do Handle -> LockMode -> IO ()
hLock Handle
hnd LockMode
mode IO () -> (FileLockingNotSupported -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \FileLockingNotSupported
FileLockingNotSupported -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   PackageDbLock -> IO PackageDbLock
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDbLock -> IO PackageDbLock)
-> PackageDbLock -> IO PackageDbLock
forall a b. (a -> b) -> a -> b
$ Handle -> PackageDbLock
PackageDbLock Handle
hnd

lockPackageDb :: String -> IO PackageDbLock
lockPackageDb = LockMode -> String -> IO PackageDbLock
lockPackageDbWith LockMode
ExclusiveLock
unlockPackageDb :: PackageDbLock -> IO ()
unlockPackageDb (PackageDbLock Handle
hnd) = do
    Handle -> IO ()
hUnlock Handle
hnd
    Handle -> IO ()
hClose Handle
hnd

-- | 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 :: DbOpenMode mode t -> Bool
isDbOpenReadMode = \case
  DbOpenMode mode t
DbOpenReadOnly    -> Bool
True
  DbOpenReadWrite{} -> Bool
False

-- | Read the part of the package DB that GHC is interested in.
--
readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
readPackageDbForGhc :: String -> IO [DbUnitInfo]
readPackageDbForGhc String
file =
  String
-> DbOpenMode 'DbReadOnly Any
-> Get [DbUnitInfo]
-> IO ([DbUnitInfo], DbOpenMode 'DbReadOnly PackageDbLock)
forall (mode :: DbMode) t pkgs.
String
-> DbOpenMode mode t
-> Get pkgs
-> IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile String
file DbOpenMode 'DbReadOnly Any
forall t. DbOpenMode 'DbReadOnly t
DbOpenReadOnly Get [DbUnitInfo]
getDbForGhc IO ([DbUnitInfo], DbOpenMode 'DbReadOnly PackageDbLock)
-> (([DbUnitInfo], DbOpenMode 'DbReadOnly PackageDbLock)
    -> IO [DbUnitInfo])
-> IO [DbUnitInfo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ([DbUnitInfo]
pkgs, DbOpenMode 'DbReadOnly PackageDbLock
DbOpenReadOnly) -> [DbUnitInfo] -> IO [DbUnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [DbUnitInfo]
pkgs
  where
    getDbForGhc :: Get [DbUnitInfo]
getDbForGhc = do
      (Word32, Word32)
_version    <- Get (Word32, Word32)
getHeader
      Word32
_ghcPartLen <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
      [DbUnitInfo]
ghcPart     <- Get [DbUnitInfo]
forall t. Binary t => Get t
get
      -- the next part is for ghc-pkg, but we stop here.
      [DbUnitInfo] -> Get [DbUnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [DbUnitInfo]
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.
--
-- 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 :: String
-> DbOpenMode mode t -> IO (pkgs, DbOpenMode mode PackageDbLock)
readPackageDbForGhcPkg String
file DbOpenMode mode t
mode =
    String
-> DbOpenMode mode t
-> Get pkgs
-> IO (pkgs, DbOpenMode mode PackageDbLock)
forall (mode :: DbMode) t pkgs.
String
-> DbOpenMode mode t
-> Get pkgs
-> IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile String
file DbOpenMode mode t
mode Get pkgs
getDbForGhcPkg
  where
    getDbForGhcPkg :: Get pkgs
getDbForGhcPkg = do
      (Word32, Word32)
_version    <- Get (Word32, Word32)
getHeader
      -- skip over the ghc part
      Word32
ghcPartLen  <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
      ()
_ghcPart    <- Int -> Get ()
skip (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ghcPartLen)
      -- the next part is for ghc-pkg
      pkgs
ghcPkgPart  <- Get pkgs
forall t. Binary t => Get t
get
      pkgs -> Get pkgs
forall (m :: * -> *) a. Monad m => a -> m a
return pkgs
ghcPkgPart

-- | Write the whole of the package DB, both parts.
--
writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()
writePackageDb :: String -> [DbUnitInfo] -> pkgs -> IO ()
writePackageDb String
file [DbUnitInfo]
ghcPkgs pkgs
ghcPkgPart =
  String -> ByteString -> IO ()
writeFileAtomic String
file (Put -> ByteString
runPut Put
putDbForGhcPkg)
  where
    putDbForGhcPkg :: Put
putDbForGhcPkg = do
        Put
putHeader
        Word32 -> Put
forall t. Binary t => t -> Put
put               Word32
ghcPartLen
        ByteString -> Put
putLazyByteString ByteString
ghcPart
        pkgs -> Put
forall t. Binary t => t -> Put
put               pkgs
ghcPkgPart
      where
        ghcPartLen :: Word32
        ghcPartLen :: Word32
ghcPartLen = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
BS.Lazy.length ByteString
ghcPart)
        ghcPart :: ByteString
ghcPart    = [DbUnitInfo] -> ByteString
forall a. Binary a => a -> ByteString
encode [DbUnitInfo]
ghcPkgs

getHeader :: Get (Word32, Word32)
getHeader :: Get (Word32, Word32)
getHeader = do
    ByteString
magic <- Int -> Get ByteString
getByteString (ByteString -> Int
BS.length ByteString
headerMagic)
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
headerMagic) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a ghc-pkg db file, wrong file magic number"

    Word32
majorVersion <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
    -- The major version is for incompatible changes

    Word32
minorVersion <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
    -- The minor version is for compatible extensions

    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
majorVersion Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
1) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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).
    Word32
headerExtraLen <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
    Int -> Get ()
skip (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
headerExtraLen)

    (Word32, Word32) -> Get (Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
majorVersion, Word32
minorVersion)

putHeader :: Put
putHeader :: Put
putHeader = do
    ByteString -> Put
putByteString ByteString
headerMagic
    Word32 -> Put
forall t. Binary t => t -> Put
put Word32
majorVersion
    Word32 -> Put
forall t. Binary t => t -> Put
put Word32
minorVersion
    Word32 -> Put
forall t. Binary t => t -> Put
put Word32
headerExtraLen
  where
    majorVersion :: Word32
majorVersion   = Word32
1 :: Word32
    minorVersion :: Word32
minorVersion   = Word32
0 :: Word32
    headerExtraLen :: Word32
headerExtraLen = Word32
0 :: Word32

headerMagic :: BS.ByteString
headerMagic :: ByteString
headerMagic = String -> ByteString
BS.Char8.pack String
"\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 -> DbOpenMode mode t -> Get pkgs ->
                  IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile :: String
-> DbOpenMode mode t
-> Get pkgs
-> IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile String
file DbOpenMode mode t
mode Get pkgs
decoder = case DbOpenMode mode t
mode of
  DbOpenMode mode t
DbOpenReadOnly -> do
  -- Note [Locking package database on Windows]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- 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 defined(mingw32_HOST_OS)
    bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
#endif
      (, DbOpenMode 'DbReadOnly PackageDbLock
forall t. DbOpenMode 'DbReadOnly t
DbOpenReadOnly) (pkgs -> (pkgs, DbOpenMode 'DbReadOnly PackageDbLock))
-> IO pkgs -> IO (pkgs, DbOpenMode 'DbReadOnly PackageDbLock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO pkgs
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.
    IO PackageDbLock
-> (PackageDbLock -> IO ())
-> (PackageDbLock
    -> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock))
-> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (String -> IO PackageDbLock
lockPackageDb String
file) PackageDbLock -> IO ()
unlockPackageDb ((PackageDbLock
  -> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock))
 -> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock))
-> (PackageDbLock
    -> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock))
-> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock)
forall a b. (a -> b) -> a -> b
$ \PackageDbLock
lock -> do
      (, PackageDbLock -> DbOpenMode 'DbReadWrite PackageDbLock
forall t. t -> DbOpenMode 'DbReadWrite t
DbOpenReadWrite PackageDbLock
lock) (pkgs -> (pkgs, DbOpenMode 'DbReadWrite PackageDbLock))
-> IO pkgs -> IO (pkgs, DbOpenMode 'DbReadWrite PackageDbLock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO pkgs
decodeFileContents
  where
    decodeFileContents :: IO pkgs
decodeFileContents = String -> IOMode -> (Handle -> IO pkgs) -> IO pkgs
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
file IOMode
ReadMode ((Handle -> IO pkgs) -> IO pkgs) -> (Handle -> IO pkgs) -> IO pkgs
forall a b. (a -> b) -> a -> b
$ \Handle
hnd ->
      Handle -> Decoder pkgs -> IO pkgs
feed Handle
hnd (Get pkgs -> Decoder pkgs
forall a. Get a -> Decoder a
runGetIncremental Get pkgs
decoder)

    feed :: Handle -> Decoder pkgs -> IO pkgs
feed Handle
hnd (Partial Maybe ByteString -> Decoder pkgs
k)  = do ByteString
chunk <- Handle -> Int -> IO ByteString
BS.hGet Handle
hnd Int
BS.Lazy.defaultChunkSize
                               if ByteString -> Bool
BS.null ByteString
chunk
                                 then Handle -> Decoder pkgs -> IO pkgs
feed Handle
hnd (Maybe ByteString -> Decoder pkgs
k Maybe ByteString
forall a. Maybe a
Nothing)
                                 else Handle -> Decoder pkgs -> IO pkgs
feed Handle
hnd (Maybe ByteString -> Decoder pkgs
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk))
    feed Handle
_ (Done ByteString
_ Int64
_ pkgs
res) = pkgs -> IO pkgs
forall (m :: * -> *) a. Monad m => a -> m a
return pkgs
res
    feed Handle
_ (Fail ByteString
_ Int64
_ String
msg) = IOError -> IO pkgs
forall a. IOError -> IO a
ioError IOError
err
      where
        err :: IOError
err = IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InappropriateType String
loc Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
file)
              IOError -> String -> IOError
`ioeSetErrorString` String
msg
        loc :: String
loc = String
"GHC.Unit.Database.readPackageDb"

-- Copied from Cabal's Distribution.Simple.Utils.
writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
writeFileAtomic :: String -> ByteString -> IO ()
writeFileAtomic String
targetPath ByteString
content = do
  let (String
targetDir, String
targetFile) = String -> (String, String)
splitFileName String
targetPath
  IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracketOnError
    (String -> String -> IO (String, Handle)
openBinaryTempFileWithDefaultPermissions String
targetDir (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
targetFile String -> ShowS
<.> String
"tmp")
    (\(String
tmpPath, Handle
handle) -> Handle -> IO ()
hClose Handle
handle IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeFile String
tmpPath)
    (\(String
tmpPath, Handle
handle) -> do
        Handle -> ByteString -> IO ()
BS.Lazy.hPut Handle
handle ByteString
content
        Handle -> IO ()
hClose Handle
handle
        String -> String -> IO ()
renameFile String
tmpPath String
targetPath)

instance Binary DbUnitInfo where
  put :: DbUnitInfo -> Put
put (GenericUnitInfo
         ByteString
unitId ByteString
unitInstanceOf [(ByteString, DbModule)]
unitInstantiations
         ByteString
unitPackageId
         ByteString
unitPackageName Version
unitPackageVersion
         Maybe ByteString
unitComponentName
         String
unitAbiHash [ByteString]
unitDepends [(ByteString, String)]
unitAbiDepends [String]
unitImportDirs
         [String]
unitLibraries [String]
unitExtDepLibsSys [String]
unitExtDepLibsGhc
         [String]
unitLibraryDirs [String]
unitLibraryDynDirs
         [String]
unitExtDepFrameworks [String]
unitExtDepFrameworkDirs
         [String]
unitLinkerOptions [String]
unitCcOptions
         [String]
unitIncludes [String]
unitIncludeDirs
         [String]
unitHaddockInterfaces [String]
unitHaddockHTMLs
         [(ByteString, Maybe DbModule)]
unitExposedModules [ByteString]
unitHiddenModules
         Bool
unitIsIndefinite Bool
unitIsExposed Bool
unitIsTrusted) = do
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
unitPackageId
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
unitPackageName
    Version -> Put
forall t. Binary t => t -> Put
put Version
unitPackageVersion
    Maybe ByteString -> Put
forall t. Binary t => t -> Put
put Maybe ByteString
unitComponentName
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
unitId
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
unitInstanceOf
    [(ByteString, DbModule)] -> Put
forall t. Binary t => t -> Put
put [(ByteString, DbModule)]
unitInstantiations
    String -> Put
forall t. Binary t => t -> Put
put String
unitAbiHash
    [ByteString] -> Put
forall t. Binary t => t -> Put
put [ByteString]
unitDepends
    [(ByteString, String)] -> Put
forall t. Binary t => t -> Put
put [(ByteString, String)]
unitAbiDepends
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitImportDirs
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitLibraries
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitExtDepLibsSys
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitExtDepLibsGhc
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitLibraryDirs
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitLibraryDynDirs
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitExtDepFrameworks
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitExtDepFrameworkDirs
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitLinkerOptions
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitCcOptions
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitIncludes
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitIncludeDirs
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitHaddockInterfaces
    [String] -> Put
forall t. Binary t => t -> Put
put [String]
unitHaddockHTMLs
    [(ByteString, Maybe DbModule)] -> Put
forall t. Binary t => t -> Put
put [(ByteString, Maybe DbModule)]
unitExposedModules
    [ByteString] -> Put
forall t. Binary t => t -> Put
put [ByteString]
unitHiddenModules
    Bool -> Put
forall t. Binary t => t -> Put
put Bool
unitIsIndefinite
    Bool -> Put
forall t. Binary t => t -> Put
put Bool
unitIsExposed
    Bool -> Put
forall t. Binary t => t -> Put
put Bool
unitIsTrusted

  get :: Get DbUnitInfo
get = do
    ByteString
unitPackageId      <- Get ByteString
forall t. Binary t => Get t
get
    ByteString
unitPackageName    <- Get ByteString
forall t. Binary t => Get t
get
    Version
unitPackageVersion <- Get Version
forall t. Binary t => Get t
get
    Maybe ByteString
unitComponentName  <- Get (Maybe ByteString)
forall t. Binary t => Get t
get
    ByteString
unitId             <- Get ByteString
forall t. Binary t => Get t
get
    ByteString
unitInstanceOf     <- Get ByteString
forall t. Binary t => Get t
get
    [(ByteString, DbModule)]
unitInstantiations <- Get [(ByteString, DbModule)]
forall t. Binary t => Get t
get
    String
unitAbiHash        <- Get String
forall t. Binary t => Get t
get
    [ByteString]
unitDepends        <- Get [ByteString]
forall t. Binary t => Get t
get
    [(ByteString, String)]
unitAbiDepends     <- Get [(ByteString, String)]
forall t. Binary t => Get t
get
    [String]
unitImportDirs     <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitLibraries      <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitExtDepLibsSys  <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitExtDepLibsGhc  <- Get [String]
forall t. Binary t => Get t
get
    [String]
libraryDirs        <- Get [String]
forall t. Binary t => Get t
get
    [String]
libraryDynDirs     <- Get [String]
forall t. Binary t => Get t
get
    [String]
frameworks         <- Get [String]
forall t. Binary t => Get t
get
    [String]
frameworkDirs      <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitLinkerOptions  <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitCcOptions      <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitIncludes       <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitIncludeDirs    <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitHaddockInterfaces <- Get [String]
forall t. Binary t => Get t
get
    [String]
unitHaddockHTMLs   <- Get [String]
forall t. Binary t => Get t
get
    [(ByteString, Maybe DbModule)]
unitExposedModules <- Get [(ByteString, Maybe DbModule)]
forall t. Binary t => Get t
get
    [ByteString]
unitHiddenModules  <- Get [ByteString]
forall t. Binary t => Get t
get
    Bool
unitIsIndefinite   <- Get Bool
forall t. Binary t => Get t
get
    Bool
unitIsExposed      <- Get Bool
forall t. Binary t => Get t
get
    Bool
unitIsTrusted      <- Get Bool
forall t. Binary t => Get t
get
    DbUnitInfo -> Get DbUnitInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
-> ByteString
-> [(ByteString, DbModule)]
-> ByteString
-> ByteString
-> Version
-> Maybe ByteString
-> String
-> [ByteString]
-> [(ByteString, String)]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [(ByteString, Maybe DbModule)]
-> [ByteString]
-> Bool
-> Bool
-> Bool
-> DbUnitInfo
forall compid srcpkgid srcpkgname uid modulename mod.
uid
-> compid
-> [(modulename, mod)]
-> srcpkgid
-> srcpkgname
-> Version
-> Maybe srcpkgname
-> String
-> [uid]
-> [(uid, String)]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [(modulename, Maybe mod)]
-> [modulename]
-> Bool
-> Bool
-> Bool
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
GenericUnitInfo
              ByteString
unitId
              ByteString
unitInstanceOf
              [(ByteString, DbModule)]
unitInstantiations
              ByteString
unitPackageId
              ByteString
unitPackageName
              Version
unitPackageVersion
              Maybe ByteString
unitComponentName
              String
unitAbiHash
              [ByteString]
unitDepends
              [(ByteString, String)]
unitAbiDepends
              [String]
unitImportDirs
              [String]
unitLibraries [String]
unitExtDepLibsSys [String]
unitExtDepLibsGhc
              [String]
libraryDirs [String]
libraryDynDirs
              [String]
frameworks [String]
frameworkDirs
              [String]
unitLinkerOptions [String]
unitCcOptions
              [String]
unitIncludes [String]
unitIncludeDirs
              [String]
unitHaddockInterfaces [String]
unitHaddockHTMLs
              [(ByteString, Maybe DbModule)]
unitExposedModules
              [ByteString]
unitHiddenModules
              Bool
unitIsIndefinite Bool
unitIsExposed Bool
unitIsTrusted)

instance Binary DbModule where
  put :: DbModule -> Put
put (DbModule DbInstUnitId
dbModuleUnitId ByteString
dbModuleName) = do
    Word8 -> Put
putWord8 Word8
0
    DbInstUnitId -> Put
forall t. Binary t => t -> Put
put DbInstUnitId
dbModuleUnitId
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
dbModuleName
  put (DbModuleVar ByteString
dbModuleVarName) = do
    Word8 -> Put
putWord8 Word8
1
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
dbModuleVarName
  get :: Get DbModule
get = do
    Word8
b <- Get Word8
getWord8
    case Word8
b of
      Word8
0 -> DbInstUnitId -> ByteString -> DbModule
DbModule (DbInstUnitId -> ByteString -> DbModule)
-> Get DbInstUnitId -> Get (ByteString -> DbModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get DbInstUnitId
forall t. Binary t => Get t
get Get (ByteString -> DbModule) -> Get ByteString -> Get DbModule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
forall t. Binary t => Get t
get
      Word8
_ -> ByteString -> DbModule
DbModuleVar (ByteString -> DbModule) -> Get ByteString -> Get DbModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get

instance Binary DbInstUnitId where
  put :: DbInstUnitId -> Put
put (DbUnitId ByteString
uid) = do
    Word8 -> Put
putWord8 Word8
0
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
uid
  put (DbInstUnitId ByteString
dbUnitIdComponentId [(ByteString, DbModule)]
dbUnitIdInsts) = do
    Word8 -> Put
putWord8 Word8
1
    ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
dbUnitIdComponentId
    [(ByteString, DbModule)] -> Put
forall t. Binary t => t -> Put
put [(ByteString, DbModule)]
dbUnitIdInsts

  get :: Get DbInstUnitId
get = do
    Word8
b <- Get Word8
getWord8
    case Word8
b of
      Word8
0 -> ByteString -> DbInstUnitId
DbUnitId (ByteString -> DbInstUnitId) -> Get ByteString -> Get DbInstUnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get
      Word8
_ -> ByteString -> [(ByteString, DbModule)] -> DbInstUnitId
DbInstUnitId (ByteString -> [(ByteString, DbModule)] -> DbInstUnitId)
-> Get ByteString -> Get ([(ByteString, DbModule)] -> DbInstUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get Get ([(ByteString, DbModule)] -> DbInstUnitId)
-> Get [(ByteString, DbModule)] -> Get DbInstUnitId
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [(ByteString, DbModule)]
forall t. Binary t => Get t
get


-- | Return functions to perform path/URL variable substitution as per the Cabal
-- ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
--
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mkMungePathUrl :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath)
mkMungePathUrl :: String -> String -> (ShowS, ShowS)
mkMungePathUrl String
top_dir String
pkgroot = (ShowS
munge_path, ShowS
munge_url)
   where
    munge_path :: ShowS
munge_path String
p
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"${pkgroot}" String
p = String
pkgroot String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p'
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"$topdir"    String
p = String
top_dir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p'
      | Bool
otherwise                                = String
p

    munge_url :: ShowS
munge_url String
p
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"${pkgrooturl}" String
p = String -> ShowS
toUrlPath String
pkgroot String
p'
      | Just String
p' <- String -> String -> Maybe String
stripVarPrefix String
"$httptopdir"   String
p = String -> ShowS
toUrlPath String
top_dir String
p'
      | Bool
otherwise                                   = String
p

    toUrlPath :: String -> ShowS
toUrlPath String
r String
p = String
"file:///"
                 -- URLs always use posix style '/' separators:
                 String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
FilePath.Posix.joinPath
                        (String
r String -> [String] -> [String]
forall a. a -> [a] -> [a]
: -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator)
                                       (String -> [String]
FilePath.splitDirectories String
p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix :: String -> String -> Maybe String
stripVarPrefix String
var String
path = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
var String
path of
                              Just [] -> String -> Maybe String
forall a. a -> Maybe a
Just []
                              Just cs :: String
cs@(Char
c : String
_) | Char -> Bool
isPathSeparator Char
c -> String -> Maybe String
forall a. a -> Maybe a
Just String
cs
                              Maybe String
_ -> Maybe String
forall a. Maybe a
Nothing


-- | Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungeUnitInfoPaths :: FilePath -> FilePath -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f
mungeUnitInfoPaths :: String
-> String
-> GenericUnitInfo a b c d e f
-> GenericUnitInfo a b c d e f
mungeUnitInfoPaths String
top_dir String
pkgroot GenericUnitInfo a b c d e f
pkg =
   -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs
    GenericUnitInfo a b c d e f
pkg
      { unitImportDirs :: [String]
unitImportDirs          = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitImportDirs GenericUnitInfo a b c d e f
pkg)
      , unitIncludeDirs :: [String]
unitIncludeDirs         = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludeDirs GenericUnitInfo a b c d e f
pkg)
      , unitLibraryDirs :: [String]
unitLibraryDirs         = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDirs GenericUnitInfo a b c d e f
pkg)
      , unitLibraryDynDirs :: [String]
unitLibraryDynDirs      = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDynDirs GenericUnitInfo a b c d e f
pkg)
      , unitExtDepFrameworkDirs :: [String]
unitExtDepFrameworkDirs = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworkDirs GenericUnitInfo a b c d e f
pkg)
      , unitHaddockInterfaces :: [String]
unitHaddockInterfaces   = [String] -> [String]
munge_paths (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitHaddockInterfaces GenericUnitInfo a b c d e f
pkg)
        -- haddock-html is allowed to be either a URL or a file
      , unitHaddockHTMLs :: [String]
unitHaddockHTMLs        = [String] -> [String]
munge_paths ([String] -> [String]
munge_urls (GenericUnitInfo a b c d e f -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitHaddockHTMLs GenericUnitInfo a b c d e f
pkg))
      }
   where
      munge_paths :: [String] -> [String]
munge_paths = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
munge_path
      munge_urls :: [String] -> [String]
munge_urls  = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
munge_url
      (ShowS
munge_path,ShowS
munge_url) = String -> String -> (ShowS, ShowS)
mkMungePathUrl String
top_dir String
pkgroot