{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

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

-- |
-- Module      :  Distribution.Simple.GHC
-- Copyright   :  Isaac Jones 2003-2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This is a fairly large module. It contains most of the GHC-specific code for
-- configuring, building and installing packages. It also exports a function
-- for finding out what packages are already installed. Configuring involves
-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions
-- this version of ghc supports and returning a 'Compiler' value.
--
-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out
-- what packages are installed.
--
-- Building is somewhat complex as there is quite a bit of information to take
-- into account. We have to build libs and programs, possibly for profiling and
-- shared libs. We have to support building libraries that will be usable by
-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files
-- using ghc. Linking, especially for @split-objs@ is remarkably complex,
-- partly because there tend to be 1,000's of @.o@ files and this can often be
-- more than we can pass to the @ld@ or @ar@ programs in one go.
--
-- Installing for libs and exes involves finding the right files and copying
-- them to the right places. One of the more tricky things about this module is
-- remembering the layout of files in the build directory (which is not
-- explicitly documented) and thus what search dirs are used for various kinds
-- of files.
module Distribution.Simple.GHC
  ( getGhcInfo
  , configure
  , getInstalledPackages
  , getInstalledPackagesMonitorFiles
  , getPackageDBContents
  , buildLib
  , buildFLib
  , buildExe
  , replLib
  , replFLib
  , replExe
  , startInterpreter
  , installLib
  , installFLib
  , installExe
  , libAbiHash
  , hcPkgInfo
  , registerPackage
  , Internal.componentGhcOptions
  , Internal.componentCcGhcOptions
  , getGhcAppDir
  , getLibDir
  , isDynamic
  , getGlobalPackageDB
  , pkgRoot

    -- * Constructing and deconstructing GHC environment files
  , Internal.GhcEnvironmentFileEntry (..)
  , Internal.simpleGhcEnvironmentFile
  , Internal.renderGhcEnvironmentFile
  , Internal.writeGhcEnvironmentFile
  , Internal.ghcPlatformAndVersionString
  , readGhcEnvironmentFile
  , parseGhcEnvironmentFile
  , ParseErrorExc (..)

    -- * Version-specific implementation quirks
  , getImplInfo
  , GhcImplInfo (..)
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Arrow ((***))
import Control.Monad (forM_)
import Data.List (stripPrefix)
import qualified Data.Map as Map
import Distribution.CabalSpecVersion
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.Package
import Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..))
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import qualified Distribution.Simple.GHC.Build as GHC
import Distribution.Simple.GHC.Build.Utils
import Distribution.Simple.GHC.EnvironmentParser
import Distribution.Simple.GHC.ImplInfo
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PreProcess.Types
import Distribution.Simple.Program
import Distribution.Simple.Program.Builtin (runghcProgram)
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Repl
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ParStrat
import Distribution.Types.TargetInfo
import Distribution.Utils.NubList
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
import Language.Haskell.Extension
import System.Directory
  ( canonicalizePath
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getAppUserDataDirectory
  , getDirectoryContents
  )
import System.FilePath
  ( isRelative
  , takeDirectory
  )
import qualified System.Info
#ifndef mingw32_HOST_OS
import System.Directory (renameFile)
import System.Posix (createSymbolicLink)
#endif /* mingw32_HOST_OS */

import Distribution.Simple.Setup (BuildingWhat (..))
import Distribution.Simple.Setup.Build

-- -----------------------------------------------------------------------------
-- Configuring

configure
  :: Verbosity
  -> Maybe FilePath
  -> Maybe FilePath
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe FilePath
hcPath Maybe FilePath
hcPkgPath ProgramDb
conf0 = do
  (ConfiguredProgram
ghcProg, Version
ghcVersion, ProgramDb
progdb1) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
7, Int
0, Int
1]))
      (FilePath -> Maybe FilePath -> ProgramDb -> ProgramDb
userMaybeSpecifyPath FilePath
"ghc" Maybe FilePath
hcPath ProgramDb
conf0)
  let implInfo :: GhcImplInfo
implInfo = Version -> GhcImplInfo
ghcVersionImplInfo Version
ghcVersion

  -- Cabal currently supports ghc >= 7.0.1 && < 9.12
  -- ... and the following odd development version
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
9, Int
12]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"Unknown/unsupported 'ghc' version detected "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"(Cabal "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
cabalVersion
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" supports 'ghc' version < 9.12): "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> FilePath
programPath ConfiguredProgram
ghcProg
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is version "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
ghcVersion

  -- This is slightly tricky, we have to configure ghc first, then we use the
  -- location of ghc to help find ghc-pkg in the case that the user did not
  -- specify the location of ghc-pkg directly:
  (ConfiguredProgram
ghcPkgProg, Version
ghcPkgVersion, ProgramDb
progdb2) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcPkgProgram
        { programFindLocation = guessGhcPkgFromGhcPath ghcProg
        }
      VersionRange
anyVersion
      (FilePath -> Maybe FilePath -> ProgramDb -> ProgramDb
userMaybeSpecifyPath FilePath
"ghc-pkg" Maybe FilePath
hcPkgPath ProgramDb
progdb1)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ghcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
ghcPkgVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> Version -> FilePath -> Version -> CabalException
VersionMismatchGHC (ConfiguredProgram -> FilePath
programPath ConfiguredProgram
ghcProg) Version
ghcVersion (ConfiguredProgram -> FilePath
programPath ConfiguredProgram
ghcPkgProg) Version
ghcPkgVersion
  -- Likewise we try to find the matching hsc2hs and haddock programs.
  let hsc2hsProgram' :: Program
hsc2hsProgram' =
        Program
hsc2hsProgram
          { programFindLocation = guessHsc2hsFromGhcPath ghcProg
          }
      haddockProgram' :: Program
haddockProgram' =
        Program
haddockProgram
          { programFindLocation = guessHaddockFromGhcPath ghcProg
          }
      hpcProgram' :: Program
hpcProgram' =
        Program
hpcProgram
          { programFindLocation = guessHpcFromGhcPath ghcProg
          }
      runghcProgram' :: Program
runghcProgram' =
        Program
runghcProgram
          { programFindLocation = guessRunghcFromGhcPath ghcProg
          }
      progdb3 :: ProgramDb
progdb3 =
        Program -> ProgramDb -> ProgramDb
addKnownProgram Program
haddockProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
          Program -> ProgramDb -> ProgramDb
addKnownProgram Program
hsc2hsProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
            Program -> ProgramDb -> ProgramDb
addKnownProgram Program
hpcProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
              Program -> ProgramDb -> ProgramDb
addKnownProgram Program
runghcProgram' ProgramDb
progdb2

  [(Language, FilePath)]
languages <- Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(Language, FilePath)]
Internal.getLanguages Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcProg
  [(Extension, Maybe FilePath)]
extensions0 <- Verbosity
-> GhcImplInfo
-> ConfiguredProgram
-> IO [(Extension, Maybe FilePath)]
Internal.getExtensions Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcProg

  [(FilePath, FilePath)]
ghcInfo <- Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(FilePath, FilePath)]
Internal.getGhcInfo Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcProg
  let ghcInfoMap :: Map FilePath FilePath
ghcInfoMap = [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FilePath, FilePath)]
ghcInfo
      filterJS :: [(Extension, b)] -> [(Extension, b)]
filterJS = if Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
9, Int
8] then KnownExtension -> [(Extension, b)] -> [(Extension, b)]
forall {b}. KnownExtension -> [(Extension, b)] -> [(Extension, b)]
filterExt KnownExtension
JavaScriptFFI else [(Extension, b)] -> [(Extension, b)]
forall a. a -> a
id
      extensions :: [(Extension, Maybe FilePath)]
extensions =
        -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214
        [(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)]
forall {b}. [(Extension, b)] -> [(Extension, b)]
filterJS ([(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)])
-> [(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)]
forall a b. (a -> b) -> a -> b
$
          -- see 'filterExtTH' comment below
          [(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)]
forall {b}. [(Extension, b)] -> [(Extension, b)]
filterExtTH ([(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)])
-> [(Extension, Maybe FilePath)] -> [(Extension, Maybe FilePath)]
forall a b. (a -> b) -> a -> b
$
            [(Extension, Maybe FilePath)]
extensions0

      -- starting with GHC 8.0, `TemplateHaskell` will be omitted from
      -- `--supported-extensions` when it's not available.
      -- for older GHCs we can use the "Have interpreter" property to
      -- filter out `TemplateHaskell`
      filterExtTH :: [(Extension, b)] -> [(Extension, b)]
filterExtTH
        | Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
8]
        , Just FilePath
"NO" <- FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
"Have interpreter" Map FilePath FilePath
ghcInfoMap =
            KnownExtension -> [(Extension, b)] -> [(Extension, b)]
forall {b}. KnownExtension -> [(Extension, b)] -> [(Extension, b)]
filterExt KnownExtension
TemplateHaskell
        | Bool
otherwise = [(Extension, b)] -> [(Extension, b)]
forall a. a -> a
id

      filterExt :: KnownExtension -> [(Extension, b)] -> [(Extension, b)]
filterExt KnownExtension
ext = ((Extension, b) -> Bool) -> [(Extension, b)] -> [(Extension, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
/= KnownExtension -> Extension
EnableExtension KnownExtension
ext) (Extension -> Bool)
-> ((Extension, b) -> Extension) -> (Extension, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extension, b) -> Extension
forall a b. (a, b) -> a
fst)

      compilerId :: CompilerId
      compilerId :: CompilerId
compilerId = CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHC Version
ghcVersion

      compilerAbiTag :: AbiTag
      compilerAbiTag :: AbiTag
compilerAbiTag = AbiTag -> (FilePath -> AbiTag) -> Maybe FilePath -> AbiTag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AbiTag
NoAbiTag FilePath -> AbiTag
AbiTag (FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
"Project Unit Id" Map FilePath FilePath
ghcInfoMap Maybe FilePath -> (FilePath -> Maybe FilePath) -> Maybe FilePath
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (CompilerId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compilerId FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-"))

  let comp :: Compiler
comp =
        Compiler
          { CompilerId
compilerId :: CompilerId
compilerId :: CompilerId
compilerId
          , AbiTag
compilerAbiTag :: AbiTag
compilerAbiTag :: AbiTag
compilerAbiTag
          , compilerCompat :: [CompilerId]
compilerCompat = []
          , compilerLanguages :: [(Language, FilePath)]
compilerLanguages = [(Language, FilePath)]
languages
          , compilerExtensions :: [(Extension, Maybe FilePath)]
compilerExtensions = [(Extension, Maybe FilePath)]
extensions
          , compilerProperties :: Map FilePath FilePath
compilerProperties = Map FilePath FilePath
ghcInfoMap
          }
      compPlatform :: Maybe Platform
compPlatform = [(FilePath, FilePath)] -> Maybe Platform
Internal.targetPlatform [(FilePath, FilePath)]
ghcInfo
      -- configure gcc and ld
      progdb4 :: ProgramDb
progdb4 = GhcImplInfo
-> ConfiguredProgram
-> Map FilePath FilePath
-> ProgramDb
-> ProgramDb
Internal.configureToolchain GhcImplInfo
implInfo ConfiguredProgram
ghcProg Map FilePath FilePath
ghcInfoMap ProgramDb
progdb3
  (Compiler, Maybe Platform, ProgramDb)
-> IO (Compiler, Maybe Platform, ProgramDb)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Compiler
comp, Maybe Platform
compPlatform, ProgramDb
progdb4)

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find
-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking
-- for a versioned or unversioned ghc-pkg in the same dir, that is:
--
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
guessToolFromGhcPath
  :: Program
  -> ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath :: Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
tool ConfiguredProgram
ghcProg Verbosity
verbosity ProgramSearchPath
searchpath =
  do
    let toolname :: FilePath
toolname = Program -> FilePath
programName Program
tool
        given_path :: FilePath
given_path = ConfiguredProgram -> FilePath
programPath ConfiguredProgram
ghcProg
        given_dir :: FilePath
given_dir = FilePath -> FilePath
takeDirectory FilePath
given_path
    FilePath
real_path <- FilePath -> IO FilePath
canonicalizePath FilePath
given_path
    let real_dir :: FilePath
real_dir = FilePath -> FilePath
takeDirectory FilePath
real_path
        versionSuffix :: FilePath -> FilePath
versionSuffix FilePath
path = FilePath -> FilePath
takeVersionSuffix (FilePath -> FilePath
dropExeExtension FilePath
path)
        given_suf :: FilePath
given_suf = FilePath -> FilePath
versionSuffix FilePath
given_path
        real_suf :: FilePath
real_suf = FilePath -> FilePath
versionSuffix FilePath
real_path
        guessNormal :: p -> r
guessNormal p
dir = p
dir p -> FilePath -> r
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
toolname FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        guessGhcVersioned :: p -> FilePath -> r
guessGhcVersioned p
dir FilePath
suf =
          p
dir
            p -> FilePath -> r
forall p q r. PathLike p q r => p -> q -> r
</> (FilePath
toolname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-ghc" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suf)
              FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        guessVersioned :: p -> FilePath -> r
guessVersioned p
dir FilePath
suf =
          p
dir
            p -> FilePath -> r
forall p q r. PathLike p q r => p -> q -> r
</> (FilePath
toolname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suf)
              FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        mkGuesses :: p -> FilePath -> [a]
mkGuesses p
dir FilePath
suf
          | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
suf = [p -> a
forall {p} {r}. PathLike p FilePath r => p -> r
guessNormal p
dir]
          | Bool
otherwise =
              [ p -> FilePath -> a
forall {p} {r}. PathLike p FilePath r => p -> FilePath -> r
guessGhcVersioned p
dir FilePath
suf
              , p -> FilePath -> a
forall {p} {r}. PathLike p FilePath r => p -> FilePath -> r
guessVersioned p
dir FilePath
suf
              , p -> a
forall {p} {r}. PathLike p FilePath r => p -> r
guessNormal p
dir
              ]
        -- order matters here, see https://github.com/haskell/cabal/issues/7390
        guesses :: [FilePath]
guesses =
          ( if FilePath
real_path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
given_path
              then []
              else FilePath -> FilePath -> [FilePath]
forall {p} {a}. PathLike p FilePath a => p -> FilePath -> [a]
mkGuesses FilePath
real_dir FilePath
real_suf
          )
            [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> [FilePath]
forall {p} {a}. PathLike p FilePath a => p -> FilePath -> [a]
mkGuesses FilePath
given_dir FilePath
given_suf
    Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"looking for tool "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
toolname
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" near compiler in "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
given_dir
    Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"candidate locations: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
guesses
    [Bool]
exists <- (FilePath -> IO Bool) -> [FilePath] -> IO [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePath -> IO Bool
doesFileExist [FilePath]
guesses
    case [FilePath
file | (FilePath
file, Bool
True) <- [FilePath] -> [Bool] -> [(FilePath, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
guesses [Bool]
exists] of
      -- If we can't find it near ghc, fall back to the usual
      -- method.
      [] -> Program
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
programFindLocation Program
tool Verbosity
verbosity ProgramSearchPath
searchpath
      (FilePath
fp : [FilePath]
_) -> do
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"found " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
toolname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp
        let lookedAt :: [FilePath]
lookedAt =
              ((FilePath, Bool) -> FilePath) -> [(FilePath, Bool)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Bool) -> FilePath
forall a b. (a, b) -> a
fst
                ([(FilePath, Bool)] -> [FilePath])
-> ([(FilePath, Bool)] -> [(FilePath, Bool)])
-> [(FilePath, Bool)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, Bool) -> Bool)
-> [(FilePath, Bool)] -> [(FilePath, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(FilePath
_file, Bool
exist) -> Bool -> Bool
not Bool
exist)
                ([(FilePath, Bool)] -> [FilePath])
-> [(FilePath, Bool)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [Bool] -> [(FilePath, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
guesses [Bool]
exists
        Maybe (FilePath, [FilePath]) -> IO (Maybe (FilePath, [FilePath]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, [FilePath]) -> Maybe (FilePath, [FilePath])
forall a. a -> Maybe a
Just (FilePath
fp, [FilePath]
lookedAt))
  where
    takeVersionSuffix :: FilePath -> String
    takeVersionSuffix :: FilePath -> FilePath
takeVersionSuffix = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhileEndLE Char -> Bool
isSuffixChar

    isSuffixChar :: Char -> Bool
    isSuffixChar :: Char -> Bool
isSuffixChar Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding ghc-pkg, we try looking for both a versioned and unversioned
-- ghc-pkg in the same dir, that is:
--
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
guessGhcPkgFromGhcPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessGhcPkgFromGhcPath :: ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessGhcPkgFromGhcPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
ghcPkgProgram

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding hsc2hs, we try looking for both a versioned and unversioned
-- hsc2hs in the same dir, that is:
--
-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs(.exe)
guessHsc2hsFromGhcPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcPath :: ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
hsc2hsProgram

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding haddock, we try looking for both a versioned and unversioned
-- haddock in the same dir, that is:
--
-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)
-- > /usr/local/bin/haddock-6.6.1(.exe)
-- > /usr/local/bin/haddock(.exe)
guessHaddockFromGhcPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcPath :: ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
haddockProgram

guessHpcFromGhcPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcPath :: ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
hpcProgram

guessRunghcFromGhcPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessRunghcFromGhcPath :: ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessRunghcFromGhcPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcPath Program
runghcProgram

getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(FilePath, FilePath)]
getGhcInfo Verbosity
verbosity ConfiguredProgram
ghcProg = Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(FilePath, FilePath)]
Internal.getGhcInfo Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcProg
  where
    version :: Version
version = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Version
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.getGhcInfo: no ghc version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcProg
    implInfo :: GhcImplInfo
implInfo = Version -> GhcImplInfo
ghcVersionImplInfo Version
version

-- | Given a single package DB, return all installed packages.
getPackageDBContents
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> ProgramDb
  -> IO InstalledPackageIndex
getPackageDBContents :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> ProgramDb
-> IO InstalledPackageIndex
getPackageDBContents Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb ProgramDb
progdb = do
  [(PackageDB, [InstalledPackageInfo])]
pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [PackageDB
packagedb] ProgramDb
progdb
  Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb

-- | Given a package DB stack, return all installed packages.
getInstalledPackages
  :: Verbosity
  -> Compiler
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [PackageDB]
packagedbs ProgramDb
progdb = do
  Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity
  Verbosity -> Compiler -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp [PackageDB]
packagedbs
  [(PackageDB, [InstalledPackageInfo])]
pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [PackageDB]
packagedbs ProgramDb
progdb
  InstalledPackageIndex
index <- Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb
  InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$! InstalledPackageIndex -> InstalledPackageIndex
hackRtsPackage InstalledPackageIndex
index
  where
    hackRtsPackage :: InstalledPackageIndex -> InstalledPackageIndex
hackRtsPackage InstalledPackageIndex
index =
      case InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName InstalledPackageIndex
index (FilePath -> PackageName
mkPackageName FilePath
"rts") of
        [(Version
_, [InstalledPackageInfo
rts])] ->
          InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
PackageIndex.insert (InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir InstalledPackageInfo
rts) InstalledPackageIndex
index
        [(Version, [InstalledPackageInfo])]
_ -> InstalledPackageIndex
index -- No (or multiple) ghc rts package is registered!!
        -- Feh, whatever, the ghc test suite does some crazy stuff.

-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
-- @PackageIndex@. Helper function used by 'getPackageDBContents' and
-- 'getInstalledPackages'.
toPackageIndex
  :: Verbosity
  -> [(PackageDB, [InstalledPackageInfo])]
  -> ProgramDb
  -> IO InstalledPackageIndex
toPackageIndex :: Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb = do
  -- On Windows, various fields have $topdir/foo rather than full
  -- paths. We need to substitute the right value in so that when
  -- we, for example, call gcc, we have proper paths to give it.
  FilePath
topDir <- Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcProg
  let indices :: [InstalledPackageIndex]
indices =
        [ [InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList ((InstalledPackageInfo -> InstalledPackageInfo)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> InstalledPackageInfo -> InstalledPackageInfo
Internal.substTopDir FilePath
topDir) [InstalledPackageInfo]
pkgs)
        | (PackageDB
_, [InstalledPackageInfo]
pkgs) <- [(PackageDB, [InstalledPackageInfo])]
pkgss
        ]
  InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$! [InstalledPackageIndex] -> InstalledPackageIndex
forall a. Monoid a => [a] -> a
mconcat [InstalledPackageIndex]
indices
  where
    ghcProg :: ConfiguredProgram
ghcProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ConfiguredProgram
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.toPackageIndex: no ghc program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcProgram ProgramDb
progdb

-- | Return the 'FilePath' to the GHC application data directory.
--
-- @since 3.4.0.0
getGhcAppDir :: IO FilePath
getGhcAppDir :: IO FilePath
getGhcAppDir = FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"ghc"

getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir Verbosity
verbosity LocalBuildInfo
lbi =
  (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> Program -> ProgramDb -> [FilePath] -> IO FilePath
getDbProgramOutput
      Verbosity
verbosity
      Program
ghcProgram
      (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
      [FilePath
"--print-libdir"]

getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcProg =
  (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> ConfiguredProgram -> [FilePath] -> IO FilePath
getProgramOutput Verbosity
verbosity ConfiguredProgram
ghcProg [FilePath
"--print-libdir"]

-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg =
  (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> ConfiguredProgram -> [FilePath] -> IO FilePath
getProgramOutput Verbosity
verbosity ConfiguredProgram
ghcProg [FilePath
"--print-global-package-db"]

-- | Return the 'FilePath' to the per-user GHC package database.
getUserPackageDB
  :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB Verbosity
_verbosity ConfiguredProgram
ghcProg Platform
platform = do
  -- It's rather annoying that we have to reconstruct this, because ghc
  -- hides this information from us otherwise. But for certain use cases
  -- like change monitoring it really can't remain hidden.
  FilePath
appdir <- IO FilePath
getGhcAppDir
  FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
appdir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
platformAndVersion FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
packageConfFileName)
  where
    platformAndVersion :: FilePath
platformAndVersion =
      Platform -> Version -> FilePath
Internal.ghcPlatformAndVersionString
        Platform
platform
        Version
ghcVersion
    packageConfFileName :: FilePath
packageConfFileName = FilePath
"package.conf.d"
    ghcVersion :: Version
ghcVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Version
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.getUserPackageDB: no ghc version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcProg

checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity =
  Verbosity -> FilePath -> FilePath -> IO ()
Internal.checkPackageDbEnvVar Verbosity
verbosity FilePath
"GHC" FilePath
"GHC_PACKAGE_PATH"

checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO ()
checkPackageDbStack :: Verbosity -> Compiler -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp =
  if GhcImplInfo -> Bool
flagPackageConf GhcImplInfo
implInfo
    then Verbosity -> [PackageDB] -> IO ()
checkPackageDbStackPre76 Verbosity
verbosity
    else Verbosity -> [PackageDB] -> IO ()
checkPackageDbStackPost76 Verbosity
verbosity
  where
    implInfo :: GhcImplInfo
implInfo = Version -> GhcImplInfo
ghcVersionImplInfo (Compiler -> Version
compilerVersion Compiler
comp)

checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStackPost76 :: Verbosity -> [PackageDB] -> IO ()
checkPackageDbStackPost76 Verbosity
_ (PackageDB
GlobalPackageDB : [PackageDB]
rest)
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDB]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStackPost76 Verbosity
verbosity [PackageDB]
rest
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageDB]
rest =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
CheckPackageDbStackPost76
checkPackageDbStackPost76 Verbosity
_ [PackageDB]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStackPre76 :: Verbosity -> [PackageDB] -> IO ()
checkPackageDbStackPre76 Verbosity
_ (PackageDB
GlobalPackageDB : [PackageDB]
rest)
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDB]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStackPre76 Verbosity
verbosity [PackageDB]
rest
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDB]
rest =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
CheckPackageDbStackPre76
checkPackageDbStackPre76 Verbosity
verbosity [PackageDB]
_ =
  Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
GlobalPackageDbSpecifiedFirst

-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
-- breaks when you want to use a different gcc, so we need to filter
-- it out.
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir InstalledPackageInfo
pkg =
  let ids :: [FilePath]
ids = InstalledPackageInfo -> [FilePath]
InstalledPackageInfo.includeDirs InstalledPackageInfo
pkg
      ids' :: [FilePath]
ids' = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"mingw" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`)) [FilePath]
ids
   in InstalledPackageInfo
pkg{InstalledPackageInfo.includeDirs = ids'}

-- | Get the packages from specific PackageDBs, not cumulative.
getInstalledPackages'
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> [PackageDB]
  -> ProgramDb
  -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [PackageDB]
packagedbs ProgramDb
progdb =
  [IO (PackageDB, [InstalledPackageInfo])]
-> IO [(PackageDB, [InstalledPackageInfo])]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ do
      [InstalledPackageInfo]
pkgs <- HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> IO [InstalledPackageInfo]
HcPkg.dump (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb) Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb
      (PackageDB, [InstalledPackageInfo])
-> IO (PackageDB, [InstalledPackageInfo])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDB
packagedb, [InstalledPackageInfo]
pkgs)
    | PackageDB
packagedb <- [PackageDB]
packagedbs
    ]

getInstalledPackagesMonitorFiles
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> Platform
  -> ProgramDb
  -> [PackageDB]
  -> IO [FilePath]
getInstalledPackagesMonitorFiles :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Platform
-> ProgramDb
-> [PackageDB]
-> IO [FilePath]
getInstalledPackagesMonitorFiles Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir Platform
platform ProgramDb
progdb =
  (PackageDB -> IO FilePath) -> [PackageDB] -> IO [FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PackageDB -> IO FilePath
getPackageDBPath
  where
    getPackageDBPath :: PackageDB -> IO FilePath
    getPackageDBPath :: PackageDB -> IO FilePath
getPackageDBPath PackageDB
GlobalPackageDB =
      FilePath -> IO FilePath
selectMonitorFile (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg
    getPackageDBPath PackageDB
UserPackageDB =
      FilePath -> IO FilePath
selectMonitorFile (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg Platform
platform
    getPackageDBPath (SpecificPackageDB FilePath
path) = FilePath -> IO FilePath
selectMonitorFile FilePath
path

    -- GHC has old style file dbs, and new style directory dbs.
    -- Note that for dir style dbs, we only need to monitor the cache file, not
    -- the whole directory. The ghc program itself only reads the cache file
    -- so it's safe to only monitor this one file.
    selectMonitorFile :: FilePath -> IO FilePath
selectMonitorFile FilePath
path0 = do
      let path :: FilePath
path =
            if FilePath -> Bool
isRelative FilePath
path0
              then Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'OnlyRelative Pkg Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (FilePath -> SymbolicPathX 'OnlyRelative Pkg Any
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
path0)
              else FilePath
path0
      Bool
isFileStyle <- FilePath -> IO Bool
doesFileExist FilePath
path
      if Bool
isFileStyle
        then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
        else FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
path FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"package.cache")

    ghcProg :: ConfiguredProgram
ghcProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ConfiguredProgram
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.toPackageIndex: no ghc program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcProgram ProgramDb
progdb

-- -----------------------------------------------------------------------------
-- Building a library

buildLib
  :: BuildFlags
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
buildLib :: BuildFlags
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib BuildFlags
flags Flag ParStrat
numJobs PackageDescription
pkg LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
numJobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat = BuildFlags -> BuildingWhat
BuildNormal BuildFlags
flags
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (Library -> Component
CLib Library
lib)
      }

replLib
  :: ReplFlags
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
replLib :: ReplFlags
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
replLib ReplFlags
flags Flag ParStrat
numJobs PackageDescription
pkg LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
numJobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat = ReplFlags -> BuildingWhat
BuildRepl ReplFlags
flags
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (Library -> Component
CLib Library
lib)
      }

-- | Start a REPL without loading any source files.
startInterpreter
  :: Verbosity
  -> ProgramDb
  -> Compiler
  -> Platform
  -> PackageDBStack
  -> IO ()
startInterpreter :: Verbosity
-> ProgramDb -> Compiler -> Platform -> [PackageDB] -> IO ()
startInterpreter Verbosity
verbosity ProgramDb
progdb Compiler
comp Platform
platform [PackageDB]
packageDBs = do
  let replOpts :: GhcOptions
replOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeInteractive
          , ghcOptPackageDBs = packageDBs
          }
  Verbosity -> Compiler -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp [PackageDB]
packageDBs
  (ConfiguredProgram
ghcProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram ProgramDb
progdb
  Verbosity
-> ConfiguredProgram
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> GhcOptions
-> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing GhcOptions
replOpts

-- -----------------------------------------------------------------------------
-- Building an executable or foreign library

-- | Build a foreign library
buildFLib
  :: Verbosity
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
buildFLib :: Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
buildFLib Verbosity
v Flag ParStrat
numJobs PackageDescription
pkg LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
numJobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat =
          BuildFlags -> BuildingWhat
BuildNormal (BuildFlags -> BuildingWhat) -> BuildFlags -> BuildingWhat
forall a b. (a -> b) -> a -> b
$
            BuildFlags
forall a. Monoid a => a
mempty
              { buildCommonFlags =
                  mempty{setupVerbosity = toFlag v}
              }
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (ForeignLib -> Component
CFLib ForeignLib
flib)
      }

replFLib
  :: ReplFlags
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
replFLib :: ReplFlags
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
replFLib ReplFlags
replFlags Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
njobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat = ReplFlags -> BuildingWhat
BuildRepl ReplFlags
replFlags
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (ForeignLib -> Component
CFLib ForeignLib
flib)
      }

-- | Build an executable with GHC.
buildExe
  :: Verbosity
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
buildExe :: Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
buildExe Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
njobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat =
          BuildFlags -> BuildingWhat
BuildNormal (BuildFlags -> BuildingWhat) -> BuildFlags -> BuildingWhat
forall a b. (a -> b) -> a -> b
$
            BuildFlags
forall a. Monoid a => a
mempty
              { buildCommonFlags =
                  mempty{setupVerbosity = toFlag v}
              }
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (Executable -> Component
CExe Executable
exe)
      }

replExe
  :: ReplFlags
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
replExe :: ReplFlags
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
replExe ReplFlags
replFlags Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi =
  Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
GHC.build Flag ParStrat
njobs PackageDescription
pkg (PreBuildComponentInputs -> IO ())
-> PreBuildComponentInputs -> IO ()
forall a b. (a -> b) -> a -> b
$
    PreBuildComponentInputs
      { buildingWhat :: BuildingWhat
buildingWhat = ReplFlags -> BuildingWhat
BuildRepl ReplFlags
replFlags
      , localBuildInfo :: LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi
      , targetInfo :: TargetInfo
targetInfo = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi (Executable -> Component
CExe Executable
exe)
      }

-- | Extracts a String representing a hash of the ABI of a built
-- library.  It can fail if the library has not yet been built.
libAbiHash
  :: Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO String
libAbiHash :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO FilePath
libAbiHash Verbosity
verbosity PackageDescription
_pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
  let
    libBi :: BuildInfo
libBi = Library -> BuildInfo
libBuildInfo Library
lib
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
    vanillaArgs :: GhcOptions
vanillaArgs =
      (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi (LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi))
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeAbiHash
          , ghcOptInputModules = toNubListR $ exposedModules lib
          }
    sharedArgs :: GhcOptions
sharedArgs =
      GhcOptions
vanillaArgs
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptDynLinkMode = toFlag GhcDynamicOnly
          , ghcOptFPic = toFlag True
          , ghcOptHiSuffix = toFlag "dyn_hi"
          , ghcOptObjSuffix = toFlag "dyn_o"
          , ghcOptExtra = hcSharedOptions GHC libBi
          }
    profArgs :: GhcOptions
profArgs =
      GhcOptions
vanillaArgs
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptProfilingMode = toFlag True
          , ghcOptProfilingAuto =
              Internal.profDetailLevelFlag
                True
                (withProfLibDetail lbi)
          , ghcOptHiSuffix = toFlag "p_hi"
          , ghcOptObjSuffix = toFlag "p_o"
          , ghcOptExtra = hcProfOptions GHC libBi
          }
    ghcArgs :: GhcOptions
ghcArgs
      | LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi = GhcOptions
vanillaArgs
      | LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi = GhcOptions
sharedArgs
      | LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi = GhcOptions
profArgs
      | Bool
otherwise = FilePath -> GhcOptions
forall a. HasCallStack => FilePath -> a
error FilePath
"libAbiHash: Can't find an enabled library way"

  (ConfiguredProgram
ghcProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)

  FilePath
hash <-
    Verbosity -> ProgramInvocation -> IO FilePath
getProgramInvocationOutput
      Verbosity
verbosity
      (ProgramInvocation -> IO FilePath)
-> IO ProgramInvocation -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> ConfiguredProgram
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> GhcOptions
-> IO ProgramInvocation
ghcInvocation Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir GhcOptions
ghcArgs

  FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) FilePath
hash)

-- -----------------------------------------------------------------------------
-- Installing

-- | Install executables for GHC.
installExe
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ Where to copy the files to
  -> FilePath
  -- ^ Build location
  -> (FilePath, FilePath)
  -- ^ Executable (prefix,suffix)
  -> PackageDescription
  -> Executable
  -> IO ()
installExe :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> (FilePath, FilePath)
-> PackageDescription
-> Executable
-> IO ()
installExe
  Verbosity
verbosity
  LocalBuildInfo
lbi
  FilePath
binDir
  FilePath
buildPref
  (FilePath
progprefix, FilePath
progsuffix)
  PackageDescription
_pkg
  Executable
exe = do
    Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
binDir
    let exeName' :: FilePath
exeName' = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
        exeFileName :: FilePath
exeFileName = Platform -> UnqualComponentName -> FilePath
exeTargetName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) (Executable -> UnqualComponentName
exeName Executable
exe)
        fixedExeBaseName :: FilePath
fixedExeBaseName = FilePath
progprefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
exeName' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
progsuffix
        installBinary :: FilePath -> IO ()
installBinary FilePath
dest = do
          Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile
            Verbosity
verbosity
            (FilePath
buildPref FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeName' FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeFileName)
            (FilePath
dest FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi))
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
stripExes LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()
Strip.stripExe
              Verbosity
verbosity
              (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
              (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
              (FilePath
dest FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi))
    FilePath -> IO ()
installBinary (FilePath
binDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
fixedExeBaseName)

-- | Install foreign library for GHC.
installFLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ install location
  -> FilePath
  -- ^ Build location
  -> PackageDescription
  -> ForeignLib
  -> IO ()
installFLib :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> PackageDescription
-> ForeignLib
-> IO ()
installFLib Verbosity
verbosity LocalBuildInfo
lbi FilePath
targetDir FilePath
builtDir PackageDescription
_pkg ForeignLib
flib =
  Bool -> FilePath -> FilePath -> FilePath -> IO ()
forall {p} {p}.
PathLike p p FilePath =>
Bool -> p -> p -> p -> IO ()
install
    (ForeignLib -> Bool
foreignLibIsShared ForeignLib
flib)
    FilePath
builtDir
    FilePath
targetDir
    (LocalBuildInfo -> ForeignLib -> FilePath
flibTargetName LocalBuildInfo
lbi ForeignLib
flib)
  where
    install :: Bool -> p -> p -> p -> IO ()
install Bool
isShared p
srcDir p
dstDir p
name = do
      let src :: FilePath
src = p
srcDir p -> p -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> p
name
          dst :: FilePath
dst = p
dstDir p -> p -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> p
name
      Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
targetDir
      -- TODO: Should we strip? (stripLibs lbi)
      if Bool
isShared
        then Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile Verbosity
verbosity FilePath
src FilePath
dst
        else Verbosity -> FilePath -> FilePath -> IO ()
installOrdinaryFile Verbosity
verbosity FilePath
src FilePath
dst
      -- Now install appropriate symlinks if library is versioned
      let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
Linux) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
            CabalException
CantInstallForeignLib
#ifndef mingw32_HOST_OS
        -- 'createSymbolicLink file1 file2' creates a symbolic link
        -- named 'file2' which points to the file 'file1'.
        -- Note that we do want a symlink to 'name' rather than
        -- 'dst', because the symlink will be relative to the
        -- directory it's created in.
        -- Finally, we first create the symlinks in a temporary
        -- directory and then rename to simulate 'ln --force'.
        withTempDirectory verbosity dstDir nm $ \tmpDir -> do
            let link1 = flibBuildName lbi flib
                link2 = "lib" ++ nm <.> "so"
            createSymbolicLink name (tmpDir </> link1)
            renameFile (tmpDir </> link1) (dstDir </> link1)
            createSymbolicLink name (tmpDir </> link2)
            renameFile (tmpDir </> link2) (dstDir </> link2)
      where
        nm :: String
        nm = unUnqualComponentName $ foreignLibName flib
#endif /* mingw32_HOST_OS */

-- | Install for ghc, .hi, .a and, if --with-ghci given, .o
installLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ install location
  -> FilePath
  -- ^ install location for dynamic libraries
  -> FilePath
  -- ^ Build location
  -> PackageDescription
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
installLib :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> FilePath
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
lbi FilePath
targetDir FilePath
dynlibTargetDir FilePath
_builtDir PackageDescription
pkg Library
lib ComponentLocalBuildInfo
clbi = do
  -- copy .hi files over:
  IO () -> IO ()
whenVanilla (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Suffix
Suffix FilePath
"hi"
  IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Suffix
Suffix FilePath
"p_hi"
  IO () -> IO ()
whenShared (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Suffix
Suffix FilePath
"dyn_hi"

  -- copy extra compilation artifacts that ghc plugins may produce
  RelativePath Build ('Dir Artifacts) -> IO ()
copyDirectoryIfExists RelativePath Build ('Dir Artifacts)
extraCompilationArtifacts

  -- copy the built library files over:
  IO () -> IO ()
whenHasCode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ()
whenVanilla (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installOrdinary
          SymbolicPath Pkg ('Dir Build)
builtDir
          FilePath
targetDir
          (FilePath -> FilePath
mkGenericStaticLibName (FilePath
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f))
        | FilePath
l <-
            UnitId -> FilePath
getHSLibraryName
              (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi)
              FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (BuildInfo -> [FilePath]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib))
        , FilePath
f <- FilePath
"" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: BuildInfo -> [FilePath]
extraLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
        ]
      IO () -> IO ()
whenGHCi (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installOrdinary SymbolicPath Pkg ('Dir Build)
builtDir FilePath
targetDir FilePath
ghciLibName
    IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installOrdinary SymbolicPath Pkg ('Dir Build)
builtDir FilePath
targetDir FilePath
profileLibName
      IO () -> IO ()
whenGHCi (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installOrdinary SymbolicPath Pkg ('Dir Build)
builtDir FilePath
targetDir FilePath
ghciProfLibName
    IO () -> IO ()
whenShared (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      if
          -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
          -- See ghc issue #15837 and Cabal PR #5855.
          | PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
< CabalSpecVersion
CabalSpecV3_0 -> do
              [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                [ SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installShared
                  SymbolicPath Pkg ('Dir Build)
builtDir
                  FilePath
dynlibTargetDir
                  (Platform -> CompilerId -> FilePath -> FilePath
mkGenericSharedLibName Platform
platform CompilerId
compiler_id (FilePath
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f))
                | FilePath
l <- UnitId -> FilePath
getHSLibraryName UnitId
uid FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: BuildInfo -> [FilePath]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib)
                , FilePath
f <- FilePath
"" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: BuildInfo -> [FilePath]
extraDynLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
                ]
          | Bool
otherwise -> do
              [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                [ SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installShared
                  SymbolicPath Pkg ('Dir Build)
builtDir
                  FilePath
dynlibTargetDir
                  ( Platform -> CompilerId -> FilePath -> FilePath
mkGenericSharedLibName
                      Platform
platform
                      CompilerId
compiler_id
                      (UnitId -> FilePath
getHSLibraryName UnitId
uid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f)
                  )
                | FilePath
f <- FilePath
"" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: BuildInfo -> [FilePath]
extraDynLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
                ]
              [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                [ do
                  [FilePath]
files <- FilePath -> IO [FilePath]
getDirectoryContents (SymbolicPath Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Build)
builtDir)
                  let l' :: FilePath
l' =
                        Platform -> CompilerId -> FilePath -> FilePath
mkGenericSharedBundledLibName
                          Platform
platform
                          CompilerId
compiler_id
                          FilePath
l
                  [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
l' FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
file) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      Bool
isFile <- FilePath -> IO Bool
doesFileExist (SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build)
builtDir SymbolicPath Pkg ('Dir Build)
-> RelativePath Build Any -> SymbolicPathX 'AllowAbsolute Pkg Any
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Build Any
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
file)
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        SymbolicPath Pkg ('Dir Build) -> FilePath -> FilePath -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installShared
                          SymbolicPath Pkg ('Dir Build)
builtDir
                          FilePath
dynlibTargetDir
                          FilePath
file
                | FilePath
l <- BuildInfo -> [FilePath]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib)
                ]
  where
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi

    builtDir :: SymbolicPath Pkg ('Dir Build)
builtDir = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi

    install :: Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath
-> FilePath
-> IO ()
install Bool
isShared SymbolicPathX allowAbsolute Pkg ('Dir from)
srcDir FilePath
dstDir FilePath
name = do
      let src :: FilePath
src = SymbolicPathX allowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX allowAbsolute Pkg Any -> FilePath)
-> SymbolicPathX allowAbsolute Pkg Any -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPathX allowAbsolute Pkg ('Dir from)
srcDir SymbolicPathX allowAbsolute Pkg ('Dir from)
-> RelativePath from Any -> SymbolicPathX allowAbsolute Pkg Any
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath from Any
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
name
          dst :: FilePath
dst = FilePath
dstDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
name

      Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
dstDir

      if Bool
isShared
        then Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile Verbosity
verbosity FilePath
src FilePath
dst
        else Verbosity -> FilePath -> FilePath -> IO ()
installOrdinaryFile Verbosity
verbosity FilePath
src FilePath
dst

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
stripLibs LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()
Strip.stripLib
          Verbosity
verbosity
          Platform
platform
          (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
          FilePath
dst

    installOrdinary :: SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installOrdinary = Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath
-> FilePath
-> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath
-> FilePath
-> IO ()
install Bool
False
    installShared :: SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath -> FilePath -> IO ()
installShared = Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath
-> FilePath
-> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> FilePath
-> FilePath
-> IO ()
install Bool
True

    copyModuleFiles :: Suffix -> IO ()
copyModuleFiles Suffix
ext = do
      [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
files <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPath Pkg ('Dir Build)]
-> [Suffix]
-> [ModuleName]
-> IO [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> [ModuleName]
-> IO
     [(SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File)]
findModuleFilesCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [SymbolicPath Pkg ('Dir Build)
builtDir] [Suffix
ext] (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
      let files' :: [(FilePath, FilePath)]
files' = ((SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)
 -> (FilePath, FilePath))
-> [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
-> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolicPath Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPath Pkg ('Dir Build) -> FilePath)
-> (RelativePath Build 'File -> FilePath)
-> (SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)
-> (FilePath, FilePath)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** RelativePath Build 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath) [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
files
      Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
installOrdinaryFiles Verbosity
verbosity FilePath
targetDir [(FilePath, FilePath)]
files'

    copyDirectoryIfExists :: RelativePath Build (Dir Artifacts) -> IO ()
    copyDirectoryIfExists :: RelativePath Build ('Dir Artifacts) -> IO ()
copyDirectoryIfExists RelativePath Build ('Dir Artifacts)
dirName = do
      let src :: FilePath
src = SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts) -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts) -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build)
builtDir SymbolicPath Pkg ('Dir Build)
-> RelativePath Build ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Build ('Dir Artifacts)
dirName
          dst :: FilePath
dst = FilePath
targetDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Build ('Dir Artifacts) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath RelativePath Build ('Dir Artifacts)
dirName
      Bool
dirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
src
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity FilePath
src FilePath
dst

    compiler_id :: CompilerId
compiler_id = Compiler -> CompilerId
compilerId (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
    platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
    profileLibName :: FilePath
profileLibName = UnitId -> FilePath
mkProfLibName UnitId
uid
    ghciLibName :: FilePath
ghciLibName = UnitId -> FilePath
Internal.mkGHCiLibName UnitId
uid
    ghciProfLibName :: FilePath
ghciProfLibName = UnitId -> FilePath
Internal.mkGHCiProfLibName UnitId
uid

    hasLib :: Bool
hasLib =
      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)
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
cSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
cmmSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
asmSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& ([SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
jsSources (Library -> BuildInfo
libBuildInfo Library
lib)) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
hasJsSupport)
    hasJsSupport :: Bool
hasJsSupport = case LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi of
      Platform Arch
JavaScript OS
_ -> Bool
True
      Platform
_ -> Bool
False
    has_code :: Bool
has_code = Bool -> Bool
not (ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi)
    whenHasCode :: IO () -> IO ()
whenHasCode = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_code
    whenVanilla :: IO () -> IO ()
whenVanilla = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi)
    whenProf :: IO () -> IO ()
whenProf = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
has_code)
    whenGHCi :: IO () -> IO ()
whenGHCi = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withGHCiLib LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
has_code)
    whenShared :: IO () -> IO ()
whenShared = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
has_code)

-- -----------------------------------------------------------------------------
-- Registering

hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
hcPkgInfo :: ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb =
  HcPkg.HcPkgInfo
    { hcPkgProgram :: ConfiguredProgram
HcPkg.hcPkgProgram = ConfiguredProgram
ghcPkgProg
    , noPkgDbStack :: Bool
HcPkg.noPkgDbStack = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
< [Int
6, Int
9]
    , noVerboseFlag :: Bool
HcPkg.noVerboseFlag = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
< [Int
6, Int
11]
    , flagPackageConf :: Bool
HcPkg.flagPackageConf = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
< [Int
7, Int
5]
    , supportsDirDbs :: Bool
HcPkg.supportsDirDbs = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
6, Int
8]
    , requiresDirDbs :: Bool
HcPkg.requiresDirDbs = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
7, Int
10]
    , nativeMultiInstance :: Bool
HcPkg.nativeMultiInstance = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
7, Int
10]
    , recacheMultiInstance :: Bool
HcPkg.recacheMultiInstance = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
6, Int
12]
    , suppressFilesCheck :: Bool
HcPkg.suppressFilesCheck = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
6, Int
6]
    }
  where
    v :: [Int]
v = Version -> [Int]
versionNumbers Version
ver
    ghcPkgProg :: ConfiguredProgram
ghcPkgProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ConfiguredProgram
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.hcPkgInfo: no ghc program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcPkgProgram ProgramDb
progdb
    ver :: Version
ver = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Version
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.hcPkgInfo: no ghc version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcPkgProg

registerPackage
  :: Verbosity
  -> ProgramDb
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: Verbosity
-> ProgramDb
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [PackageDB]
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
HcPkg.register
    (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb)
    Verbosity
verbosity
    Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    [PackageDB]
packageDbs
    InstalledPackageInfo
installedPkgInfo
    RegisterOptions
registerOptions

pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD (Dir Pkg))
pkgRoot :: Verbosity
-> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD ('Dir Pkg))
pkgRoot Verbosity
verbosity LocalBuildInfo
lbi = (FilePath -> SymbolicPath CWD ('Dir Pkg))
-> IO FilePath -> IO (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (IO FilePath -> IO (SymbolicPath CWD ('Dir Pkg)))
-> (PackageDB -> IO FilePath)
-> PackageDB
-> IO (SymbolicPath CWD ('Dir Pkg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDB -> IO FilePath
pkgRoot'
  where
    pkgRoot' :: PackageDB -> IO FilePath
pkgRoot' PackageDB
GlobalPackageDB =
      let ghcProg :: ConfiguredProgram
ghcProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ConfiguredProgram
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.pkgRoot: no ghc program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
       in (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
takeDirectory (Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg)
    pkgRoot' PackageDB
UserPackageDB = do
      FilePath
appDir <- IO FilePath
getGhcAppDir
      let ver :: Version
ver = Compiler -> Version
compilerVersion (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
          subdir :: FilePath
subdir =
            FilePath
System.Info.arch
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
System.Info.os
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
ver
          rootDir :: FilePath
rootDir = FilePath
appDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
subdir
      -- We must create the root directory for the user package database if it
      -- does not yet exist. Otherwise '${pkgroot}' will resolve to a
      -- directory at the time of 'ghc-pkg register', and registration will
      -- fail.
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
rootDir
      FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
rootDir
    pkgRoot' (SpecificPackageDB FilePath
fp) =
      FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
        FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
          LocalBuildInfo -> SymbolicPathX Any Pkg Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi (FilePath -> SymbolicPathX Any Pkg Any
forall (allowAbs :: AllowAbsolute) from (to :: FileOrDir).
FilePath -> SymbolicPathX allowAbs from to
unsafeMakeSymbolicPath FilePath
fp)