{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Register
-- Copyright   :  Isaac Jones 2003-2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module deals with registering and unregistering packages. There are a
-- couple ways it can do this, one is to do it directly. Another is to generate
-- a script that can be run later to do it. The idea here being that the user
-- is shielded from the details of what command to use for package registration
-- for a particular compiler. In practice this aspect was not especially
-- popular so we also provide a way to simply generate the package registration
-- file which then must be manually passed to @ghc-pkg@. It is possible to
-- generate registration information for where the package is to be installed,
-- or alternatively to register the package in place in the build tree. The
-- latter is occasionally handy, and will become more important when we try to
-- build multi-package systems.
--
-- This module does not delegate anything to the per-compiler modules but just
-- mixes it all in this module, which is rather unsatisfactory. The script
-- generation and the unregister feature are not well used or tested.
module Distribution.Simple.Register
  ( register
  , unregister
  , internalPackageDBPath
  , initPackageDB
  , doesPackageDBExist
  , createPackageDB
  , deletePackageDB
  , abiHash
  , invokeHcPkg
  , registerPackage
  , HcPkg.RegisterOptions (..)
  , HcPkg.defaultRegisterOptions
  , generateRegistrationInfo
  , inplaceInstalledPackageInfo
  , absoluteInstalledPackageInfo
  , generalInstalledPackageInfo
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo

import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.LocalBuildInfo

import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.PackageIndex as Index
import qualified Distribution.Simple.UHC as UHC

import Distribution.Backpack.DescribeUnitId
import Distribution.Compat.Graph (IsNode (nodeKey))
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.License (licenseFromSPDX, licenseToSPDX)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import Distribution.Simple.Program
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.Program.Script
import Distribution.Simple.Setup.Register
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Utils.MapAccum
import Distribution.Verbosity as Verbosity
import Distribution.Version
import System.Directory
import System.FilePath (isAbsolute, (<.>), (</>))

import qualified Data.ByteString.Lazy.Char8 as BS.Char8

-- -----------------------------------------------------------------------------
-- Registration

register
  :: PackageDescription
  -> LocalBuildInfo
  -> RegisterFlags
  -- ^ Install in the user's database?; verbose
  -> IO ()
register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
register PackageDescription
pkg_descr LocalBuildInfo
lbi0 RegisterFlags
flags =
  -- Duncan originally asked for us to not register/install files
  -- when there was no public library.  But with per-component
  -- configure, we legitimately need to install internal libraries
  -- so that we can get them.  So just unconditionally install.
  IO ()
doRegister
  where
    doRegister :: IO ()
doRegister = do
      [TargetInfo]
targets <- Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [String]
-> IO [TargetInfo]
readTargetInfos Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi0 (RegisterFlags -> [String]
regArgs RegisterFlags
flags)

      -- It's important to register in build order, because ghc-pkg
      -- will complain if a dependency is not registered.
      let componentsToRegister :: [TargetInfo]
componentsToRegister =
            PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo]
neededTargetsInBuildOrder' PackageDescription
pkg_descr LocalBuildInfo
lbi0 ((TargetInfo -> UnitId) -> [TargetInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map TargetInfo -> Key TargetInfo
TargetInfo -> UnitId
forall a. IsNode a => a -> Key a
nodeKey [TargetInfo]
targets)

      (InstalledPackageIndex
_, [Maybe InstalledPackageInfo]
ipi_mbs) <-
        (InstalledPackageIndex
 -> TargetInfo
 -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
-> InstalledPackageIndex
-> [TargetInfo]
-> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo])
forall (m :: * -> *) (t :: * -> *) a b c.
(Monad m, Traversable t) =>
(a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
mapAccumM ((InstalledPackageIndex
  -> TargetInfo
  -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
 -> InstalledPackageIndex
 -> [TargetInfo]
 -> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo]))
-> InstalledPackageIndex
-> (InstalledPackageIndex
    -> TargetInfo
    -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
-> [TargetInfo]
-> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo])
forall a b c. (a -> b -> c) -> b -> a -> c
`flip` LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi0 ((InstalledPackageIndex
  -> TargetInfo
  -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
 -> [TargetInfo]
 -> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo]))
-> [TargetInfo]
-> (InstalledPackageIndex
    -> TargetInfo
    -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
-> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo])
forall a b c. (a -> b -> c) -> b -> a -> c
`flip` [TargetInfo]
componentsToRegister ((InstalledPackageIndex
  -> TargetInfo
  -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
 -> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo]))
-> (InstalledPackageIndex
    -> TargetInfo
    -> IO (InstalledPackageIndex, Maybe InstalledPackageInfo))
-> IO (InstalledPackageIndex, [Maybe InstalledPackageInfo])
forall a b. (a -> b) -> a -> b
$ \InstalledPackageIndex
index TargetInfo
tgt ->
          case TargetInfo -> Component
targetComponent TargetInfo
tgt of
            CLib Library
lib -> do
              let clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
tgt
                  lbi :: LocalBuildInfo
lbi = LocalBuildInfo
lbi0{installedPkgs = index}
              InstalledPackageInfo
ipi <- PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> RegisterFlags
-> IO InstalledPackageInfo
generateOne PackageDescription
pkg_descr Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi RegisterFlags
flags
              (InstalledPackageIndex, Maybe InstalledPackageInfo)
-> IO (InstalledPackageIndex, Maybe InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
Index.insert InstalledPackageInfo
ipi InstalledPackageIndex
index, InstalledPackageInfo -> Maybe InstalledPackageInfo
forall a. a -> Maybe a
Just InstalledPackageInfo
ipi)
            Component
_ -> (InstalledPackageIndex, Maybe InstalledPackageInfo)
-> IO (InstalledPackageIndex, Maybe InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex
index, Maybe InstalledPackageInfo
forall a. Maybe a
Nothing)

      PackageDescription
-> LocalBuildInfo
-> RegisterFlags
-> [InstalledPackageInfo]
-> IO ()
registerAll PackageDescription
pkg_descr LocalBuildInfo
lbi0 RegisterFlags
flags ([Maybe InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. [Maybe a] -> [a]
catMaybes [Maybe InstalledPackageInfo]
ipi_mbs)
      where
        verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
flags)

generateOne
  :: PackageDescription
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> RegisterFlags
  -> IO InstalledPackageInfo
generateOne :: PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> RegisterFlags
-> IO InstalledPackageInfo
generateOne PackageDescription
pkg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi RegisterFlags
regFlags =
  do
    PackageDBStack
absPackageDBs <- PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths PackageDBStack
packageDbs
    InstalledPackageInfo
installedPkgInfo <-
      Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Bool
-> String
-> PackageDB
-> IO InstalledPackageInfo
generateRegistrationInfo
        Verbosity
verbosity
        PackageDescription
pkg
        Library
lib
        LocalBuildInfo
lbi
        ComponentLocalBuildInfo
clbi
        Bool
inplace
        Bool
reloc
        String
distPref
        (PackageDBStack -> PackageDB
registrationPackageDB PackageDBStack
absPackageDBs)
    Verbosity -> String -> IO ()
info Verbosity
verbosity (InstalledPackageInfo -> String
IPI.showInstalledPackageInfo InstalledPackageInfo
installedPkgInfo)
    InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
installedPkgInfo
  where
    inplace :: Bool
inplace = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regInPlace RegisterFlags
regFlags)
    reloc :: Bool
reloc = LocalBuildInfo -> Bool
relocatable LocalBuildInfo
lbi
    -- FIXME: there's really no guarantee this will work.
    -- registering into a totally different db stack can
    -- fail if dependencies cannot be satisfied.
    packageDbs :: PackageDBStack
packageDbs =
      PackageDBStack -> PackageDBStack
forall a. Eq a => [a] -> [a]
nub (PackageDBStack -> PackageDBStack)
-> PackageDBStack -> PackageDBStack
forall a b. (a -> b) -> a -> b
$
        LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
          PackageDBStack -> PackageDBStack -> PackageDBStack
forall a. [a] -> [a] -> [a]
++ Maybe PackageDB -> PackageDBStack
forall a. Maybe a -> [a]
maybeToList (Flag PackageDB -> Maybe PackageDB
forall a. Flag a -> Maybe a
flagToMaybe (RegisterFlags -> Flag PackageDB
regPackageDB RegisterFlags
regFlags))
    distPref :: String
distPref = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag String
regDistPref RegisterFlags
regFlags)
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)

registerAll
  :: PackageDescription
  -> LocalBuildInfo
  -> RegisterFlags
  -> [InstalledPackageInfo]
  -> IO ()
registerAll :: PackageDescription
-> LocalBuildInfo
-> RegisterFlags
-> [InstalledPackageInfo]
-> IO ()
registerAll PackageDescription
pkg LocalBuildInfo
lbi RegisterFlags
regFlags [InstalledPackageInfo]
ipis =
  do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regPrintId RegisterFlags
regFlags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [InstalledPackageInfo] -> (InstalledPackageInfo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [InstalledPackageInfo]
ipis ((InstalledPackageInfo -> IO ()) -> IO ())
-> (InstalledPackageInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledPackageInfo
installedPkgInfo ->
        -- Only print the public library's IPI
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
          ( InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
installedPkgInfo PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
              Bool -> Bool -> Bool
&& InstalledPackageInfo -> LibraryName
IPI.sourceLibName InstalledPackageInfo
installedPkgInfo LibraryName -> LibraryName -> Bool
forall a. Eq a => a -> a -> Bool
== LibraryName
LMainLibName
          )
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (UnitId -> String
forall a. Pretty a => a -> String
prettyShow (InstalledPackageInfo -> UnitId
IPI.installedUnitId InstalledPackageInfo
installedPkgInfo))

    -- Three different modes:
    case () of
      ()
_
        | Bool
modeGenerateRegFile -> IO ()
writeRegistrationFileOrDirectory
        | Bool
modeGenerateRegScript -> IO ()
writeRegisterScript
        | Bool
otherwise -> do
            [InstalledPackageInfo] -> (InstalledPackageInfo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [InstalledPackageInfo]
ipis ((InstalledPackageInfo -> IO ()) -> IO ())
-> (InstalledPackageInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledPackageInfo
ipi -> do
              Verbosity
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, OpenModule)]
-> IO ()
forall a.
Pretty a =>
Verbosity
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage'
                Verbosity
verbosity
                String
"Registering"
                (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg)
                (LibraryName -> ComponentName
CLibName (InstalledPackageInfo -> LibraryName
IPI.sourceLibName InstalledPackageInfo
ipi))
                ([(ModuleName, OpenModule)] -> Maybe [(ModuleName, OpenModule)]
forall a. a -> Maybe a
Just (InstalledPackageInfo -> [(ModuleName, OpenModule)]
IPI.instantiatedWith InstalledPackageInfo
ipi))
              Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage
                Verbosity
verbosity
                (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
                (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
                PackageDBStack
packageDbs
                InstalledPackageInfo
ipi
                RegisterOptions
HcPkg.defaultRegisterOptions
  where
    modeGenerateRegFile :: Bool
modeGenerateRegFile = Maybe (Maybe String) -> Bool
forall a. Maybe a -> Bool
isJust (Flag (Maybe String) -> Maybe (Maybe String)
forall a. Flag a -> Maybe a
flagToMaybe (RegisterFlags -> Flag (Maybe String)
regGenPkgConf RegisterFlags
regFlags))
    regFile :: String
regFile =
      String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe
        (PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) String -> String -> String
<.> String
"conf")
        (Flag (Maybe String) -> Maybe String
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag (Maybe String)
regGenPkgConf RegisterFlags
regFlags))

    modeGenerateRegScript :: Bool
modeGenerateRegScript = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regGenScript RegisterFlags
regFlags)

    -- FIXME: there's really no guarantee this will work.
    -- registering into a totally different db stack can
    -- fail if dependencies cannot be satisfied.
    packageDbs :: PackageDBStack
packageDbs =
      PackageDBStack -> PackageDBStack
forall a. Eq a => [a] -> [a]
nub (PackageDBStack -> PackageDBStack)
-> PackageDBStack -> PackageDBStack
forall a b. (a -> b) -> a -> b
$
        LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
          PackageDBStack -> PackageDBStack -> PackageDBStack
forall a. [a] -> [a] -> [a]
++ Maybe PackageDB -> PackageDBStack
forall a. Maybe a -> [a]
maybeToList (Flag PackageDB -> Maybe PackageDB
forall a. Flag a -> Maybe a
flagToMaybe (RegisterFlags -> Flag PackageDB
regPackageDB RegisterFlags
regFlags))
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)

    writeRegistrationFileOrDirectory :: IO ()
writeRegistrationFileOrDirectory = do
      -- Handles overwriting both directory and file
      String -> IO ()
deletePackageDB String
regFile
      case [InstalledPackageInfo]
ipis of
        [InstalledPackageInfo
installedPkgInfo] -> do
          Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Creating package registration file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
regFile)
          String -> String -> IO ()
writeUTF8File String
regFile (InstalledPackageInfo -> String
IPI.showInstalledPackageInfo InstalledPackageInfo
installedPkgInfo)
        [InstalledPackageInfo]
_ -> do
          Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Creating package registration directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
regFile)
          String -> IO ()
createDirectory String
regFile
          let num_ipis :: Int
num_ipis = [InstalledPackageInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InstalledPackageInfo]
ipis
              lpad :: Int -> String -> String
lpad Int
m String
xs = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ys
                where
                  ys :: String
ys = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
m String
xs
              number :: a -> String
number a
i = Int -> String -> String
lpad (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
num_ipis)) (a -> String
forall a. Show a => a -> String
show a
i)
          [(Int, InstalledPackageInfo)]
-> ((Int, InstalledPackageInfo) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [InstalledPackageInfo] -> [(Int, InstalledPackageInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) [InstalledPackageInfo]
ipis) (((Int, InstalledPackageInfo) -> IO ()) -> IO ())
-> ((Int, InstalledPackageInfo) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, InstalledPackageInfo
installedPkgInfo) ->
            String -> String -> IO ()
writeUTF8File
              (String
regFile String -> String -> String
</> (Int -> String
forall a. Show a => a -> String
number Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (InstalledPackageInfo -> UnitId
IPI.installedUnitId InstalledPackageInfo
installedPkgInfo)))
              (InstalledPackageInfo -> String
IPI.showInstalledPackageInfo InstalledPackageInfo
installedPkgInfo)

    writeRegisterScript :: IO ()
writeRegisterScript =
      case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
        CompilerFlavor
UHC -> Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Registration scripts not needed for uhc"
        CompilerFlavor
_ ->
          Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO ()) -> IO ()
forall a.
Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO a) -> IO a
withHcPkg
            Verbosity
verbosity
            String
"Registration scripts are not implemented for this compiler"
            (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
            (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
            (Verbosity
-> [InstalledPackageInfo] -> PackageDBStack -> HcPkgInfo -> IO ()
writeHcPkgRegisterScript Verbosity
verbosity [InstalledPackageInfo]
ipis PackageDBStack
packageDbs)

generateRegistrationInfo
  :: Verbosity
  -> PackageDescription
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Bool
  -> Bool
  -> FilePath
  -> PackageDB
  -> IO InstalledPackageInfo
generateRegistrationInfo :: Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Bool
-> String
-> PackageDB
-> IO InstalledPackageInfo
generateRegistrationInfo Verbosity
verbosity PackageDescription
pkg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
inplace Bool
reloc String
distPref PackageDB
packageDb = do
  -- TODO: eliminate pwd!
  String
pwd <- IO String
getCurrentDirectory

  InstalledPackageInfo
installedPkgInfo <-
    if Bool
inplace
      then -- NB: With an inplace installation, the user may run './Setup
      -- build' to update the library files, without reregistering.
      -- In this case, it is critical that the ABI hash not flip.

        InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( String
-> String
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo
              String
pwd
              String
distPref
              PackageDescription
pkg
              (String -> AbiHash
mkAbiHash String
"inplace")
              Library
lib
              LocalBuildInfo
lbi
              ComponentLocalBuildInfo
clbi
          )
      else do
        AbiHash
abi_hash <- Verbosity
-> PackageDescription
-> String
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO AbiHash
abiHash Verbosity
verbosity PackageDescription
pkg String
distPref LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
        if Bool
reloc
          then
            Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> AbiHash
-> PackageDB
-> IO InstalledPackageInfo
relocRegistrationInfo
              Verbosity
verbosity
              PackageDescription
pkg
              Library
lib
              LocalBuildInfo
lbi
              ComponentLocalBuildInfo
clbi
              AbiHash
abi_hash
              PackageDB
packageDb
          else
            InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
absoluteInstalledPackageInfo
                  PackageDescription
pkg
                  AbiHash
abi_hash
                  Library
lib
                  LocalBuildInfo
lbi
                  ComponentLocalBuildInfo
clbi
              )

  InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
installedPkgInfo

-- | Compute the 'AbiHash' of a library that we built inplace.
abiHash
  :: Verbosity
  -> PackageDescription
  -> FilePath
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO AbiHash
abiHash :: Verbosity
-> PackageDescription
-> String
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO AbiHash
abiHash Verbosity
verbosity PackageDescription
pkg String
distPref LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi =
  case Compiler -> CompilerFlavor
compilerFlavor Compiler
comp of
    CompilerFlavor
GHC -> do
      (String -> AbiHash) -> IO String -> IO AbiHash
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> AbiHash
mkAbiHash (IO String -> IO AbiHash) -> IO String -> IO AbiHash
forall a b. (a -> b) -> a -> b
$ Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO String
GHC.libAbiHash Verbosity
verbosity PackageDescription
pkg LocalBuildInfo
lbi' Library
lib ComponentLocalBuildInfo
clbi
    CompilerFlavor
GHCJS -> do
      (String -> AbiHash) -> IO String -> IO AbiHash
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> AbiHash
mkAbiHash (IO String -> IO AbiHash) -> IO String -> IO AbiHash
forall a b. (a -> b) -> a -> b
$ Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO String
GHCJS.libAbiHash Verbosity
verbosity PackageDescription
pkg LocalBuildInfo
lbi' Library
lib ComponentLocalBuildInfo
clbi
    CompilerFlavor
_ -> AbiHash -> IO AbiHash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> AbiHash
mkAbiHash String
"")
  where
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    lbi' :: LocalBuildInfo
lbi' =
      LocalBuildInfo
lbi
        { withPackageDB =
            withPackageDB lbi
              ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
        }

relocRegistrationInfo
  :: Verbosity
  -> PackageDescription
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> AbiHash
  -> PackageDB
  -> IO InstalledPackageInfo
relocRegistrationInfo :: Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> AbiHash
-> PackageDB
-> IO InstalledPackageInfo
relocRegistrationInfo Verbosity
verbosity PackageDescription
pkg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi AbiHash
abi_hash PackageDB
packageDb =
  case (Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)) of
    CompilerFlavor
GHC -> do
      String
fs <- Verbosity -> LocalBuildInfo -> PackageDB -> IO String
GHC.pkgRoot Verbosity
verbosity LocalBuildInfo
lbi PackageDB
packageDb
      InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> InstalledPackageInfo
relocatableInstalledPackageInfo
            PackageDescription
pkg
            AbiHash
abi_hash
            Library
lib
            LocalBuildInfo
lbi
            ComponentLocalBuildInfo
clbi
            String
fs
        )
    CompilerFlavor
_ -> Verbosity -> CabalException -> IO InstalledPackageInfo
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
RelocRegistrationInfo

initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO ()
initPackageDB :: Verbosity -> Compiler -> ProgramDb -> String -> IO ()
initPackageDB Verbosity
verbosity Compiler
comp ProgramDb
progdb String
dbPath =
  Verbosity -> Compiler -> ProgramDb -> Bool -> String -> IO ()
createPackageDB Verbosity
verbosity Compiler
comp ProgramDb
progdb Bool
False String
dbPath

-- | Create an empty package DB at the specified location.
createPackageDB
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> Bool
  -> FilePath
  -> IO ()
createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool -> String -> IO ()
createPackageDB Verbosity
verbosity Compiler
comp ProgramDb
progdb Bool
preferCompat String
dbPath =
  case Compiler -> CompilerFlavor
compilerFlavor Compiler
comp of
    CompilerFlavor
GHC -> HcPkgInfo -> Verbosity -> Bool -> String -> IO ()
HcPkg.init (ProgramDb -> HcPkgInfo
GHC.hcPkgInfo ProgramDb
progdb) Verbosity
verbosity Bool
preferCompat String
dbPath
    CompilerFlavor
GHCJS -> HcPkgInfo -> Verbosity -> Bool -> String -> IO ()
HcPkg.init (ProgramDb -> HcPkgInfo
GHCJS.hcPkgInfo ProgramDb
progdb) Verbosity
verbosity Bool
False String
dbPath
    CompilerFlavor
UHC -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    HaskellSuite String
_ -> Verbosity -> ProgramDb -> String -> IO ()
HaskellSuite.initPackageDB Verbosity
verbosity ProgramDb
progdb String
dbPath
    CompilerFlavor
_ -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
CreatePackageDB

doesPackageDBExist :: FilePath -> IO Bool
doesPackageDBExist :: String -> IO Bool
doesPackageDBExist String
dbPath = do
  -- currently one impl for all compiler flavours, but could change if needed
  Bool
dir_exists <- String -> IO Bool
doesDirectoryExist String
dbPath
  if Bool
dir_exists
    then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else String -> IO Bool
doesFileExist String
dbPath

deletePackageDB :: FilePath -> IO ()
deletePackageDB :: String -> IO ()
deletePackageDB String
dbPath = do
  -- currently one impl for all compiler flavours, but could change if needed
  Bool
dir_exists <- String -> IO Bool
doesDirectoryExist String
dbPath
  if Bool
dir_exists
    then String -> IO ()
removeDirectoryRecursive String
dbPath
    else do
      Bool
file_exists <- String -> IO Bool
doesFileExist String
dbPath
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
file_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
dbPath

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invokeHcPkg
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> PackageDBStack
  -> [String]
  -> IO ()
invokeHcPkg :: Verbosity
-> Compiler -> ProgramDb -> PackageDBStack -> [String] -> IO ()
invokeHcPkg Verbosity
verbosity Compiler
comp ProgramDb
progdb PackageDBStack
dbStack [String]
extraArgs =
  Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO ()) -> IO ()
forall a.
Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO a) -> IO a
withHcPkg
    Verbosity
verbosity
    String
"invokeHcPkg"
    Compiler
comp
    ProgramDb
progdb
    (\HcPkgInfo
hpi -> HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
HcPkg.invoke HcPkgInfo
hpi Verbosity
verbosity PackageDBStack
dbStack [String]
extraArgs)

withHcPkg
  :: Verbosity
  -> String
  -> Compiler
  -> ProgramDb
  -> (HcPkg.HcPkgInfo -> IO a)
  -> IO a
withHcPkg :: forall a.
Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO a) -> IO a
withHcPkg Verbosity
verbosity String
name Compiler
comp ProgramDb
progdb HcPkgInfo -> IO a
f =
  case Compiler -> CompilerFlavor
compilerFlavor Compiler
comp of
    CompilerFlavor
GHC -> HcPkgInfo -> IO a
f (ProgramDb -> HcPkgInfo
GHC.hcPkgInfo ProgramDb
progdb)
    CompilerFlavor
GHCJS -> HcPkgInfo -> IO a
f (ProgramDb -> HcPkgInfo
GHCJS.hcPkgInfo ProgramDb
progdb)
    CompilerFlavor
_ -> Verbosity -> CabalException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO a) -> CabalException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> CabalException
WithHcPkg String
name

registerPackage
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> PackageDBStack
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity Compiler
comp ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  case Compiler -> CompilerFlavor
compilerFlavor Compiler
comp of
    CompilerFlavor
GHC -> Verbosity
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
GHC.registerPackage Verbosity
verbosity ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions
    CompilerFlavor
GHCJS -> Verbosity
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
GHCJS.registerPackage Verbosity
verbosity ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions
    HaskellSuite{} ->
      Verbosity
-> ProgramDb -> PackageDBStack -> InstalledPackageInfo -> IO ()
HaskellSuite.registerPackage Verbosity
verbosity ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo
    CompilerFlavor
_
      | RegisterOptions -> Bool
HcPkg.registerMultiInstance RegisterOptions
registerOptions ->
          Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
RegisMultiplePkgNotSupported
    CompilerFlavor
UHC -> Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> IO ()
UHC.registerPackage Verbosity
verbosity Compiler
comp ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo
    CompilerFlavor
_ -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
RegisteringNotImplemented

writeHcPkgRegisterScript
  :: Verbosity
  -> [InstalledPackageInfo]
  -> PackageDBStack
  -> HcPkg.HcPkgInfo
  -> IO ()
writeHcPkgRegisterScript :: Verbosity
-> [InstalledPackageInfo] -> PackageDBStack -> HcPkgInfo -> IO ()
writeHcPkgRegisterScript Verbosity
verbosity [InstalledPackageInfo]
ipis PackageDBStack
packageDbs HcPkgInfo
hpi = do
  let genScript :: InstalledPackageInfo -> String
genScript InstalledPackageInfo
installedPkgInfo =
        let invocation :: ProgramInvocation
invocation =
              HcPkgInfo
-> Verbosity
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
HcPkg.registerInvocation
                HcPkgInfo
hpi
                Verbosity
Verbosity.normal
                PackageDBStack
packageDbs
                InstalledPackageInfo
installedPkgInfo
                RegisterOptions
HcPkg.defaultRegisterOptions
         in OS -> ProgramInvocation -> String
invocationAsSystemScript OS
buildOS ProgramInvocation
invocation
      scripts :: [String]
scripts = (InstalledPackageInfo -> String)
-> [InstalledPackageInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> String
genScript [InstalledPackageInfo]
ipis
      -- TODO: Do something more robust here
      regScript :: String
regScript = [String] -> String
unlines [String]
scripts

  Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Creating package registration script: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
regScriptFileName)
  String -> String -> IO ()
writeUTF8File String
regScriptFileName String
regScript
  String -> IO ()
setFileExecutable String
regScriptFileName

regScriptFileName :: FilePath
regScriptFileName :: String
regScriptFileName = case OS
buildOS of
  OS
Windows -> String
"register.bat"
  OS
_ -> String
"register.sh"

-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

-- | Construct 'InstalledPackageInfo' for a library in a package, given a set
-- of installation directories.
generalInstalledPackageInfo
  :: ([FilePath] -> [FilePath])
  -- ^ Translate relative include dir paths to
  -- absolute paths.
  -> PackageDescription
  -> AbiHash
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> InstallDirs FilePath
  -> InstalledPackageInfo
generalInstalledPackageInfo :: ([String] -> [String])
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstallDirs String
-> InstalledPackageInfo
generalInstalledPackageInfo [String] -> [String]
adjustRelIncDirs PackageDescription
pkg AbiHash
abi_hash Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi InstallDirs String
installDirs =
  IPI.InstalledPackageInfo
    { sourcePackageId :: PackageIdentifier
IPI.sourcePackageId = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
    , installedUnitId :: UnitId
IPI.installedUnitId = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
    , installedComponentId_ :: ComponentId
IPI.installedComponentId_ = ComponentLocalBuildInfo -> ComponentId
componentComponentId ComponentLocalBuildInfo
clbi
    , instantiatedWith :: [(ModuleName, OpenModule)]
IPI.instantiatedWith = ComponentLocalBuildInfo -> [(ModuleName, OpenModule)]
componentInstantiatedWith ComponentLocalBuildInfo
clbi
    , sourceLibName :: LibraryName
IPI.sourceLibName = Library -> LibraryName
libName Library
lib
    , compatPackageKey :: String
IPI.compatPackageKey = ComponentLocalBuildInfo -> String
componentCompatPackageKey ComponentLocalBuildInfo
clbi
    , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
      license :: Either License License
IPI.license =
        if Bool
ghc84
          then License -> Either License License
forall a b. a -> Either a b
Left (License -> Either License License)
-> License -> Either License License
forall a b. (a -> b) -> a -> b
$ (License -> License)
-> (License -> License) -> Either License License -> License
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either License -> License
forall a. a -> a
id License -> License
licenseToSPDX (Either License License -> License)
-> Either License License -> License
forall a b. (a -> b) -> a -> b
$ PackageDescription -> Either License License
licenseRaw PackageDescription
pkg
          else License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> License -> Either License License
forall a b. (a -> b) -> a -> b
$ (License -> License)
-> (License -> License) -> Either License License -> License
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either License -> License
licenseFromSPDX License -> License
forall a. a -> a
id (Either License License -> License)
-> Either License License -> License
forall a b. (a -> b) -> a -> b
$ PackageDescription -> Either License License
licenseRaw PackageDescription
pkg
    , copyright :: ShortText
IPI.copyright = PackageDescription -> ShortText
copyright PackageDescription
pkg
    , maintainer :: ShortText
IPI.maintainer = PackageDescription -> ShortText
maintainer PackageDescription
pkg
    , author :: ShortText
IPI.author = PackageDescription -> ShortText
author PackageDescription
pkg
    , stability :: ShortText
IPI.stability = PackageDescription -> ShortText
stability PackageDescription
pkg
    , homepage :: ShortText
IPI.homepage = PackageDescription -> ShortText
homepage PackageDescription
pkg
    , pkgUrl :: ShortText
IPI.pkgUrl = PackageDescription -> ShortText
pkgUrl PackageDescription
pkg
    , synopsis :: ShortText
IPI.synopsis = PackageDescription -> ShortText
synopsis PackageDescription
pkg
    , description :: ShortText
IPI.description = PackageDescription -> ShortText
description PackageDescription
pkg
    , category :: ShortText
IPI.category = PackageDescription -> ShortText
category PackageDescription
pkg
    , abiHash :: AbiHash
IPI.abiHash = AbiHash
abi_hash
    , indefinite :: Bool
IPI.indefinite = ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi
    , exposed :: Bool
IPI.exposed = Library -> Bool
libExposed Library
lib
    , exposedModules :: [ExposedModule]
IPI.exposedModules =
        ComponentLocalBuildInfo -> [ExposedModule]
componentExposedModules ComponentLocalBuildInfo
clbi
          -- add virtual modules into the list of exposed modules for the
          -- package database as well.
          [ExposedModule] -> [ExposedModule] -> [ExposedModule]
forall a. [a] -> [a] -> [a]
++ (ModuleName -> ExposedModule) -> [ModuleName] -> [ExposedModule]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
name -> ModuleName -> Maybe OpenModule -> ExposedModule
IPI.ExposedModule ModuleName
name Maybe OpenModule
forall a. Maybe a
Nothing) (BuildInfo -> [ModuleName]
virtualModules BuildInfo
bi)
    , hiddenModules :: [ModuleName]
IPI.hiddenModules = BuildInfo -> [ModuleName]
otherModules BuildInfo
bi
    , trusted :: Bool
IPI.trusted = InstalledPackageInfo -> Bool
IPI.trusted InstalledPackageInfo
IPI.emptyInstalledPackageInfo
    , importDirs :: [String]
IPI.importDirs = [InstallDirs String -> String
forall dir. InstallDirs dir -> dir
libdir InstallDirs String
installDirs | Bool
hasModules]
    , libraryDirs :: [String]
IPI.libraryDirs = [String]
libdirs
    , libraryDirsStatic :: [String]
IPI.libraryDirsStatic = [String]
libdirsStatic
    , libraryDynDirs :: [String]
IPI.libraryDynDirs = [String]
dynlibdirs
    , dataDir :: String
IPI.dataDir = InstallDirs String -> String
forall dir. InstallDirs dir -> dir
datadir InstallDirs String
installDirs
    , hsLibraries :: [String]
IPI.hsLibraries =
        ( if Bool
hasLibrary
            then [UnitId -> String
getHSLibraryName (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi)]
            else []
        )
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
extraBundledLibs BuildInfo
bi
    , extraLibraries :: [String]
IPI.extraLibraries = BuildInfo -> [String]
extraLibs BuildInfo
bi
    , extraLibrariesStatic :: [String]
IPI.extraLibrariesStatic = BuildInfo -> [String]
extraLibsStatic BuildInfo
bi
    , extraGHCiLibraries :: [String]
IPI.extraGHCiLibraries = BuildInfo -> [String]
extraGHCiLibs BuildInfo
bi
    , includeDirs :: [String]
IPI.includeDirs = [String]
absinc [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
adjustRelIncDirs [String]
relinc
    , includes :: [String]
IPI.includes = BuildInfo -> [String]
includes BuildInfo
bi
    , depends :: [UnitId]
IPI.depends = [UnitId]
depends
    , abiDepends :: [AbiDependency]
IPI.abiDepends = [] -- due to #5465
    , ccOptions :: [String]
IPI.ccOptions = [] -- Note. NOT ccOptions bi!
    -- We don't want cc-options to be propagated
    -- to C compilations in other packages.
    , cxxOptions :: [String]
IPI.cxxOptions = [] -- Also. NOT cxxOptions bi!
    , ldOptions :: [String]
IPI.ldOptions = BuildInfo -> [String]
ldOptions BuildInfo
bi
    , frameworks :: [String]
IPI.frameworks = BuildInfo -> [String]
frameworks BuildInfo
bi
    , frameworkDirs :: [String]
IPI.frameworkDirs = BuildInfo -> [String]
extraFrameworkDirs BuildInfo
bi
    , haddockInterfaces :: [String]
IPI.haddockInterfaces = [InstallDirs String -> String
forall dir. InstallDirs dir -> dir
haddockdir InstallDirs String
installDirs String -> String -> String
</> PackageDescription -> String
haddockName PackageDescription
pkg]
    , haddockHTMLs :: [String]
IPI.haddockHTMLs = [InstallDirs String -> String
forall dir. InstallDirs dir -> dir
htmldir InstallDirs String
installDirs]
    , pkgRoot :: Maybe String
IPI.pkgRoot = Maybe String
forall a. Maybe a
Nothing
    , libVisibility :: LibraryVisibility
IPI.libVisibility = Library -> LibraryVisibility
libVisibility Library
lib
    }
  where
    ghc84 :: Bool
ghc84 = case Compiler -> CompilerId
compilerId (Compiler -> CompilerId) -> Compiler -> CompilerId
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi of
      CompilerId CompilerFlavor
GHC Version
v -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
4]
      CompilerId
_ -> Bool
False

    bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib
    -- TODO: unclear what the root cause of the
    -- duplication is, but we nub it here for now:
    depends :: [UnitId]
depends = [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
ordNub ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst (ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi)
    ([String]
absinc, [String]
relinc) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
isAbsolute (BuildInfo -> [String]
includeDirs BuildInfo
bi)
    hasModules :: Bool
hasModules = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    hasLibrary :: Bool
hasLibrary =
      ( Bool
hasModules
          Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
cSources BuildInfo
bi))
          Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
asmSources BuildInfo
bi))
          Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
cmmSources BuildInfo
bi))
          Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
cxxSources BuildInfo
bi))
          Bool -> Bool -> Bool
|| (Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
jsSources BuildInfo
bi)) Bool -> Bool -> Bool
&& Bool
hasJsSupport)
      )
        Bool -> Bool -> Bool
&& Bool -> Bool
not (ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi)
    hasJsSupport :: Bool
hasJsSupport = case LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi of
      Platform Arch
JavaScript OS
_ -> Bool
True
      Platform
_ -> Bool
False
    libdirsStatic :: [String]
libdirsStatic
      | Bool
hasLibrary = InstallDirs String -> String
forall dir. InstallDirs dir -> dir
libdir InstallDirs String
installDirs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extraLibDirsStaticOrFallback
      | Bool
otherwise = [String]
extraLibDirsStaticOrFallback
      where
        -- If no static library dirs were given, the package likely makes no
        -- distinction between fully static linking and otherwise.
        -- Fall back to the normal library dirs in that case.
        extraLibDirsStaticOrFallback :: [String]
extraLibDirsStaticOrFallback = case BuildInfo -> [String]
extraLibDirsStatic BuildInfo
bi of
          [] -> BuildInfo -> [String]
extraLibDirs BuildInfo
bi
          [String]
dirs -> [String]
dirs
    ([String]
libdirs, [String]
dynlibdirs)
      | Bool -> Bool
not Bool
hasLibrary =
          (BuildInfo -> [String]
extraLibDirs BuildInfo
bi, [])
      -- the dynamic-library-dirs defaults to the library-dirs if not specified,
      -- so this works whether the dynamic-library-dirs field is supported or not

      | Compiler -> Bool
libraryDynDirSupported Compiler
comp =
          ( InstallDirs String -> String
forall dir. InstallDirs dir -> dir
libdir InstallDirs String
installDirs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraLibDirs BuildInfo
bi
          , InstallDirs String -> String
forall dir. InstallDirs dir -> dir
dynlibdir InstallDirs String
installDirs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraLibDirs BuildInfo
bi
          )
      | Bool
otherwise =
          (InstallDirs String -> String
forall dir. InstallDirs dir -> dir
libdir InstallDirs String
installDirs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: InstallDirs String -> String
forall dir. InstallDirs dir -> dir
dynlibdir InstallDirs String
installDirs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraLibDirs BuildInfo
bi, [])

-- the compiler doesn't understand the dynamic-library-dirs field so we
-- add the dyn directory to the "normal" list in the library-dirs field

-- | Construct 'InstalledPackageInfo' for a library that is in place in the
-- build tree.
--
-- This function knows about the layout of in place packages.
inplaceInstalledPackageInfo
  :: FilePath
  -- ^ top of the build tree
  -> FilePath
  -- ^ location of the dist tree
  -> PackageDescription
  -> AbiHash
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> InstalledPackageInfo
inplaceInstalledPackageInfo :: String
-> String
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo String
inplaceDir String
distPref PackageDescription
pkg AbiHash
abi_hash Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi =
  ([String] -> [String])
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstallDirs String
-> InstalledPackageInfo
generalInstalledPackageInfo
    [String] -> [String]
adjustRelativeIncludeDirs
    PackageDescription
pkg
    AbiHash
abi_hash
    Library
lib
    LocalBuildInfo
lbi
    ComponentLocalBuildInfo
clbi
    InstallDirs String
installDirs
  where
    adjustRelativeIncludeDirs :: [String] -> [String]
adjustRelativeIncludeDirs = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> [String]) -> [String] -> [String])
-> (String -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ \String
d ->
      [ String
inplaceDir String -> String -> String
</> String
d -- local include-dir
      , String
inplaceDir String -> String -> String
</> String
libTargetDir String -> String -> String
</> String
d -- autogen include-dir
      ]
    libTargetDir :: String
libTargetDir = LocalBuildInfo -> ComponentLocalBuildInfo -> String
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    installDirs :: InstallDirs String
installDirs =
      (PackageDescription
-> LocalBuildInfo -> UnitId -> CopyDest -> InstallDirs String
absoluteComponentInstallDirs PackageDescription
pkg LocalBuildInfo
lbi (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi) CopyDest
NoCopyDest)
        { libdir = inplaceDir </> libTargetDir
        , dynlibdir = inplaceDir </> libTargetDir
        , datadir = inplaceDir </> dataDir pkg
        , docdir = inplaceDocdir
        , htmldir = inplaceHtmldir
        , haddockdir = inplaceHtmldir
        }
    inplaceDocdir :: String
inplaceDocdir = String
inplaceDir String -> String -> String
</> String
distPref String -> String -> String
</> String
"doc"
    inplaceHtmldir :: String
inplaceHtmldir = String
inplaceDocdir String -> String -> String
</> String
"html" String -> String -> String
</> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg)

-- | Construct 'InstalledPackageInfo' for the final install location of a
-- library package.
--
-- This function knows about the layout of installed packages.
absoluteInstalledPackageInfo
  :: PackageDescription
  -> AbiHash
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> InstalledPackageInfo
absoluteInstalledPackageInfo :: PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
absoluteInstalledPackageInfo PackageDescription
pkg AbiHash
abi_hash Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi =
  ([String] -> [String])
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstallDirs String
-> InstalledPackageInfo
generalInstalledPackageInfo
    [String] -> [String]
forall {p}. p -> [String]
adjustReativeIncludeDirs
    PackageDescription
pkg
    AbiHash
abi_hash
    Library
lib
    LocalBuildInfo
lbi
    ComponentLocalBuildInfo
clbi
    InstallDirs String
installDirs
  where
    -- For installed packages we install all include files into one dir,
    -- whereas in the build tree they may live in multiple local dirs.
    adjustReativeIncludeDirs :: p -> [String]
adjustReativeIncludeDirs p
_
      | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
installIncludes BuildInfo
bi) = []
      | Bool
otherwise = [InstallDirs String -> String
forall dir. InstallDirs dir -> dir
includedir InstallDirs String
installDirs]
    bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib
    installDirs :: InstallDirs String
installDirs = PackageDescription
-> LocalBuildInfo -> UnitId -> CopyDest -> InstallDirs String
absoluteComponentInstallDirs PackageDescription
pkg LocalBuildInfo
lbi (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi) CopyDest
NoCopyDest

relocatableInstalledPackageInfo
  :: PackageDescription
  -> AbiHash
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> InstalledPackageInfo
relocatableInstalledPackageInfo :: PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> InstalledPackageInfo
relocatableInstalledPackageInfo PackageDescription
pkg AbiHash
abi_hash Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi String
pkgroot =
  ([String] -> [String])
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstallDirs String
-> InstalledPackageInfo
generalInstalledPackageInfo
    [String] -> [String]
forall {p}. p -> [String]
adjustReativeIncludeDirs
    PackageDescription
pkg
    AbiHash
abi_hash
    Library
lib
    LocalBuildInfo
lbi
    ComponentLocalBuildInfo
clbi
    InstallDirs String
installDirs
  where
    -- For installed packages we install all include files into one dir,
    -- whereas in the build tree they may live in multiple local dirs.
    adjustReativeIncludeDirs :: p -> [String]
adjustReativeIncludeDirs p
_
      | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
installIncludes BuildInfo
bi) = []
      | Bool
otherwise = [InstallDirs String -> String
forall dir. InstallDirs dir -> dir
includedir InstallDirs String
installDirs]
    bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib

    installDirs :: InstallDirs String
installDirs =
      (String -> String) -> InstallDirs String -> InstallDirs String
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
"${pkgroot}" String -> String -> String
</>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
shortRelativePath String
pkgroot) (InstallDirs String -> InstallDirs String)
-> InstallDirs String -> InstallDirs String
forall a b. (a -> b) -> a -> b
$
        PackageDescription
-> LocalBuildInfo -> UnitId -> CopyDest -> InstallDirs String
absoluteComponentInstallDirs PackageDescription
pkg LocalBuildInfo
lbi (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi) CopyDest
NoCopyDest

-- -----------------------------------------------------------------------------
-- Unregistration

unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
unregister PackageDescription
pkg LocalBuildInfo
lbi RegisterFlags
regFlags = do
  let pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
      genScript :: Bool
genScript = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regGenScript RegisterFlags
regFlags)
      verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)
      packageDb :: PackageDB
packageDb =
        PackageDB -> Flag PackageDB -> PackageDB
forall a. a -> Flag a -> a
fromFlagOrDefault
          (PackageDBStack -> PackageDB
registrationPackageDB (LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi))
          (RegisterFlags -> Flag PackageDB
regPackageDB RegisterFlags
regFlags)
      unreg :: HcPkgInfo -> IO ()
unreg HcPkgInfo
hpi =
        let invocation :: ProgramInvocation
invocation =
              HcPkgInfo
-> Verbosity -> PackageDB -> PackageIdentifier -> ProgramInvocation
HcPkg.unregisterInvocation
                HcPkgInfo
hpi
                Verbosity
Verbosity.normal
                PackageDB
packageDb
                PackageIdentifier
pkgid
         in if Bool
genScript
              then
                String -> ByteString -> IO ()
writeFileAtomic
                  String
unregScriptFileName
                  (String -> ByteString
BS.Char8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ OS -> ProgramInvocation -> String
invocationAsSystemScript OS
buildOS ProgramInvocation
invocation)
              else Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
  Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity String
"Unregistering" PackageIdentifier
pkgid
  Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO ()) -> IO ()
forall a.
Verbosity
-> String -> Compiler -> ProgramDb -> (HcPkgInfo -> IO a) -> IO a
withHcPkg
    Verbosity
verbosity
    String
"unregistering is only implemented for GHC and GHCJS"
    (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
    (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
    HcPkgInfo -> IO ()
unreg

unregScriptFileName :: FilePath
unregScriptFileName :: String
unregScriptFileName = case OS
buildOS of
  OS
Windows -> String
"unregister.bat"
  OS
_ -> String
"unregister.sh"

internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath :: LocalBuildInfo -> String -> String
internalPackageDBPath LocalBuildInfo
lbi String
distPref =
  case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
    CompilerFlavor
UHC -> LocalBuildInfo -> String
UHC.inplacePackageDbPath LocalBuildInfo
lbi
    CompilerFlavor
_ -> String
distPref String -> String -> String
</> String
"package.conf.inplace"