{-# LANGUAGE CPP #-}
{-# 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.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 (Flag (..), toFlag)
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 (extraCompilationArtifacts)
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.Verbosity
import Distribution.Version
import Language.Haskell.Extension
import System.Directory
  ( canonicalizePath
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getAppUserDataDirectory
  , getDirectoryContents
  )
import System.FilePath
  ( 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 :: FilePath -> FilePath
guessNormal FilePath
dir = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
toolname FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        guessGhcVersioned :: FilePath -> FilePath -> FilePath
guessGhcVersioned FilePath
dir FilePath
suf =
          FilePath
dir
            FilePath -> FilePath -> FilePath
</> (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
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        guessVersioned :: FilePath -> FilePath -> FilePath
guessVersioned FilePath
dir FilePath
suf =
          FilePath
dir
            FilePath -> FilePath -> FilePath
</> (FilePath
toolname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suf)
              FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
        mkGuesses :: FilePath -> FilePath -> [FilePath]
mkGuesses FilePath
dir FilePath
suf
          | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
suf = [FilePath -> FilePath
guessNormal FilePath
dir]
          | Bool
otherwise =
              [ FilePath -> FilePath -> FilePath
guessGhcVersioned FilePath
dir FilePath
suf
              , FilePath -> FilePath -> FilePath
guessVersioned FilePath
dir FilePath
suf
              , FilePath -> FilePath
guessNormal FilePath
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]
mkGuesses FilePath
real_dir FilePath
real_suf
          )
            [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> [FilePath]
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
  -> PackageDB
  -> ProgramDb
  -> IO InstalledPackageIndex
getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb -> IO InstalledPackageIndex
getPackageDBContents Verbosity
verbosity PackageDB
packagedb ProgramDb
progdb = do
  [(PackageDB, [InstalledPackageInfo])]
pkgss <- Verbosity
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [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
  -> PackageDBStack
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> Compiler -> [PackageDB] -> ProgramDb -> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp [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
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [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
</> FilePath
platformAndVersion FilePath -> FilePath -> FilePath
</> 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
  -> [PackageDB]
  -> ProgramDb
  -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' :: Verbosity
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [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 -> PackageDB -> IO [InstalledPackageInfo]
HcPkg.dump (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb) Verbosity
verbosity 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
  -> Platform
  -> ProgramDb
  -> [PackageDB]
  -> IO [FilePath]
getInstalledPackagesMonitorFiles :: Verbosity -> Platform -> ProgramDb -> [PackageDB] -> IO [FilePath]
getInstalledPackagesMonitorFiles Verbosity
verbosity 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
path = do
      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
</> 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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (BuildFlags -> BuildingWhat
BuildNormal BuildFlags
flags) LocalBuildInfo
lbi (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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (ReplFlags -> BuildingWhat
BuildRepl ReplFlags
flags) LocalBuildInfo
lbi (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 -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform 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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (BuildFlags -> BuildingWhat
BuildNormal BuildFlags
forall a. Monoid a => a
mempty{buildVerbosity = toFlag v}) LocalBuildInfo
lbi (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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (ReplFlags -> BuildingWhat
BuildRepl ReplFlags
replFlags) LocalBuildInfo
lbi (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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (BuildFlags -> BuildingWhat
BuildNormal BuildFlags
forall a. Monoid a => a
mempty{buildVerbosity = toFlag v}) LocalBuildInfo
lbi (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
$
    BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
PreBuildComponentInputs (ReplFlags -> BuildingWhat
BuildRepl ReplFlags
replFlags) LocalBuildInfo
lbi (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
    vanillaArgs :: GhcOptions
vanillaArgs =
      (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath
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
-> GhcOptions
-> IO ProgramInvocation
ghcInvocation Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform 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
</> FilePath
exeName' FilePath -> FilePath -> FilePath
</> FilePath
exeFileName)
            (FilePath
dest FilePath -> FilePath -> FilePath
<.> 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
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi))
    FilePath -> IO ()
installBinary (FilePath
binDir FilePath -> FilePath -> FilePath
</> 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
</> FilePath
name
          dst :: FilePath
dst = FilePath
dstDir FilePath -> FilePath -> FilePath
</> 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
<.> FilePath
"so"
            FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
name (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
link1)
            FilePath -> FilePath -> IO ()
renameFile (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
link1) (FilePath
dstDir FilePath -> FilePath -> FilePath
</> FilePath
link1)
            FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
name (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
link2)
            FilePath -> FilePath -> IO ()
renameFile (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
link2) (FilePath
dstDir FilePath -> FilePath -> FilePath
</> 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
  -- 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
  FilePath -> IO ()
copyDirectoryIfExists FilePath
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_
        [ FilePath -> FilePath -> FilePath -> IO ()
installOrdinary
          FilePath
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
$ FilePath -> FilePath -> FilePath -> IO ()
installOrdinary FilePath
builtDir FilePath
targetDir FilePath
ghciLibName
    IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> FilePath -> FilePath -> IO ()
installOrdinary FilePath
builtDir FilePath
targetDir FilePath
profileLibName
      IO () -> IO ()
whenGHCi (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> IO ()
installOrdinary FilePath
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_
                [ FilePath -> FilePath -> FilePath -> IO ()
installShared
                  FilePath
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_
                [ FilePath -> FilePath -> FilePath -> IO ()
installShared
                  FilePath
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 FilePath
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 (FilePath
builtDir FilePath -> FilePath -> FilePath
</> 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
                        FilePath -> FilePath -> FilePath -> IO ()
installShared
                          FilePath
builtDir
                          FilePath
dynlibTargetDir
                          FilePath
file
                | FilePath
l <- BuildInfo -> [FilePath]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib)
                ]
  where
    builtDir :: FilePath
builtDir = LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi

    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
</> FilePath
name
          dst :: FilePath
dst = FilePath
dstDir FilePath -> FilePath -> FilePath
</> 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 :: FilePath -> FilePath -> FilePath -> IO ()
installOrdinary = Bool -> FilePath -> FilePath -> FilePath -> IO ()
install Bool
False
    installShared :: FilePath -> FilePath -> FilePath -> IO ()
installShared = Bool -> FilePath -> FilePath -> FilePath -> IO ()
install Bool
True

    copyModuleFiles :: Suffix -> IO ()
copyModuleFiles Suffix
ext =
      Verbosity
-> [FilePath]
-> [Suffix]
-> [ModuleName]
-> IO [(FilePath, FilePath)]
findModuleFilesEx Verbosity
verbosity [FilePath
builtDir] [Suffix
ext] (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
        IO [(FilePath, FilePath)]
-> ([(FilePath, FilePath)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
installOrdinaryFiles Verbosity
verbosity FilePath
targetDir

    copyDirectoryIfExists :: FilePath -> IO ()
copyDirectoryIfExists FilePath
dirName = do
      let src :: FilePath
src = FilePath
builtDir FilePath -> FilePath -> FilePath
</> FilePath
dirName
          dst :: FilePath
dst = FilePath
targetDir FilePath -> FilePath -> FilePath
</> FilePath
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
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [FilePath]
cSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [FilePath]
cxxSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [FilePath]
cmmSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [FilePath]
asmSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [FilePath]
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
  -> PackageDBStack
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: Verbosity
-> ProgramDb
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb [PackageDB]
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  HcPkgInfo
-> Verbosity
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
HcPkg.register
    (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb)
    Verbosity
verbosity
    [PackageDB]
packageDbs
    InstalledPackageInfo
installedPkgInfo
    RegisterOptions
registerOptions

pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot Verbosity
verbosity LocalBuildInfo
lbi = 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
</> FilePath
subdir
      -- We must create the root directory for the user package database if it
      -- does not yet exists. 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 -> FilePath
takeDirectory FilePath
fp)