{-# 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 #-}
{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- 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 Data.List (intersperse)
import Control.Exception as Exception
import Control.Monad (when)
import System.FilePath as FilePath
#if !defined(mingw32_HOST_OS)
import System.Posix.Files
import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing))
#endif
import System.IO
import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import qualified GHC.Data.ShortText as ST
import GHC.IO.Handle.Lock
import System.Directory

-- | @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
   { forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId             :: uid
      -- ^ Unique unit identifier that is used during compilation (e.g. to
      -- generate symbols).

   , forall compid srcpkgid srcpkgname uid modulename mod.
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.

   , forall compid srcpkgid srcpkgname uid modulename mod.
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

   , forall compid srcpkgid srcpkgname uid modulename mod.
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.

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

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

   , forall compid srcpkgid srcpkgname uid modulename mod.
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.

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

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

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

   , forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitImportDirs     :: [FilePathST]
      -- ^ Directories containing module interfaces

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

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

   , forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsGhc  :: [ST.ShortText]
      -- ^ 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.

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

   , forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDynDirs :: [FilePathST]
      -- ^ 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.

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

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

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

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

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

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

   , forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitHaddockInterfaces :: [FilePathST]
      -- ^ Paths to Haddock interface files for this unit

   , forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitHaddockHTMLs   :: [FilePathST]
      -- ^ Paths to Haddock directories containing HTML files

   , forall compid srcpkgid srcpkgname uid modulename mod.
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.

   , forall compid srcpkgid srcpkgname uid modulename mod.
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)

   , forall compid srcpkgid srcpkgname uid modulename mod.
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).

   , forall compid srcpkgid srcpkgname uid modulename mod.
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.

   , forall compid srcpkgid srcpkgname uid modulename mod.
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)

type FilePathST = ST.ShortText

-- | 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 :: forall uid1 uid2 cid1 cid2 srcpkg1 srcpkg2 srcpkgname1 srcpkgname2
       modname1 modname2 mod1 mod2.
(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]
[(uid1, ShortText)]
[(modname1, mod1)]
[(modname1, Maybe mod1)]
[ShortText]
Maybe srcpkgname1
Version
ShortText
unitIsTrusted :: Bool
unitIsExposed :: Bool
unitIsIndefinite :: Bool
unitHiddenModules :: [modname1]
unitExposedModules :: [(modname1, Maybe mod1)]
unitHaddockHTMLs :: [ShortText]
unitHaddockInterfaces :: [ShortText]
unitIncludeDirs :: [ShortText]
unitIncludes :: [ShortText]
unitCcOptions :: [ShortText]
unitLinkerOptions :: [ShortText]
unitExtDepFrameworkDirs :: [ShortText]
unitExtDepFrameworks :: [ShortText]
unitLibraryDynDirs :: [ShortText]
unitLibraryDirs :: [ShortText]
unitExtDepLibsGhc :: [ShortText]
unitExtDepLibsSys :: [ShortText]
unitLibraries :: [ShortText]
unitImportDirs :: [ShortText]
unitAbiDepends :: [(uid1, ShortText)]
unitDepends :: [uid1]
unitAbiHash :: ShortText
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
-> [ShortText]
unitHaddockInterfaces :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludes :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitCcOptions :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLinkerOptions :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworkDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworks :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDynDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsGhc :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsSys :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraries :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitImportDirs :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitAbiDepends :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(uid, ShortText)]
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
-> ShortText
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, ShortText)]
unitAbiDepends      = ((uid1, ShortText) -> (uid2, ShortText))
-> [(uid1, ShortText)] -> [(uid2, ShortText)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((uid1 -> uid2) -> (uid1, ShortText) -> (uid2, ShortText)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first uid1 -> uid2
fuid) [(uid1, ShortText)]
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 :: forall (mode :: DbMode) a. DbOpenMode mode a -> 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 :: forall pkgs (mode :: DbMode) t.
Binary pkgs =>
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 :: forall pkgs. Binary pkgs => 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 :: 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
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 mode PackageDbLock))
-> IO pkgs -> IO (pkgs, DbOpenMode mode 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 mode PackageDbLock))
-> IO (pkgs, DbOpenMode mode 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 mode PackageDbLock))
 -> IO (pkgs, DbOpenMode mode PackageDbLock))
-> (PackageDbLock -> IO (pkgs, DbOpenMode mode PackageDbLock))
-> IO (pkgs, DbOpenMode mode 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 mode PackageDbLock))
-> IO pkgs -> IO (pkgs, DbOpenMode mode 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
  -- Figure out how to update the file mode after we create the temporary file
  let no_update :: p -> m ()
no_update p
_path = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !defined(mingw32_HOST_OS)
  let on_error :: IOError -> IO (p -> m ())
on_error IOError
ioe =
          -- If the file doesn't yet exist then just use the default owner and
          -- mode.
          case IOError -> IOErrorType
ioe_type IOError
ioe of
            IOErrorType
NoSuchThing -> (p -> m ()) -> IO (p -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return p -> m ()
forall {m :: * -> *} {p}. Monad m => p -> m ()
no_update
            IOErrorType
_ -> IOError -> IO (p -> m ())
forall a. IOError -> IO a
ioError IOError
ioe
  let handleIO :: (IOException -> IO a) -> IO a -> IO a
      handleIO :: forall a. (IOError -> IO a) -> IO a -> IO a
handleIO = (IO a -> (IOError -> IO a) -> IO a)
-> (IOError -> IO a) -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> (IOError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
  String -> IO ()
set_metadata <- (IOError -> IO (String -> IO ()))
-> IO (String -> IO ()) -> IO (String -> IO ())
forall a. (IOError -> IO a) -> IO a -> IO a
handleIO IOError -> IO (String -> IO ())
forall {m :: * -> *} {p}. Monad m => IOError -> IO (p -> m ())
on_error (IO (String -> IO ()) -> IO (String -> IO ()))
-> IO (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ do
      FileStatus
status <- String -> IO FileStatus
getFileStatus String
targetPath
      (String -> IO ()) -> IO (String -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ \String
path -> do
        String -> FileMode -> IO ()
setFileMode String
path (FileStatus -> FileMode
fileMode FileStatus
status)
        String -> UserID -> GroupID -> IO ()
setOwnerAndGroup String
path (FileStatus -> UserID
fileOwner FileStatus
status) (FileStatus -> GroupID
fileGroup FileStatus
status)
#else
  let set_metadata = no_update
#endif

  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 -> IO ()
set_metadata String
tmpPath
        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
         ShortText
unitAbiHash [ByteString]
unitDepends [(ByteString, ShortText)]
unitAbiDepends [ShortText]
unitImportDirs
         [ShortText]
unitLibraries [ShortText]
unitExtDepLibsSys [ShortText]
unitExtDepLibsGhc
         [ShortText]
unitLibraryDirs [ShortText]
unitLibraryDynDirs
         [ShortText]
unitExtDepFrameworks [ShortText]
unitExtDepFrameworkDirs
         [ShortText]
unitLinkerOptions [ShortText]
unitCcOptions
         [ShortText]
unitIncludes [ShortText]
unitIncludeDirs
         [ShortText]
unitHaddockInterfaces [ShortText]
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
    ShortText -> Put
forall t. Binary t => t -> Put
put ShortText
unitAbiHash
    [ByteString] -> Put
forall t. Binary t => t -> Put
put [ByteString]
unitDepends
    [(ByteString, ShortText)] -> Put
forall t. Binary t => t -> Put
put [(ByteString, ShortText)]
unitAbiDepends
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitImportDirs
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitLibraries
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitExtDepLibsSys
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitExtDepLibsGhc
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitLibraryDirs
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitLibraryDynDirs
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitExtDepFrameworks
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitExtDepFrameworkDirs
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitLinkerOptions
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitCcOptions
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitIncludes
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitIncludeDirs
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
unitHaddockInterfaces
    [ShortText] -> Put
forall t. Binary t => t -> Put
put [ShortText]
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
    ShortText
unitAbiHash        <- Get ShortText
forall t. Binary t => Get t
get
    [ByteString]
unitDepends        <- Get [ByteString]
forall t. Binary t => Get t
get
    [(ByteString, ShortText)]
unitAbiDepends     <- Get [(ByteString, ShortText)]
forall t. Binary t => Get t
get
    [ShortText]
unitImportDirs     <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitLibraries      <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitExtDepLibsSys  <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitExtDepLibsGhc  <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
libraryDirs        <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
libraryDynDirs     <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
frameworks         <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
frameworkDirs      <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitLinkerOptions  <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitCcOptions      <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitIncludes       <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitIncludeDirs    <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitHaddockInterfaces <- Get [ShortText]
forall t. Binary t => Get t
get
    [ShortText]
unitHaddockHTMLs   <- Get [ShortText]
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
-> ShortText
-> [ByteString]
-> [(ByteString, ShortText)]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [(ByteString, Maybe DbModule)]
-> [ByteString]
-> Bool
-> Bool
-> Bool
-> DbUnitInfo
forall compid srcpkgid srcpkgname uid modulename mod.
uid
-> compid
-> [(modulename, mod)]
-> srcpkgid
-> srcpkgname
-> Version
-> Maybe srcpkgname
-> ShortText
-> [uid]
-> [(uid, ShortText)]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [ShortText]
-> [(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
              ShortText
unitAbiHash
              [ByteString]
unitDepends
              [(ByteString, ShortText)]
unitAbiDepends
              [ShortText]
unitImportDirs
              [ShortText]
unitLibraries [ShortText]
unitExtDepLibsSys [ShortText]
unitExtDepLibsGhc
              [ShortText]
libraryDirs [ShortText]
libraryDynDirs
              [ShortText]
frameworks [ShortText]
frameworkDirs
              [ShortText]
unitLinkerOptions [ShortText]
unitCcOptions
              [ShortText]
unitIncludes [ShortText]
unitIncludeDirs
              [ShortText]
unitHaddockInterfaces [ShortText]
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 :: FilePathST -> FilePathST -> (FilePathST -> FilePathST, FilePathST -> FilePathST)
mkMungePathUrl :: ShortText
-> ShortText -> (ShortText -> ShortText, ShortText -> ShortText)
mkMungePathUrl ShortText
top_dir ShortText
pkgroot = (ShortText -> ShortText
munge_path, ShortText -> ShortText
munge_url)
   where
    munge_path :: ShortText -> ShortText
munge_path ShortText
p
      | Just ShortText
p' <- ShortText -> ShortText -> Maybe ShortText
stripVarPrefix ShortText
"${pkgroot}" ShortText
p = ShortText -> ShortText -> ShortText
forall a. Monoid a => a -> a -> a
mappend ShortText
pkgroot ShortText
p'
      | Just ShortText
p' <- ShortText -> ShortText -> Maybe ShortText
stripVarPrefix ShortText
"$topdir"    ShortText
p = ShortText -> ShortText -> ShortText
forall a. Monoid a => a -> a -> a
mappend ShortText
top_dir ShortText
p'
      | Bool
otherwise                                = ShortText
p

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

    toUrlPath :: ShortText -> ShortText -> ShortText
toUrlPath ShortText
r ShortText
p = [ShortText] -> ShortText
forall a. Monoid a => [a] -> a
mconcat ([ShortText] -> ShortText) -> [ShortText] -> ShortText
forall a b. (a -> b) -> a -> b
$ ShortText
"file:///" ShortText -> [ShortText] -> [ShortText]
forall a. a -> [a] -> [a]
: (ShortText -> [ShortText] -> [ShortText]
forall a. a -> [a] -> [a]
intersperse ShortText
"/" (ShortText
r ShortText -> [ShortText] -> [ShortText]
forall a. a -> [a] -> [a]
: (ShortText -> [ShortText]
splitDirectories ShortText
p)))
                                          -- URLs always use posix style '/' separators

    -- We need to drop a leading "/" or "\\" if there is one:
    splitDirectories :: FilePathST -> [FilePathST]
    splitDirectories :: ShortText -> [ShortText]
splitDirectories ShortText
p  = (ShortText -> Bool) -> [ShortText] -> [ShortText]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ShortText -> Bool) -> ShortText -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> Bool
ST.null) ([ShortText] -> [ShortText]) -> [ShortText] -> [ShortText]
forall a b. (a -> b) -> a -> b
$ ShortText -> [ShortText]
ST.splitFilePath ShortText
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 :: ShortText -> ShortText -> Maybe ShortText
stripVarPrefix ShortText
var ShortText
path = case ShortText -> ShortText -> Maybe ShortText
ST.stripPrefix ShortText
var ShortText
path of
                              Just ShortText
"" -> ShortText -> Maybe ShortText
forall a. a -> Maybe a
Just ShortText
""
                              Just ShortText
cs | Char -> Bool
isPathSeparator (ShortText -> Char
ST.head ShortText
cs) -> ShortText -> Maybe ShortText
forall a. a -> Maybe a
Just ShortText
cs
                              Maybe ShortText
_ -> Maybe ShortText
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 :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f
mungeUnitInfoPaths :: forall a b c d e f.
ShortText
-> ShortText
-> GenericUnitInfo a b c d e f
-> GenericUnitInfo a b c d e f
mungeUnitInfoPaths ShortText
top_dir ShortText
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 :: [ShortText]
unitImportDirs          = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitImportDirs GenericUnitInfo a b c d e f
pkg)
      , unitIncludeDirs :: [ShortText]
unitIncludeDirs         = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs GenericUnitInfo a b c d e f
pkg)
      , unitLibraryDirs :: [ShortText]
unitLibraryDirs         = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirs GenericUnitInfo a b c d e f
pkg)
      , unitLibraryDynDirs :: [ShortText]
unitLibraryDynDirs      = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDynDirs GenericUnitInfo a b c d e f
pkg)
      , unitExtDepFrameworkDirs :: [ShortText]
unitExtDepFrameworkDirs = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworkDirs GenericUnitInfo a b c d e f
pkg)
      , unitHaddockInterfaces :: [ShortText]
unitHaddockInterfaces   = [ShortText] -> [ShortText]
munge_paths (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitHaddockInterfaces GenericUnitInfo a b c d e f
pkg)
        -- haddock-html is allowed to be either a URL or a file
      , unitHaddockHTMLs :: [ShortText]
unitHaddockHTMLs        = [ShortText] -> [ShortText]
munge_paths ([ShortText] -> [ShortText]
munge_urls (GenericUnitInfo a b c d e f -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitHaddockHTMLs GenericUnitInfo a b c d e f
pkg))
      }
   where
      munge_paths :: [ShortText] -> [ShortText]
munge_paths = (ShortText -> ShortText) -> [ShortText] -> [ShortText]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> ShortText
munge_path
      munge_urls :: [ShortText] -> [ShortText]
munge_urls  = (ShortText -> ShortText) -> [ShortText] -> [ShortText]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> ShortText
munge_url
      (ShortText -> ShortText
munge_path,ShortText -> ShortText
munge_url) = ShortText
-> ShortText -> (ShortText -> ShortText, ShortText -> ShortText)
mkMungePathUrl ShortText
top_dir ShortText
pkgroot