{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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
  , compilerBuildWay
  , 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 qualified Distribution.Simple.GHC.Build as GHC
import Distribution.Simple.GHC.Build.Modules (BuildWay (..))
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
  (ghcProg, ghcVersion, 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 = Version -> GhcImplInfo
ghcVersionImplInfo Version
ghcVersion

  -- Cabal currently supports ghc >= 7.0.1 && < 9.12
  -- ... and the following odd development version
  unless (ghcVersion < mkVersion [9, 12]) $
    warn verbosity $
      "Unknown/unsupported 'ghc' version detected "
        ++ "(Cabal "
        ++ prettyShow cabalVersion
        ++ " supports 'ghc' version < 9.12): "
        ++ programPath ghcProg
        ++ " is version "
        ++ prettyShow 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:
  (ghcPkgProg, ghcPkgVersion, progdb2) <-
    requireProgramVersion
      verbosity
      ghcPkgProgram
        { programFindLocation = guessGhcPkgFromGhcPath ghcProg
        }
      anyVersion
      (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)

  when (ghcVersion /= ghcPkgVersion) $
    dieWithException verbosity $
      VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion
  -- Likewise we try to find the matching hsc2hs and haddock programs.
  let hsc2hsProgram' =
        Program
hsc2hsProgram
          { programFindLocation = guessHsc2hsFromGhcPath ghcProg
          }
      haddockProgram' =
        Program
haddockProgram
          { programFindLocation = guessHaddockFromGhcPath ghcProg
          }
      hpcProgram' =
        Program
hpcProgram
          { programFindLocation = guessHpcFromGhcPath ghcProg
          }
      runghcProgram' =
        Program
runghcProgram
          { programFindLocation = guessRunghcFromGhcPath ghcProg
          }
      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

  languages <- Internal.getLanguages verbosity implInfo ghcProg
  extensions0 <- Internal.getExtensions verbosity implInfo ghcProg

  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg
  let ghcInfoMap = [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FilePath, FilePath)]
ghcInfo
      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 =
        -- 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
        | 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
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 = CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHC Version
ghcVersion

      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
          { 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 = [(FilePath, FilePath)] -> Maybe Platform
Internal.targetPlatform [(FilePath, FilePath)]
ghcInfo
      -- configure gcc and ld
      progdb4 = GhcImplInfo
-> ConfiguredProgram
-> Map FilePath FilePath
-> ProgramDb
-> ProgramDb
Internal.configureToolchain GhcImplInfo
implInfo ConfiguredProgram
ghcProg Map FilePath FilePath
ghcInfoMap ProgramDb
progdb3
  return (comp, compPlatform, 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
    real_path <- FilePath -> IO FilePath
canonicalizePath FilePath
given_path
    let real_dir = FilePath -> FilePath
takeDirectory FilePath
real_path
        versionSuffix FilePath
path = FilePath -> FilePath
takeVersionSuffix (FilePath -> FilePath
dropExeExtension FilePath
path)
        given_suf = FilePath -> FilePath
versionSuffix FilePath
given_path
        real_suf = FilePath -> FilePath
versionSuffix FilePath
real_path
        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
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
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
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 =
          ( 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
    info verbosity $
      "looking for tool "
        ++ toolname
        ++ " near compiler in "
        ++ given_dir
    debug verbosity $ "candidate locations: " ++ show guesses
    exists <- traverse doesFileExist guesses
    case [file | (file, True) <- zip guesses 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 from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> ProgramDb
  -> IO InstalledPackageIndex
getPackageDBContents :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
getPackageDBContents Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb ProgramDb
progdb = do
  pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir [PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb] ProgramDb
progdb
  toPackageIndex verbosity pkgss progdb

-- | Given a package DB stack, return all installed packages.
getInstalledPackages
  :: Verbosity
  -> Compiler
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: forall from.
Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs ProgramDb
progdb = do
  Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity
  Verbosity
-> Compiler
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> IO ()
forall fp.
Eq fp =>
Verbosity -> Compiler -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs
  pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs ProgramDb
progdb
  index <- toPackageIndex verbosity pkgss progdb
  return $! hackRtsPackage 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
  -> [(PackageDBX a, [InstalledPackageInfo])]
  -> ProgramDb
  -> IO InstalledPackageIndex
toPackageIndex :: forall a.
Verbosity
-> [(PackageDBX a, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDBX a, [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.
  topDir <- Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcProg
  let 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)
        | (PackageDBX a
_, [InstalledPackageInfo]
pkgs) <- [(PackageDBX a, [InstalledPackageInfo])]
pkgss
        ]
  return $! mconcat 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.
  appdir <- IO FilePath
getGhcAppDir
  return (appdir </> platformAndVersion </> 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 :: Eq fp => Verbosity -> Compiler -> PackageDBStackX fp -> IO ()
checkPackageDbStack :: forall fp.
Eq fp =>
Verbosity -> Compiler -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp =
  if GhcImplInfo -> Bool
flagPackageConf GhcImplInfo
implInfo
    then Verbosity -> PackageDBStackX fp -> IO ()
forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPre76 Verbosity
verbosity
    else Verbosity -> PackageDBStackX fp -> IO ()
forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPost76 Verbosity
verbosity
  where
    implInfo :: GhcImplInfo
implInfo = Version -> GhcImplInfo
ghcVersionImplInfo (Compiler -> Version
compilerVersion Compiler
comp)

checkPackageDbStackPost76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPost76 :: forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPost76 Verbosity
_ (PackageDBX fp
GlobalPackageDB : [PackageDBX fp]
rest)
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDBX fp]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStackPost76 Verbosity
verbosity [PackageDBX fp]
rest
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageDBX fp]
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
_ [PackageDBX fp]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkPackageDbStackPre76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPre76 :: forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStackPre76 Verbosity
_ (PackageDBX fp
GlobalPackageDB : [PackageDBX fp]
rest)
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDBX fp]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStackPre76 Verbosity
verbosity [PackageDBX fp]
rest
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDBX fp]
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 [PackageDBX fp]
_ =
  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 from))
  -> [PackageDBX (SymbolicPath from (Dir PkgDB))]
  -> ProgramDb
  -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]
getInstalledPackages' :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir [PackageDBX (SymbolicPath from ('Dir PkgDB))]
packagedbs ProgramDb
progdb =
  [IO
   (PackageDBX (SymbolicPath from ('Dir PkgDB)),
    [InstalledPackageInfo])]
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [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
      pkgs <- HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
HcPkg.dump (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb) Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb
      return (packagedb, pkgs)
    | PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb <- [PackageDBX (SymbolicPath from ('Dir PkgDB))]
packagedbs
    ]

getInstalledPackagesMonitorFiles
  :: forall from
   . Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> Platform
  -> ProgramDb
  -> [PackageDBS from]
  -> IO [FilePath]
getInstalledPackagesMonitorFiles :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> Platform
-> ProgramDb
-> [PackageDBS from]
-> IO [FilePath]
getInstalledPackagesMonitorFiles Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir Platform
platform ProgramDb
progdb =
  (PackageDBS from -> IO FilePath)
-> [PackageDBS from] -> 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 PackageDBS from -> IO FilePath
getPackageDBPath
  where
    getPackageDBPath :: PackageDBS from -> IO FilePath
    getPackageDBPath :: PackageDBS from -> IO FilePath
getPackageDBPath PackageDBS from
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 PackageDBS from
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 SymbolicPath from ('Dir PkgDB)
path) = FilePath -> IO FilePath
selectMonitorFile (Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
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 from))
-> SymbolicPathX 'OnlyRelative from (ZonkAny 2) -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir (FilePath -> SymbolicPathX 'OnlyRelative from (ZonkAny 2)
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
path0)
              else FilePath
path0
      isFileStyle <- FilePath -> IO Bool
doesFileExist FilePath
path
      if isFileStyle
        then return path
        else return (path </> "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 -> PackageDBStack -> IO ()
startInterpreter Verbosity
verbosity ProgramDb
progdb Compiler
comp Platform
platform PackageDBStack
packageDBs = do
  let replOpts :: GhcOptions
replOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeInteractive
          , ghcOptPackageDBs = packageDBs
          }
  Verbosity -> Compiler -> PackageDBStack -> IO ()
forall fp.
Eq fp =>
Verbosity -> Compiler -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs
  (ghcProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram ProgramDb
progdb
  runGHC verbosity ghcProg comp platform Nothing 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 = hcOptions GHC libBi ++ 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 = hcOptions GHC libBi ++ hcProfOptions GHC libBi
          }
    profDynArgs :: GhcOptions
profDynArgs =
      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)
          , ghcOptDynLinkMode = toFlag GhcDynamicOnly
          , ghcOptFPic = toFlag True
          , ghcOptHiSuffix = toFlag "p_dyn_hi"
          , ghcOptObjSuffix = toFlag "p_dyn_o"
          , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi
          }
    ghcArgs :: GhcOptions
ghcArgs =
      let (Bool -> [BuildWay]
libWays, Bool -> BuildWay
_, BuildWay
_) = LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
buildWays LocalBuildInfo
lbi
       in case Bool -> [BuildWay]
libWays (ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi) of
            (BuildWay
ProfDynWay : [BuildWay]
_) -> GhcOptions
profDynArgs
            (BuildWay
ProfWay : [BuildWay]
_) -> GhcOptions
profArgs
            (BuildWay
StaticWay : [BuildWay]
_) -> GhcOptions
vanillaArgs
            (BuildWay
DynWay : [BuildWay]
_) -> GhcOptions
sharedArgs
            [BuildWay]
_ -> FilePath -> GhcOptions
forall a. HasCallStack => FilePath -> a
error FilePath
"libAbiHash: Can't find an enabled library way"

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

  hash <-
    getProgramInvocationOutput
      verbosity
      =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir ghcArgs

  return (takeWhile (not . isSpace) 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 ()
install
    (ForeignLib -> Bool
foreignLibIsShared ForeignLib
flib)
    FilePath
builtDir
    FilePath
targetDir
    (LocalBuildInfo -> ForeignLib -> FilePath
flibTargetName LocalBuildInfo
lbi ForeignLib
flib)
  where
    install :: Bool -> FilePath -> FilePath -> FilePath -> IO ()
install Bool
isShared FilePath
srcDir FilePath
dstDir FilePath
name = do
      let src :: FilePath
src = FilePath
srcDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> 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
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'.
        Verbosity -> FilePath -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
dstDir FilePath
nm ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
            let link1 :: FilePath
link1 = LocalBuildInfo -> ForeignLib -> FilePath
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
                link2 :: FilePath
link2 = FilePath
"lib" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nm FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"so"
            FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
name (FilePath
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link1)
            FilePath -> FilePath -> IO ()
renameFile (FilePath
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link1) (FilePath
dstDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link1)
            FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
name (FilePath
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link2)
            FilePath -> FilePath -> IO ()
renameFile (FilePath
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link2) (FilePath
dstDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
link2)
      where
        nm :: String
        nm :: FilePath
nm = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
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
  let
    (Bool -> [BuildWay]
wantedLibWays, Bool -> BuildWay
_, BuildWay
_) = LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
buildWays LocalBuildInfo
lbi
    isIndef :: Bool
isIndef = ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi
    libWays :: [BuildWay]
libWays = Bool -> [BuildWay]
wantedLibWays Bool
isIndef

  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Wanted install ways: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [BuildWay] -> FilePath
forall a. Show a => a -> FilePath
show [BuildWay]
libWays)

  -- copy .hi files over:
  [BuildWay] -> (BuildWay -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bool -> [BuildWay]
wantedLibWays Bool
isIndef) ((BuildWay -> IO ()) -> IO ()) -> (BuildWay -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BuildWay
w -> case BuildWay
w of
    BuildWay
StaticWay -> Suffix -> IO ()
copyModuleFiles (FilePath -> Suffix
Suffix FilePath
"hi")
    BuildWay
DynWay -> Suffix -> IO ()
copyModuleFiles (FilePath -> Suffix
Suffix FilePath
"dyn_hi")
    BuildWay
ProfWay -> Suffix -> IO ()
copyModuleFiles (FilePath -> Suffix
Suffix FilePath
"p_hi")
    BuildWay
ProfDynWay -> Suffix -> IO ()
copyModuleFiles (FilePath -> Suffix
Suffix FilePath
"p_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:
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
has_code Bool -> Bool -> Bool
&& Bool
hasLib) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [BuildWay] -> (BuildWay -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BuildWay]
libWays ((BuildWay -> IO ()) -> IO ()) -> (BuildWay -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BuildWay
w -> case BuildWay
w of
      BuildWay
StaticWay -> 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
      BuildWay
ProfWay -> 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
      BuildWay
ProfDynWay -> 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
          (Platform -> CompilerId -> UnitId -> FilePath
mkProfSharedLibName Platform
platform CompilerId
compiler_id UnitId
uid)
      BuildWay
DynWay -> do
        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
                    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' =
                          Platform -> CompilerId -> FilePath -> FilePath
mkGenericSharedBundledLibName
                            Platform
platform
                            CompilerId
compiler_id
                            (FilePath
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f)
                    forM_ files $ \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
                        isFile <- FilePath -> IO Bool
doesFileExist (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build)
builtDir SymbolicPath Pkg ('Dir Build)
-> RelativePath Build (ZonkAny 0)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Build (ZonkAny 0)
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
file)
                        when isFile $ do
                          installShared
                            builtDir
                            dynlibTargetDir
                            file
                  | FilePath
l <- 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)
                  ]
  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 (ZonkAny 1) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX allowAbsolute Pkg (ZonkAny 1) -> FilePath)
-> SymbolicPathX allowAbsolute Pkg (ZonkAny 1) -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPathX allowAbsolute Pkg ('Dir from)
srcDir SymbolicPathX allowAbsolute Pkg ('Dir from)
-> RelativePath from (ZonkAny 1)
-> SymbolicPathX allowAbsolute Pkg (ZonkAny 1)
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath from (ZonkAny 1)
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
      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' = ((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
      installOrdinaryFiles verbosity targetDir 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
      dirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
src
      when dirExists $ copyDirectoryRecursive verbosity src 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)
    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)

-- -----------------------------------------------------------------------------
-- 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 from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: forall from.
Verbosity
-> ProgramDb
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
HcPkg.register
    (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb)
    Verbosity
verbosity
    Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir
    PackageDBStackS from
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
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute Pkg to) -> IO FilePath
pkgRoot'
  where
    pkgRoot' :: PackageDBX (SymbolicPathX allowAbsolute Pkg to) -> IO FilePath
pkgRoot' PackageDBX (SymbolicPathX allowAbsolute Pkg to)
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' PackageDBX (SymbolicPathX allowAbsolute Pkg to)
UserPackageDB = do
      appDir <- IO FilePath
getGhcAppDir
      let ver = Compiler -> Version
compilerVersion (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
          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
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.
      createDirectoryIfMissing True rootDir
      return rootDir
    pkgRoot' (SpecificPackageDB SymbolicPathX allowAbsolute Pkg to
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 allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi SymbolicPathX allowAbsolute Pkg to
fp