{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{- FOURMOLU_DISABLE -}

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

-- |
-- Module      :  Distribution.Client.SetupWrapper
-- Copyright   :  (c) The University of Glasgow 2006,
--                    Duncan Coutts 2008
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  alpha
-- Portability :  portable
--
-- An interface to building and installing Cabal packages.
-- If the @Built-Type@ field is specified as something other than
-- 'Custom', and the current version of Cabal is acceptable, this performs
-- setup actions directly.  Otherwise it builds the setup script and
-- runs it with the given arguments.
module Distribution.Client.SetupWrapper
  ( getSetup
  , runSetup
  , runSetupCommand
  , setupWrapper
  , SetupScriptOptions (..)
  , defaultSetupScriptOptions
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import qualified Distribution.Backpack as Backpack
import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)
import qualified Distribution.Make as Make
import Distribution.Package
  ( ComponentId
  , PackageId
  , PackageIdentifier (..)
  , mkPackageName
  , newSimpleUnitId
  , packageName
  , packageVersion
  , unsafeMkDefUnitId
  )
import Distribution.PackageDescription
  ( BuildType (..)
  , GenericPackageDescription (packageDescription)
  , PackageDescription (..)
  , buildType
  , specVersion
  )
import qualified Distribution.Simple as Simple
import Distribution.Simple.Build.Macros
  ( generatePackageVersionMacros
  )
import Distribution.Simple.BuildPaths
  ( defaultDistPref
  , exeExtension
  )
import Distribution.Simple.Compiler
import Distribution.Simple.Configure
  ( configCompilerEx
  )
import Distribution.Simple.PackageDescription
  ( readGenericPackageDescription
  )
import Distribution.Simple.PreProcess
  ( ppUnlit
  , runSimplePreProcessor
  )
import Distribution.Simple.Program
  ( ProgramDb
  , emptyProgramDb
  , getDbProgramOutputCwd
  , getProgramSearchPath
  , ghcProgram
  , ghcjsProgram
  , runDbProgramCwd
  )
import Distribution.Simple.Program.Db
  ( configureAllKnownPrograms
  , prependProgramSearchPath
  , progOverrideEnv
  )
import Distribution.Simple.Program.Find
  ( programSearchPathAsPATHVar
  )
import Distribution.Simple.Program.Run
  ( getEffectiveEnvironment
  )
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Types.ModuleRenaming (defaultRenaming)
import Distribution.Version
  ( Version
  , VersionRange
  , anyVersion
  , intersectVersionRanges
  , mkVersion
  , orLaterVersion
  , versionNumbers
  , withinRange
  )

import Distribution.Client.Config
  ( defaultCacheDir
  )
import Distribution.Client.IndexUtils
  ( getInstalledPackages
  )
import Distribution.Client.JobControl
  ( Lock
  , criticalSection
  )
import Distribution.Client.Types
import Distribution.Client.Utils
  ( existsAndIsMoreRecentThan
  , makeRelativeToDirS
#ifdef mingw32_HOST_OS
  , canonicalizePathNoThrow
#endif
  , moreRecentFile
  , tryCanonicalizePath
  , withEnv
  , withEnvOverrides
  , withExtraPathEnv
  )
import Distribution.Utils.Path
  hiding ( (</>), (<.>) )
import qualified Distribution.Utils.Path as Cabal.Path
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Simple.Command
  ( CommandUI (..)
  , commandShowOptions
  )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program.GHC
  ( GhcMode (..)
  , GhcOptions (..)
  , renderGhcOptions
  )
import Distribution.Simple.Setup
  ( CommonSetupFlags (..)
  , pattern Flag
  , GlobalFlags (..)
  , globalCommand
  )
import Distribution.Simple.Utils
  ( cabalVersion
  , copyFileVerbose
  , createDirectoryIfMissingVerbose
  , debug
  , die'
  , dieWithException
  , info
  , infoNoWrap
  , installExecutableFile
  , maybeExit
  , rawSystemProc
  , rewriteFileEx
  , rewriteFileLBS
  , tryFindPackageDesc
  )
import Distribution.Utils.Generic
  ( safeHead
  )

import Distribution.Compat.Stack
import Distribution.ReadE
import Distribution.System (Platform (..), buildPlatform)
import Distribution.Utils.NubList
  ( toNubListR
  )
import Distribution.Verbosity

import Data.List (foldl1')
import qualified Data.Map.Lazy as Map
import Distribution.Client.Compat.ExecutablePath (getExecutablePath)
import Distribution.Compat.Process (proc)
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import System.IO (Handle, hPutStr)
import System.Process (StdStream (..))
import qualified System.Process as Process

import qualified Data.ByteString.Lazy as BS
import Distribution.Client.Errors

#ifdef mingw32_HOST_OS
import Distribution.Simple.Utils
         ( withTempDirectory )

import Control.Exception   ( bracket )
import System.FilePath     ( equalFilePath, takeDirectory )
import System.Directory    ( doesDirectoryExist )
import qualified System.Win32 as Win32
#endif

-- | @Setup@ encapsulates the outcome of configuring a setup method to build a
-- particular package.
data Setup = Setup
  { Setup -> SetupMethod
setupMethod :: SetupMethod
  , Setup -> SetupScriptOptions
setupScriptOptions :: SetupScriptOptions
  , Setup -> Version
setupVersion :: Version
  , Setup -> BuildType
setupBuildType :: BuildType
  , Setup -> PackageDescription
setupPackage :: PackageDescription
  }

-- | @SetupMethod@ represents one of the methods used to run Cabal commands.
data SetupMethod
  = -- | run Cabal commands through \"cabal\" in the
    -- current process
    InternalMethod
  | -- | run Cabal commands through \"cabal\" as a
    -- child process
    SelfExecMethod
  | -- | run Cabal commands through a custom \"Setup\" executable
    ExternalMethod FilePath

-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two
-- parts: one that has no policy and just does as it's told with all the
-- explicit options, and an optional initial part that applies certain
-- policies (like if we should add the Cabal lib as a dep, and if so which
-- version). This could be structured as an action that returns a fully
-- elaborated 'SetupScriptOptions' containing no remaining policy choices.
--
-- See also the discussion at https://github.com/haskell/cabal/pull/3094

-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as
-- opposed to options given to the Cabal command at runtime.
data SetupScriptOptions = SetupScriptOptions
  { SetupScriptOptions -> VersionRange
useCabalVersion :: VersionRange
  -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive'
  -- is not set). A suitable version of the Cabal library must be installed
  -- (or for some build-types be the one cabal-install was built with).
  --
  -- The version found also determines the version of the Cabal specification
  -- that we us for talking to the Setup.hs, unless overridden by
  -- 'useCabalSpecVersion'.
  , SetupScriptOptions -> Maybe Version
useCabalSpecVersion :: Maybe Version
  -- ^ This is the version of the Cabal specification that we believe that
  -- this package uses. This affects the semantics and in particular the
  -- Setup command line interface.
  --
  -- This is similar to 'useCabalVersion' but instead of probing the system
  -- for a version of the /Cabal library/ you just say exactly which version
  -- of the /spec/ we will use. Using this also avoid adding the Cabal
  -- library as an additional dependency, so add it to 'useDependencies'
  -- if needed.
  , SetupScriptOptions -> Maybe Compiler
useCompiler :: Maybe Compiler
  , SetupScriptOptions -> Maybe Platform
usePlatform :: Maybe Platform
  , SetupScriptOptions -> PackageDBStackCWD
usePackageDB :: PackageDBStackCWD
  , SetupScriptOptions -> Maybe InstalledPackageIndex
usePackageIndex :: Maybe InstalledPackageIndex
  , SetupScriptOptions -> ProgramDb
useProgramDb :: ProgramDb
  , SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref :: SymbolicPath Pkg (Dir Dist)
  , SetupScriptOptions -> Maybe Handle
useLoggingHandle :: Maybe Handle
  , SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir :: Maybe (SymbolicPath CWD (Dir Pkg))
  , SetupScriptOptions -> [[Char]]
useExtraPathEnv :: [FilePath]
  -- ^ Extra things to add to PATH when invoking the setup script.
  , SetupScriptOptions -> [([Char], Maybe [Char])]
useExtraEnvOverrides :: [(String, Maybe FilePath)]
  -- ^ Extra environment variables paired with overrides, where
  --
  -- * @'Just' v@ means \"set the environment variable's value to @v@\".
  -- * 'Nothing' means \"unset the environment variable\".
  , SetupScriptOptions -> Bool
forceExternalSetupMethod :: Bool
  , SetupScriptOptions -> [(ComponentId, PackageId)]
useDependencies :: [(ComponentId, PackageId)]
  -- ^ List of dependencies to use when building Setup.hs.
  , SetupScriptOptions -> Bool
useDependenciesExclusive :: Bool
  -- ^ Is the list of setup dependencies exclusive?
  --
  -- When this is @False@, if we compile the Setup.hs script we do so with the
  -- list in 'useDependencies' but all other packages in the environment are
  -- also visible. A suitable version of @Cabal@ library (see
  -- 'useCabalVersion') is also added to the list of dependencies, unless
  -- 'useDependencies' already contains a Cabal dependency.
  --
  -- When @True@, only the 'useDependencies' packages are used, with other
  -- packages in the environment hidden.
  --
  -- This feature is here to support the setup stanza in .cabal files that
  -- specifies explicit (and exclusive) dependencies, as well as the old
  -- style with no dependencies.
  , SetupScriptOptions -> Bool
useVersionMacros :: Bool
  -- ^ Should we build the Setup.hs with CPP version macros available?
  -- We turn this on when we have a setup stanza in .cabal that declares
  -- explicit setup dependencies.
  , -- Used only by 'cabal clean' on Windows.
    --
    -- Note: win32 clean hack
    -------------------------
    -- On Windows, running './dist/setup/setup clean' doesn't work because the
    -- setup script will try to delete itself (which causes it to fail horribly,
    -- unlike on Linux). So we have to move the setup exe out of the way first
    -- and then delete it manually. This applies only to the external setup
    -- method.
    SetupScriptOptions -> Bool
useWin32CleanHack :: Bool
  , -- Used only when calling setupWrapper from parallel code to serialise
    -- access to the setup cache; should be Nothing otherwise.
    --
    -- Note: setup exe cache
    ------------------------
    -- When we are installing in parallel, we always use the external setup
    -- method. Since compiling the setup script each time adds noticeable
    -- overhead, we use a shared setup script cache
    -- ('$XDG_CACHE_HOME/cabal/setup-exe-cache'). For each (compiler, platform, Cabal
    -- version) combination the cache holds a compiled setup script
    -- executable. This only affects the Simple build type; for the Custom,
    -- Configure and Make build types we always compile the setup script anew.
    SetupScriptOptions -> Maybe Lock
setupCacheLock :: Maybe Lock
  , SetupScriptOptions -> Bool
isInteractive :: Bool
  -- ^ Is the task we are going to run an interactive foreground task,
  -- or an non-interactive background task? Based on this flag we
  -- decide whether or not to delegate ctrl+c to the spawned task
  , SetupScriptOptions -> Bool
isMainLibOrExeComponent :: Bool
  -- ^ Let the setup script logic know if it is being run to build a main
  -- library or executable component.  This is used to determine if we should
  -- use the configure command, if the build-type is 'Configure'.  For
  -- configure, only the main library and execomponents have 'configure'
  -- support, and thus we can skip running configure for other components.
  }

defaultSetupScriptOptions :: SetupScriptOptions
defaultSetupScriptOptions :: SetupScriptOptions
defaultSetupScriptOptions =
  SetupScriptOptions
    { useCabalVersion :: VersionRange
useCabalVersion = VersionRange
anyVersion
    , useCabalSpecVersion :: Maybe Version
useCabalSpecVersion = Maybe Version
forall a. Maybe a
Nothing
    , useCompiler :: Maybe Compiler
useCompiler = Maybe Compiler
forall a. Maybe a
Nothing
    , usePlatform :: Maybe Platform
usePlatform = Maybe Platform
forall a. Maybe a
Nothing
    , usePackageDB :: PackageDBStackCWD
usePackageDB = [PackageDBX [Char]
forall fp. PackageDBX fp
GlobalPackageDB, PackageDBX [Char]
forall fp. PackageDBX fp
UserPackageDB]
    , usePackageIndex :: Maybe InstalledPackageIndex
usePackageIndex = Maybe InstalledPackageIndex
forall a. Maybe a
Nothing
    , useDependencies :: [(ComponentId, PackageId)]
useDependencies = []
    , useDependenciesExclusive :: Bool
useDependenciesExclusive = Bool
False
    , useVersionMacros :: Bool
useVersionMacros = Bool
False
    , useProgramDb :: ProgramDb
useProgramDb = ProgramDb
emptyProgramDb
    , useDistPref :: SymbolicPath Pkg ('Dir Dist)
useDistPref = SymbolicPath Pkg ('Dir Dist)
defaultDistPref
    , useLoggingHandle :: Maybe Handle
useLoggingHandle = Maybe Handle
forall a. Maybe a
Nothing
    , useWorkingDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir = Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
    , useExtraPathEnv :: [[Char]]
useExtraPathEnv = []
    , useExtraEnvOverrides :: [([Char], Maybe [Char])]
useExtraEnvOverrides = []
    , useWin32CleanHack :: Bool
useWin32CleanHack = Bool
False
    , forceExternalSetupMethod :: Bool
forceExternalSetupMethod = Bool
False
    , setupCacheLock :: Maybe Lock
setupCacheLock = Maybe Lock
forall a. Maybe a
Nothing
    , isInteractive :: Bool
isInteractive = Bool
False
    , isMainLibOrExeComponent :: Bool
isMainLibOrExeComponent = Bool
True
    }

workingDir :: SetupScriptOptions -> FilePath
workingDir :: SetupScriptOptions -> [Char]
workingDir SetupScriptOptions
options = case SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options of
  Just SymbolicPath CWD ('Dir Pkg)
dir
    | let fp :: [Char]
fp = SymbolicPath CWD ('Dir Pkg) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath CWD ('Dir Pkg)
dir
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
fp
    -> [Char]
fp
  Maybe (SymbolicPath CWD ('Dir Pkg))
_ -> [Char]
"."

-- | A @SetupRunner@ implements a 'SetupMethod'.
type SetupRunner =
  Verbosity
  -> SetupScriptOptions
  -> BuildType
  -> [String]
  -> IO ()

-- | Prepare to build a package by configuring a 'SetupMethod'. The returned
-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed
-- during the configuration process; the final values are given by
-- 'setupScriptOptions'.
getSetup
  :: Verbosity
  -> SetupScriptOptions
  -> Maybe PackageDescription
  -> IO Setup
getSetup :: Verbosity
-> SetupScriptOptions -> Maybe PackageDescription -> IO Setup
getSetup Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg = do
  pkg <- IO PackageDescription
-> (PackageDescription -> IO PackageDescription)
-> Maybe PackageDescription
-> IO PackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO PackageDescription
getPkg PackageDescription -> IO PackageDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageDescription
mpkg
  let options' =
        SetupScriptOptions
options
          { useCabalVersion =
              intersectVersionRanges
                (useCabalVersion options)
                (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))
          }
      -- We retain Configure only for the main library and executable components.
      -- For other components, we rewrite the buildType to Simple to skip the
      -- configure step.  This is because the configure step is not supported for
      -- other components.  Configure can only impact MainLib and Exe through
      -- .buildinfo files.
      buildType' = case (PackageDescription -> BuildType
buildType PackageDescription
pkg, SetupScriptOptions -> Bool
isMainLibOrExeComponent SetupScriptOptions
options) of
        (BuildType
Configure, Bool
False) -> BuildType
Simple
        (BuildType
bt, Bool
_) -> BuildType
bt
  (version, method, options'') <-
    getSetupMethod verbosity options' pkg buildType'
  return
    Setup
      { setupMethod = method
      , setupScriptOptions = options''
      , setupVersion = version
      , setupBuildType = buildType'
      , setupPackage = pkg
      }
  where
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options
    getPkg :: IO PackageDescription
getPkg =
      (RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath (RelativePath Pkg 'File -> SymbolicPath Pkg 'File)
-> IO (RelativePath Pkg 'File) -> IO (SymbolicPath Pkg 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir)
        IO (SymbolicPath Pkg 'File)
-> (SymbolicPath Pkg 'File -> IO GenericPackageDescription)
-> IO GenericPackageDescription
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
        IO GenericPackageDescription
-> (GenericPackageDescription -> IO PackageDescription)
-> IO PackageDescription
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageDescription -> IO PackageDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> IO PackageDescription)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> IO PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription

-- | Decide if we're going to be able to do a direct internal call to the
-- entry point in the Cabal library or if we're going to have to compile
-- and execute an external Setup.hs script.
getSetupMethod
  :: Verbosity
  -> SetupScriptOptions
  -> PackageDescription
  -> BuildType
  -> IO (Version, SetupMethod, SetupScriptOptions)
getSetupMethod :: Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> IO (Version, SetupMethod, SetupScriptOptions)
getSetupMethod Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
buildType'
  | BuildType
buildType' BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Custom
      Bool -> Bool -> Bool
|| BuildType
buildType' BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Hooks
      Bool -> Bool -> Bool
|| Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Version
cabalVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/=) (SetupScriptOptions -> Maybe Version
useCabalSpecVersion SetupScriptOptions
options)
      Bool -> Bool -> Bool
|| Bool -> Bool
not (Version
cabalVersion Version -> VersionRange -> Bool
`withinRange` SetupScriptOptions -> VersionRange
useCabalVersion SetupScriptOptions
options) =
      Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> IO (Version, SetupMethod, SetupScriptOptions)
getExternalSetupMethod Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
buildType'
  | Maybe Handle -> Bool
forall a. Maybe a -> Bool
isJust (SetupScriptOptions -> Maybe Handle
useLoggingHandle SetupScriptOptions
options)
      -- Forcing is done to use an external process e.g. due to parallel
      -- build concerns.
      Bool -> Bool -> Bool
|| SetupScriptOptions -> Bool
forceExternalSetupMethod SetupScriptOptions
options =
      (Version, SetupMethod, SetupScriptOptions)
-> IO (Version, SetupMethod, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
cabalVersion, SetupMethod
SelfExecMethod, SetupScriptOptions
options)
  | Bool
otherwise = (Version, SetupMethod, SetupScriptOptions)
-> IO (Version, SetupMethod, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
cabalVersion, SetupMethod
InternalMethod, SetupScriptOptions
options)

runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)
runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)
runSetupMethod SetupMethod
InternalMethod = SetupRunner
internalSetupMethod
runSetupMethod (ExternalMethod [Char]
path) = WithCallStack ([Char] -> SetupRunner)
[Char] -> SetupRunner
externalSetupMethod [Char]
path
runSetupMethod SetupMethod
SelfExecMethod = SetupRunner
selfExecSetupMethod

-- | Run a configured 'Setup' with specific arguments.
runSetup
  :: Verbosity
  -> Setup
  -> [String]
  -- ^ command-line arguments
  -> IO ()
runSetup :: Verbosity -> Setup -> [[Char]] -> IO ()
runSetup Verbosity
verbosity Setup
setup [[Char]]
args0 = do
  let method :: SetupMethod
method = Setup -> SetupMethod
setupMethod Setup
setup
      options :: SetupScriptOptions
options = Setup -> SetupScriptOptions
setupScriptOptions Setup
setup
      bt :: BuildType
bt = Setup -> BuildType
setupBuildType Setup
setup
      args :: [[Char]]
args = Version -> [[Char]] -> [[Char]]
verbosityHack (Setup -> Version
setupVersion Setup
setup) [[Char]]
args0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening {- avoid test if not debug -} Bool -> Bool -> Bool
&& [[Char]]
args [[Char]] -> [[Char]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [[Char]]
args0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> [Char] -> IO ()
infoNoWrap Verbosity
verbose ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"Applied verbosity hack:\n"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  Before: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args0
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  After:  "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
  WithCallStack (SetupMethod -> SetupRunner)
SetupMethod -> SetupRunner
runSetupMethod SetupMethod
method Verbosity
verbosity SetupScriptOptions
options BuildType
bt [[Char]]
args

-- | This is a horrible hack to make sure passing fancy verbosity
-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on
-- old Setup.  We can't do it in 'filterConfigureFlags' because
-- verbosity applies to ALL commands.
verbosityHack :: Version -> [String] -> [String]
verbosityHack :: Version -> [[Char]] -> [[Char]]
verbosityHack Version
ver [[Char]]
args0
  | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2, Int
1] = [[Char]]
args0
  | Bool
otherwise = [[Char]] -> [[Char]]
go [[Char]]
args0
  where
    go :: [[Char]] -> [[Char]]
go ((Char
'-' : Char
'v' : [Char]
rest) : [[Char]]
args)
      | Just [Char]
rest' <- [Char] -> Maybe [Char]
munch [Char]
rest = ([Char]
"-v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest') [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go [[Char]]
args
    go ((Char
'-' : Char
'-' : Char
'v' : Char
'e' : Char
'r' : Char
'b' : Char
'o' : Char
's' : Char
'e' : Char
'=' : [Char]
rest) : [[Char]]
args)
      | Just [Char]
rest' <- [Char] -> Maybe [Char]
munch [Char]
rest = ([Char]
"--verbose=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest') [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go [[Char]]
args
    go ([Char]
"--verbose" : [Char]
rest : [[Char]]
args)
      | Just [Char]
rest' <- [Char] -> Maybe [Char]
munch [Char]
rest = [Char]
"--verbose" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
rest' [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go [[Char]]
args
    go rest :: [[Char]]
rest@([Char]
"--" : [[Char]]
_) = [[Char]]
rest
    go ([Char]
arg : [[Char]]
args) = [Char]
arg [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go [[Char]]
args
    go [] = []

    munch :: [Char] -> Maybe [Char]
munch [Char]
rest =
      case ReadE Verbosity -> [Char] -> Either [Char] Verbosity
forall a. ReadE a -> [Char] -> Either [Char] a
runReadE ReadE Verbosity
flagToVerbosity [Char]
rest of
        Right Verbosity
v
          | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0]
          , Verbosity -> Bool
verboseHasFlags Verbosity
v ->
              -- We could preserve the prefix, but since we're assuming
              -- it's Cabal's verbosity flag, we can assume that
              -- any format is OK
              [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Verbosity -> [Char]
showForCabal (Verbosity -> Verbosity
verboseNoFlags Verbosity
v))
          | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
1]
          , Verbosity -> Bool
isVerboseTimestamp Verbosity
v ->
              -- +timestamp wasn't yet available in Cabal-2.0.0
              [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Verbosity -> [Char]
showForCabal (Verbosity -> Verbosity
verboseNoTimestamp Verbosity
v))
        Either [Char] Verbosity
_ -> Maybe [Char]
forall a. Maybe a
Nothing

-- | Run a command through a configured 'Setup'.
runSetupCommand
  :: Verbosity
  -> Setup
  -> CommandUI flags
  -- ^ command definition
  -> (flags -> CommonSetupFlags)
  -> flags
  -- ^ command flags
  -> [String]
  -- ^ extra command-line arguments
  -> IO ()
runSetupCommand :: forall flags.
Verbosity
-> Setup
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> flags
-> [[Char]]
-> IO ()
runSetupCommand Verbosity
verbosity Setup
setup CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags flags
flags [[Char]]
extraArgs =
  -- The 'setupWorkingDir' flag corresponds to a global argument which needs to
  -- be passed before the individual command (e.g. 'configure' or 'build').
  let common :: CommonSetupFlags
common = flags -> CommonSetupFlags
getCommonFlags flags
flags
      globalFlags :: GlobalFlags
globalFlags = GlobalFlags
forall a. Monoid a => a
mempty { globalWorkingDir = setupWorkingDir common }
      args :: [[Char]]
args = CommandUI GlobalFlags -> GlobalFlags -> [[Char]]
forall flags. CommandUI flags -> flags -> [[Char]]
commandShowOptions ([Command (ZonkAny 0)] -> CommandUI GlobalFlags
forall action. [Command action] -> CommandUI GlobalFlags
globalCommand []) GlobalFlags
globalFlags
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (CommandUI flags -> [Char]
forall flags. CommandUI flags -> [Char]
commandName CommandUI flags
cmd [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: CommandUI flags -> flags -> [[Char]]
forall flags. CommandUI flags -> flags -> [[Char]]
commandShowOptions CommandUI flags
cmd flags
flags [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs)
  in Verbosity -> Setup -> [[Char]] -> IO ()
runSetup Verbosity
verbosity Setup
setup [[Char]]
args

-- | Configure a 'Setup' and run a command in one step. The command flags
-- may depend on the Cabal library version in use.
setupWrapper
  :: Verbosity
  -> SetupScriptOptions
  -> Maybe PackageDescription
  -> CommandUI flags
  -> (flags -> CommonSetupFlags)
  -> (Version -> IO flags)
  -- ^ produce command flags given the Cabal library version
  -> (Version -> [String])
  -> IO ()
setupWrapper :: forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [[Char]])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags Version -> IO flags
getFlags Version -> [[Char]]
getExtraArgs = do
  setup <- Verbosity
-> SetupScriptOptions -> Maybe PackageDescription -> IO Setup
getSetup Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg
  let version = Setup -> Version
setupVersion Setup
setup
      extraArgs = Version -> [[Char]]
getExtraArgs Version
version
  flags <- getFlags version
  runSetupCommand
    verbosity
    setup
    cmd
    getCommonFlags
    flags
    extraArgs

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

-- * Internal SetupMethod

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

-- | Run a Setup script by directly invoking the @Cabal@ library.
internalSetupMethod :: SetupRunner
internalSetupMethod :: SetupRunner
internalSetupMethod Verbosity
verbosity SetupScriptOptions
options BuildType
bt [[Char]]
args = do
  Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"Using internal setup method with build-type "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuildType -> [Char]
forall a. Show a => a -> [Char]
show BuildType
bt
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and args:\n  "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args
  -- NB: we do not set the working directory of the process here, because
  -- we will instead pass the -working-dir flag when invoking the Setup script.
  -- Note that the Setup script is guaranteed to support this flag, because
  -- the logic in 'getSetupMethod' guarantees we have an up-to-date Cabal version.
  --
  -- In the future, it would be desirable to also stop relying on the following
  -- pieces of process-global state, as this would allow us to use this internal
  -- setup method in concurrent contexts.
  [Char] -> [Char] -> IO () -> IO ()
forall a. [Char] -> [Char] -> IO a -> IO a
withEnv [Char]
"HASKELL_DIST_DIR" (SymbolicPath Pkg ('Dir Dist) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath (SymbolicPath Pkg ('Dir Dist) -> [Char])
-> SymbolicPath Pkg ('Dir Dist) -> [Char]
forall a b. (a -> b) -> a -> b
$ SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
options) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [[Char]] -> IO () -> IO ()
forall a. [[Char]] -> IO a -> IO a
withExtraPathEnv (SetupScriptOptions -> [[Char]]
useExtraPathEnv SetupScriptOptions
options) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [([Char], Maybe [Char])] -> IO () -> IO ()
forall a. [([Char], Maybe [Char])] -> IO a -> IO a
withEnvOverrides (SetupScriptOptions -> [([Char], Maybe [Char])]
useExtraEnvOverrides SetupScriptOptions
options) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        BuildType -> [[Char]] -> IO ()
buildTypeAction BuildType
bt [[Char]]
args

buildTypeAction :: BuildType -> ([String] -> IO ())
buildTypeAction :: BuildType -> [[Char]] -> IO ()
buildTypeAction BuildType
Simple = [[Char]] -> IO ()
Simple.defaultMainArgs
buildTypeAction BuildType
Configure =
  SetupHooks -> [[Char]] -> IO ()
Simple.defaultMainWithSetupHooksArgs
    SetupHooks
Simple.autoconfSetupHooks
buildTypeAction BuildType
Make = [[Char]] -> IO ()
Make.defaultMainArgs
buildTypeAction BuildType
Hooks  = [Char] -> [[Char]] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"buildTypeAction Hooks"
buildTypeAction BuildType
Custom = [Char] -> [[Char]] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"buildTypeAction Custom"

invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()
invoke :: Verbosity -> [Char] -> [[Char]] -> SetupScriptOptions -> IO ()
invoke Verbosity
verbosity [Char]
path [[Char]]
args SetupScriptOptions
options = do
  Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords ([Char]
path [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)
  case SetupScriptOptions -> Maybe Handle
useLoggingHandle SetupScriptOptions
options of
    Maybe Handle
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Handle
logHandle -> Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Redirecting build log to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Handle -> [Char]
forall a. Show a => a -> [Char]
show Handle
logHandle

  progDb <- Verbosity
-> [[Char]]
-> [([Char], Maybe [Char])]
-> ProgramDb
-> IO ProgramDb
prependProgramSearchPath Verbosity
verbosity (SetupScriptOptions -> [[Char]]
useExtraPathEnv SetupScriptOptions
options) (SetupScriptOptions -> [([Char], Maybe [Char])]
useExtraEnvOverrides SetupScriptOptions
options) (SetupScriptOptions -> ProgramDb
useProgramDb SetupScriptOptions
options)

  searchpath <-
    programSearchPathAsPATHVar $ getProgramSearchPath progDb

  env <-
    getEffectiveEnvironment $
      [ ("PATH", Just searchpath)
      , ("HASKELL_DIST_DIR", Just (getSymbolicPath $ useDistPref options))
      ]
        ++ progOverrideEnv progDb

  let loggingHandle = case SetupScriptOptions -> Maybe Handle
useLoggingHandle SetupScriptOptions
options of
        Maybe Handle
Nothing -> StdStream
Inherit
        Just Handle
hdl -> Handle -> StdStream
UseHandle Handle
hdl
      cp =
        ([Char] -> [[Char]] -> CreateProcess
proc [Char]
path [[Char]]
args)
          { Process.cwd = fmap getSymbolicPath $ useWorkingDir options
          , Process.env = env
          , Process.std_out = loggingHandle
          , Process.std_err = loggingHandle
          , Process.delegate_ctlc = isInteractive options
          }
  maybeExit $ rawSystemProc verbosity cp

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

-- * Self-Exec SetupMethod

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

selfExecSetupMethod :: SetupRunner
selfExecSetupMethod :: SetupRunner
selfExecSetupMethod Verbosity
verbosity SetupScriptOptions
options BuildType
bt [[Char]]
args0 = do
  let args :: [[Char]]
args =
        [ [Char]
"act-as-setup"
        , [Char]
"--build-type=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuildType -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow BuildType
bt
        , [Char]
"--"
        ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args0
  Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"Using self-exec internal setup method with build-type "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuildType -> [Char]
forall a. Show a => a -> [Char]
show BuildType
bt
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and args:\n  "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args
  path <- IO [Char]
getExecutablePath
  invoke verbosity path args options

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

-- * External SetupMethod

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

externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)
externalSetupMethod :: WithCallStack ([Char] -> SetupRunner)
externalSetupMethod [Char]
path Verbosity
verbosity SetupScriptOptions
options BuildType
_ [[Char]]
args =
#ifndef mingw32_HOST_OS
  Verbosity -> [Char] -> [[Char]] -> SetupScriptOptions -> IO ()
invoke
    Verbosity
verbosity
    [Char]
path
    [[Char]]
args
    SetupScriptOptions
options
#else
    -- See 'Note: win32 clean hack' above.
    if useWin32CleanHack options
      then invokeWithWin32CleanHack path
      else invoke' path
  where
    invoke' p = invoke verbosity p args options

    invokeWithWin32CleanHack origPath = do
      info verbosity $ "Using the Win32 clean hack."
      -- Recursively removes the temp dir on exit.
      withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->
        bracket
          (moveOutOfTheWay tmpDir origPath)
          (\tmpPath -> maybeRestore origPath tmpPath)
          (\tmpPath -> invoke' tmpPath)

    moveOutOfTheWay tmpDir origPath = do
      let tmpPath = tmpDir </> "setup" <.> exeExtension buildPlatform
      Win32.moveFile origPath tmpPath
      return tmpPath

    maybeRestore origPath tmpPath = do
      let origPathDir = takeDirectory origPath
      origPathDirExists <- doesDirectoryExist origPathDir
      -- 'setup clean' didn't complete, 'dist/setup' still exists.
      when origPathDirExists $
        Win32.moveFile tmpPath origPath

#endif

getExternalSetupMethod
  :: Verbosity
  -> SetupScriptOptions
  -> PackageDescription
  -> BuildType
  -> IO (Version, SetupMethod, SetupScriptOptions)
getExternalSetupMethod :: Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> IO (Version, SetupMethod, SetupScriptOptions)
getExternalSetupMethod Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
bt = do
  Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Using external setup method with build-type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuildType -> [Char]
forall a. Show a => a -> [Char]
show BuildType
bt
  Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"Using explicit dependencies: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char]
forall a. Show a => a -> [Char]
show (SetupScriptOptions -> Bool
useDependenciesExclusive SetupScriptOptions
options)
  Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 24) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 24)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir
  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- IO (Version, Maybe ComponentId, SetupScriptOptions)
cabalLibVersionToUse
  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion
  path <-
    if useCachedSetupExecutable
      then
        getCachedSetupExecutable
          options'
          cabalLibVersion
          mCabalLibInstalledPkgId
      else
        compileSetupExecutable
          options'
          cabalLibVersion
          mCabalLibInstalledPkgId
          False

  -- Since useWorkingDir can change the relative path, the path argument must
  -- be turned into an absolute path. On some systems, runProcess' will take
  -- path as relative to the new working directory instead of the current
  -- working directory.
  path' <- tryCanonicalizePath path

  -- See 'Note: win32 clean hack' above.
#ifdef mingw32_HOST_OS
  -- setupProgFile may not exist if we're using a cached program
  setupProgFile' <- canonicalizePathNoThrow $ i setupProgFile
  let win32CleanHackNeeded =
        (useWin32CleanHack options)
          -- Skip when a cached setup script is used.
          && setupProgFile' `equalFilePath` path'
#else
  let win32CleanHackNeeded = Bool
False
#endif
  let options'' = SetupScriptOptions
options'{useWin32CleanHack = win32CleanHackNeeded}

  return (cabalLibVersion, ExternalMethod path', options'')
  where
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    setupDir :: SymbolicPathX 'AllowAbsolute Pkg c3
setupDir = SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
options SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath Dist c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"setup"
    setupVersionFile :: SymbolicPathX 'AllowAbsolute Pkg c3
setupVersionFile = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))
-> RelativePath (ZonkAny 1) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 1) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
"setup" [Char] -> [Char] -> [Char]
<.> [Char]
"version")
    setupHs :: SymbolicPathX 'AllowAbsolute Pkg c3
setupHs = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 2))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 2))
-> RelativePath (ZonkAny 2) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 2) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
"setup" [Char] -> [Char] -> [Char]
<.> [Char]
"hs")
    setupHooks :: SymbolicPathX 'AllowAbsolute Pkg c3
setupHooks = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 3))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 3))
-> RelativePath (ZonkAny 3) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 3) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
"SetupHooks" [Char] -> [Char] -> [Char]
<.> [Char]
"hs")
    setupProgFile :: SymbolicPathX 'AllowAbsolute Pkg c3
setupProgFile = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 4))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 4))
-> RelativePath (ZonkAny 4) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 4) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
"setup" [Char] -> [Char] -> [Char]
<.> Platform -> [Char]
exeExtension Platform
buildPlatform)

    platform :: Platform
platform = Platform -> Maybe Platform -> Platform
forall a. a -> Maybe a -> a
fromMaybe Platform
buildPlatform (SetupScriptOptions -> Maybe Platform
usePlatform SetupScriptOptions
options)

    useCachedSetupExecutable :: Bool
useCachedSetupExecutable =
      BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Simple Bool -> Bool -> Bool
|| BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Configure Bool -> Bool -> Bool
|| BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Make

    maybeGetInstalledPackages
      :: SetupScriptOptions
      -> Compiler
      -> ProgramDb
      -> IO InstalledPackageIndex
    maybeGetInstalledPackages :: SetupScriptOptions
-> Compiler -> ProgramDb -> IO InstalledPackageIndex
maybeGetInstalledPackages SetupScriptOptions
options' Compiler
comp ProgramDb
progdb =
      case SetupScriptOptions -> Maybe InstalledPackageIndex
usePackageIndex SetupScriptOptions
options' of
        Just InstalledPackageIndex
index -> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        Maybe InstalledPackageIndex
Nothing ->
          Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages
            Verbosity
verbosity
            Compiler
comp
            (SetupScriptOptions -> PackageDBStackCWD
usePackageDB SetupScriptOptions
options')
            ProgramDb
progdb

    -- Choose the version of Cabal to use if the setup script has a dependency on
    -- Cabal, and possibly update the setup script options. The version also
    -- determines how to filter the flags to Setup.
    --
    -- We first check whether the dependency solver has specified a Cabal version.
    -- If it has, we use the solver's version without looking at the installed
    -- package index (See issue #3436). Otherwise, we pick the Cabal version by
    -- checking 'useCabalSpecVersion', then the saved version, and finally the
    -- versions available in the index.
    --
    -- The version chosen here must match the one used in 'compileSetupExecutable'
    -- (See issue #3433).
    cabalLibVersionToUse
      :: IO
          ( Version
          , Maybe ComponentId
          , SetupScriptOptions
          )
    cabalLibVersionToUse :: IO (Version, Maybe ComponentId, SetupScriptOptions)
cabalLibVersionToUse =
      case ((ComponentId, PackageId) -> Bool)
-> [(ComponentId, PackageId)] -> Maybe (ComponentId, PackageId)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (PackageId -> Bool
isCabalPkgId (PackageId -> Bool)
-> ((ComponentId, PackageId) -> PackageId)
-> (ComponentId, PackageId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentId, PackageId) -> PackageId
forall a b. (a, b) -> b
snd) (SetupScriptOptions -> [(ComponentId, PackageId)]
useDependencies SetupScriptOptions
options) of
        Just (ComponentId
unitId, PackageId
pkgId) -> do
          let version :: Version
version = PackageId -> Version
pkgVersion PackageId
pkgId
          Version -> BuildType -> IO ()
updateSetupScript Version
version BuildType
bt
          Version -> IO ()
writeSetupVersionFile Version
version
          (Version, Maybe ComponentId, SetupScriptOptions)
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, ComponentId -> Maybe ComponentId
forall a. a -> Maybe a
Just ComponentId
unitId, SetupScriptOptions
options)
        Maybe (ComponentId, PackageId)
Nothing ->
          case SetupScriptOptions -> Maybe Version
useCabalSpecVersion SetupScriptOptions
options of
            Just Version
version -> do
              Version -> BuildType -> IO ()
updateSetupScript Version
version BuildType
bt
              Version -> IO ()
writeSetupVersionFile Version
version
              (Version, Maybe ComponentId, SetupScriptOptions)
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, Maybe ComponentId
forall a. Maybe a
Nothing, SetupScriptOptions
options)
            Maybe Version
Nothing -> do
              savedVer <- IO (Maybe Version)
savedVersion
              case savedVer of
                Just Version
version | Version
version Version -> VersionRange -> Bool
`withinRange` SetupScriptOptions -> VersionRange
useCabalVersion SetupScriptOptions
options ->
                  do
                    Version -> BuildType -> IO ()
updateSetupScript Version
version BuildType
bt
                    -- Does the previously compiled setup executable
                    -- still exist and is it up-to date?
                    useExisting <- Version -> IO Bool
canUseExistingSetup Version
version
                    if useExisting
                      then return (version, Nothing, options)
                      else installedVersion
                Maybe Version
_ -> IO (Version, Maybe ComponentId, SetupScriptOptions)
installedVersion
      where
        -- This check duplicates the checks in 'getCachedSetupExecutable' /
        -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice
        -- because the selected Cabal version may change as a result of this
        -- check.
        canUseExistingSetup :: Version -> IO Bool
        canUseExistingSetup :: Version -> IO Bool
canUseExistingSetup Version
version =
          if Bool
useCachedSetupExecutable
            then do
              (_, cachedSetupProgFile) <- SetupScriptOptions -> Version -> IO ([Char], [Char])
cachedSetupDirAndProg SetupScriptOptions
options Version
version
              doesFileExist cachedSetupProgFile
            else
              Bool -> Bool -> Bool
(&&)
                (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 13) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 13)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupProgFile [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 14) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 14)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupHs
                IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 15) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 15)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupProgFile [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 16) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 16)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupVersionFile

        writeSetupVersionFile :: Version -> IO ()
        writeSetupVersionFile :: Version -> IO ()
writeSetupVersionFile Version
version =
          [Char] -> [Char] -> IO ()
writeFile (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 12) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 12)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupVersionFile) (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
version [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

        installedVersion
          :: IO
              ( Version
              , Maybe InstalledPackageId
              , SetupScriptOptions
              )
        installedVersion :: IO (Version, Maybe ComponentId, SetupScriptOptions)
installedVersion = do
          (comp, progdb, options') <- SetupScriptOptions -> IO (Compiler, ProgramDb, SetupScriptOptions)
configureCompiler SetupScriptOptions
options
          (version, mipkgid, options'') <-
            installedCabalVersion
              options'
              comp
              progdb
          updateSetupScript version bt
          writeSetupVersionFile version
          return (version, mipkgid, options'')

        savedVersion :: IO (Maybe Version)
        savedVersion :: IO (Maybe Version)
savedVersion = do
          versionString <- [Char] -> IO [Char]
readFile (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 11) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 11)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupVersionFile) IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
          case reads versionString of
            [(Version
version, [Char]
s)] | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace [Char]
s -> Maybe Version -> IO (Maybe Version)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version)
            [(Version, [Char])]
_ -> Maybe Version -> IO (Maybe Version)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing

    -- \| Update a Setup.hs script, creating it if necessary.
    updateSetupScript :: Version -> BuildType -> IO ()
    updateSetupScript :: Version -> BuildType -> IO ()
updateSetupScript Version
_ BuildType
Custom = do
      useHs <- [Char] -> IO Bool
doesFileExist [Char]
customSetupHs
      useLhs <- doesFileExist customSetupLhs
      unless (useHs || useLhs) $
        dieWithException verbosity UpdateSetupScript
      let src = (if Bool
useHs then [Char]
customSetupHs else [Char]
customSetupLhs)
      srcNewer <- src `moreRecentFile` i setupHs
      when srcNewer $
        if useHs
          then copyFileVerbose verbosity src (i setupHs)
          else runSimplePreProcessor ppUnlit src (i setupHs) verbosity
      where
        customSetupHs :: [Char]
customSetupHs = SetupScriptOptions -> [Char]
workingDir SetupScriptOptions
options [Char] -> [Char] -> [Char]
</> [Char]
"Setup.hs"
        customSetupLhs :: [Char]
customSetupLhs = SetupScriptOptions -> [Char]
workingDir SetupScriptOptions
options [Char] -> [Char] -> [Char]
</> [Char]
"Setup.lhs"
    updateSetupScript Version
cabalLibVersion BuildType
Hooks = do

      let customSetupHooks :: [Char]
customSetupHooks = SetupScriptOptions -> [Char]
workingDir SetupScriptOptions
options [Char] -> [Char] -> [Char]
</> [Char]
"SetupHooks.hs"
      useHs <- [Char] -> IO Bool
doesFileExist [Char]
customSetupHooks
      unless (useHs) $
        die'
          verbosity
          "Using 'build-type: Hooks' but there is no SetupHooks.hs file."
      copyFileVerbose verbosity customSetupHooks (i setupHooks)
      rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion)
--      rewriteFileLBS verbosity hooksHs hooksScript
    updateSetupScript Version
cabalLibVersion BuildType
_ =
      Verbosity -> [Char] -> ByteString -> IO ()
rewriteFileLBS Verbosity
verbosity (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 10) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 10)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupHs) (Version -> ByteString
buildTypeScript Version
cabalLibVersion)

    buildTypeScript :: Version -> BS.ByteString
    buildTypeScript :: Version -> ByteString
buildTypeScript Version
cabalLibVersion = ByteString
"{-# LANGUAGE NoImplicitPrelude #-}\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> case BuildType
bt of
      BuildType
Simple -> ByteString
"import Distribution.Simple; main = defaultMain\n"
      BuildType
Configure
        | Version
cabalLibVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
3, Int
13, Int
0]
        -> ByteString
"import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"
        | Version
cabalLibVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
1, Int
3, Int
10]
        -> ByteString
"import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
        | Bool
otherwise
        -> ByteString
"import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
      BuildType
Make -> ByteString
"import Distribution.Make; main = defaultMain\n"
      BuildType
Hooks
        | Version
cabalLibVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
3, Int
13, Int
0]
        -> ByteString
"import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"
        | Bool
otherwise
        -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"buildTypeScript Hooks with Cabal < 3.13"
      BuildType
Custom -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"buildTypeScript Custom"

    installedCabalVersion
      :: SetupScriptOptions
      -> Compiler
      -> ProgramDb
      -> IO
          ( Version
          , Maybe InstalledPackageId
          , SetupScriptOptions
          )
    installedCabalVersion :: SetupScriptOptions
-> Compiler
-> ProgramDb
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
installedCabalVersion SetupScriptOptions
options' Compiler
_ ProgramDb
_
      | PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> PackageName
mkPackageName [Char]
"Cabal"
          Bool -> Bool -> Bool
&& BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Custom =
          (Version, Maybe ComponentId, SetupScriptOptions)
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageDescription
pkg, Maybe ComponentId
forall a. Maybe a
Nothing, SetupScriptOptions
options')
    installedCabalVersion SetupScriptOptions
options' Compiler
compiler ProgramDb
progdb = do
      index <- SetupScriptOptions
-> Compiler -> ProgramDb -> IO InstalledPackageIndex
maybeGetInstalledPackages SetupScriptOptions
options' Compiler
compiler ProgramDb
progdb
      let cabalDepName = [Char] -> PackageName
mkPackageName [Char]
"Cabal"
          cabalDepVersion = SetupScriptOptions -> VersionRange
useCabalVersion SetupScriptOptions
options'
          options'' = SetupScriptOptions
options'{usePackageIndex = Just index}
      case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
        [] ->
          Verbosity
-> CabalInstallException
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException
 -> IO (Version, Maybe ComponentId, SetupScriptOptions))
-> CabalInstallException
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a b. (a -> b) -> a -> b
$ PackageName -> VersionRange -> CabalInstallException
InstalledCabalVersion (PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg) (SetupScriptOptions -> VersionRange
useCabalVersion SetupScriptOptions
options)
        [(Version, [InstalledPackageInfo])]
pkgs ->
          let ipkginfo :: InstalledPackageInfo
ipkginfo = InstalledPackageInfo
-> Maybe InstalledPackageInfo -> InstalledPackageInfo
forall a. a -> Maybe a -> a
fromMaybe InstalledPackageInfo
forall {a}. a
err (Maybe InstalledPackageInfo -> InstalledPackageInfo)
-> Maybe InstalledPackageInfo -> InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall a. [a] -> Maybe a
safeHead ([InstalledPackageInfo] -> Maybe InstalledPackageInfo)
-> ([(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])]
-> Maybe InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> ([(Version, [InstalledPackageInfo])]
    -> (Version, [InstalledPackageInfo]))
-> [(Version, [InstalledPackageInfo])]
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, [InstalledPackageInfo]) -> Version)
-> [(Version, [InstalledPackageInfo])]
-> (Version, [InstalledPackageInfo])
forall a. (a -> Version) -> [a] -> a
bestVersion (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst ([(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo)
-> [(Version, [InstalledPackageInfo])]
-> Maybe InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ [(Version, [InstalledPackageInfo])]
pkgs
              err :: a
err = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Distribution.Client.installedCabalVersion: empty version list"
           in (Version, Maybe ComponentId, SetupScriptOptions)
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                ( InstalledPackageInfo -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion InstalledPackageInfo
ipkginfo
                , ComponentId -> Maybe ComponentId
forall a. a -> Maybe a
Just (ComponentId -> Maybe ComponentId)
-> (InstalledPackageInfo -> ComponentId)
-> InstalledPackageInfo
-> Maybe ComponentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> ComponentId
IPI.installedComponentId (InstalledPackageInfo -> Maybe ComponentId)
-> InstalledPackageInfo -> Maybe ComponentId
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
ipkginfo
                , SetupScriptOptions
options''
                )

    bestVersion :: (a -> Version) -> [a] -> a
    bestVersion :: forall a. (a -> Version) -> [a] -> a
bestVersion a -> Version
f = (a -> a -> Ordering) -> [a] -> a
forall a. (a -> a -> Ordering) -> [a] -> a
firstMaximumBy ((a -> (Bool, Bool, Bool, Version)) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Version -> (Bool, Bool, Bool, Version)
preference (Version -> (Bool, Bool, Bool, Version))
-> (a -> Version) -> a -> (Bool, Bool, Bool, Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Version
f))
      where
        -- Like maximumBy, but picks the first maximum element instead of the
        -- last. In general, we expect the preferred version to go first in the
        -- list. For the default case, this has the effect of choosing the version
        -- installed in the user package DB instead of the global one. See #1463.
        --
        -- Note: firstMaximumBy could be written as just
        -- `maximumBy cmp . reverse`, but the problem is that the behaviour of
        -- maximumBy is not fully specified in the case when there is not a single
        -- greatest element.
        firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a
        firstMaximumBy :: forall a. (a -> a -> Ordering) -> [a] -> a
firstMaximumBy a -> a -> Ordering
_ [] =
          [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Distribution.Client.firstMaximumBy: empty list"
        firstMaximumBy a -> a -> Ordering
cmp [a]
xs = (a -> a -> a) -> [a] -> a
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' a -> a -> a
maxBy [a]
xs
          where
            maxBy :: a -> a -> a
maxBy a
x a
y = case a -> a -> Ordering
cmp a
x a
y of Ordering
GT -> a
x; Ordering
EQ -> a
x; Ordering
LT -> a
y

        preference :: Version -> (Bool, Bool, Bool, Version)
preference Version
version =
          ( Bool
sameVersion
          , Bool
sameMajorVersion
          , Bool
stableVersion
          , Version
latestVersion
          )
          where
            sameVersion :: Bool
sameVersion = Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
cabalVersion
            sameMajorVersion :: Bool
sameMajorVersion = Version -> [Int]
majorVersion Version
version [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> [Int]
majorVersion Version
cabalVersion
            majorVersion :: Version -> [Int]
majorVersion = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
2 ([Int] -> [Int]) -> (Version -> [Int]) -> Version -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionNumbers
            stableVersion :: Bool
stableVersion = case Version -> [Int]
versionNumbers Version
version of
              (Int
_ : Int
x : [Int]
_) -> Int -> Bool
forall a. Integral a => a -> Bool
even Int
x
              [Int]
_ -> Bool
False
            latestVersion :: Version
latestVersion = Version
version

    configureCompiler
      :: SetupScriptOptions
      -> IO (Compiler, ProgramDb, SetupScriptOptions)
    configureCompiler :: SetupScriptOptions -> IO (Compiler, ProgramDb, SetupScriptOptions)
configureCompiler SetupScriptOptions
options' = do
      (comp, progdb) <- case SetupScriptOptions -> Maybe Compiler
useCompiler SetupScriptOptions
options' of
        Just Compiler
comp -> (Compiler, ProgramDb) -> IO (Compiler, ProgramDb)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Compiler
comp, SetupScriptOptions -> ProgramDb
useProgramDb SetupScriptOptions
options')
        Maybe Compiler
Nothing -> do
          (comp, _, progdb) <-
            Maybe CompilerFlavor
-> Maybe [Char]
-> Maybe [Char]
-> ProgramDb
-> Verbosity
-> IO (Compiler, Platform, ProgramDb)
configCompilerEx
              (CompilerFlavor -> Maybe CompilerFlavor
forall a. a -> Maybe a
Just CompilerFlavor
GHC)
              Maybe [Char]
forall a. Maybe a
Nothing
              Maybe [Char]
forall a. Maybe a
Nothing
              (SetupScriptOptions -> ProgramDb
useProgramDb SetupScriptOptions
options')
              Verbosity
verbosity
          return (comp, progdb)
      -- Whenever we need to call configureCompiler, we also need to access the
      -- package index, so let's cache it in SetupScriptOptions.
      index <- maybeGetInstalledPackages options' comp progdb
      return
        ( comp
        , progdb
        , options'
            { useCompiler = Just comp
            , usePackageIndex = Just index
            , useProgramDb = progdb
            }
        )

    -- \| Path to the setup exe cache directory and path to the cached setup
    -- executable.
    cachedSetupDirAndProg
      :: SetupScriptOptions
      -> Version
      -> IO (FilePath, FilePath)
    cachedSetupDirAndProg :: SetupScriptOptions -> Version -> IO ([Char], [Char])
cachedSetupDirAndProg SetupScriptOptions
options' Version
cabalLibVersion = do
      cacheDir <- IO [Char]
defaultCacheDir
      let setupCacheDir = [Char]
cacheDir [Char] -> [Char] -> [Char]
</> [Char]
"setup-exe-cache"
          cachedSetupProgFile =
            [Char]
setupCacheDir
              [Char] -> [Char] -> [Char]
</> ( [Char]
"setup-"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
buildTypeString
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cabalVersionString
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
platformString
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
compilerVersionString
                  )
              [Char] -> [Char] -> [Char]
<.> Platform -> [Char]
exeExtension Platform
buildPlatform
      return (setupCacheDir, cachedSetupProgFile)
      where
        buildTypeString :: [Char]
buildTypeString = BuildType -> [Char]
forall a. Show a => a -> [Char]
show BuildType
bt
        cabalVersionString :: [Char]
cabalVersionString = [Char]
"Cabal-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
cabalLibVersion
        compilerVersionString :: [Char]
compilerVersionString =
          CompilerId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (CompilerId -> [Char]) -> CompilerId -> [Char]
forall a b. (a -> b) -> a -> b
$
            CompilerId
-> (Compiler -> CompilerId) -> Maybe Compiler -> CompilerId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CompilerId
buildCompilerId Compiler -> CompilerId
compilerId (Maybe Compiler -> CompilerId) -> Maybe Compiler -> CompilerId
forall a b. (a -> b) -> a -> b
$
              SetupScriptOptions -> Maybe Compiler
useCompiler SetupScriptOptions
options'
        platformString :: [Char]
platformString = Platform -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Platform
platform

    -- \| Look up the setup executable in the cache; update the cache if the setup
    -- executable is not found.
    getCachedSetupExecutable
      :: SetupScriptOptions
      -> Version
      -> Maybe InstalledPackageId
      -> IO FilePath
    getCachedSetupExecutable :: SetupScriptOptions -> Version -> Maybe ComponentId -> IO [Char]
getCachedSetupExecutable
      SetupScriptOptions
options'
      Version
cabalLibVersion
      Maybe ComponentId
maybeCabalLibInstalledPkgId = do
        (setupCacheDir, cachedSetupProgFile) <-
          SetupScriptOptions -> Version -> IO ([Char], [Char])
cachedSetupDirAndProg SetupScriptOptions
options' Version
cabalLibVersion
        cachedSetupExists <- doesFileExist cachedSetupProgFile
        if cachedSetupExists
          then
            debug verbosity $
              "Found cached setup executable: " ++ cachedSetupProgFile
          else criticalSection' $ do
            -- The cache may have been populated while we were waiting.
            cachedSetupExists' <- doesFileExist cachedSetupProgFile
            if cachedSetupExists'
              then
                debug verbosity $
                  "Found cached setup executable: " ++ cachedSetupProgFile
              else do
                debug verbosity $ "Setup executable not found in the cache."
                src <-
                  compileSetupExecutable
                    options'
                    cabalLibVersion
                    maybeCabalLibInstalledPkgId
                    True
                createDirectoryIfMissingVerbose verbosity True setupCacheDir
                installExecutableFile verbosity src cachedSetupProgFile
                -- Do not strip if we're using GHCJS, since the result may be a script
                when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do
                  -- Add the relevant PATH overrides for the package to the
                  -- program database.
                  setupProgDb
                    <- prependProgramSearchPath verbosity
                          (useExtraPathEnv options)
                          (useExtraEnvOverrides options)
                          (useProgramDb options')
                         >>= configureAllKnownPrograms verbosity
                  Strip.stripExe
                    verbosity
                    platform
                    setupProgDb
                    cachedSetupProgFile
        return cachedSetupProgFile
        where
          criticalSection' :: IO a -> IO a
criticalSection' = (IO a -> IO a)
-> (Lock -> IO a -> IO a) -> Maybe Lock -> IO a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a -> IO a
forall a. a -> a
id Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
criticalSection (Maybe Lock -> IO a -> IO a) -> Maybe Lock -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ SetupScriptOptions -> Maybe Lock
setupCacheLock SetupScriptOptions
options'

    -- \| If the Setup.hs is out of date wrt the executable then recompile it.
    -- Currently this is GHC/GHCJS only. It should really be generalised.
    compileSetupExecutable
      :: SetupScriptOptions
      -> Version
      -> Maybe ComponentId
      -> Bool
      -> IO FilePath
    compileSetupExecutable :: SetupScriptOptions
-> Version -> Maybe ComponentId -> Bool -> IO [Char]
compileSetupExecutable
      SetupScriptOptions
options'
      Version
cabalLibVersion
      Maybe ComponentId
maybeCabalLibInstalledPkgId
      Bool
forceCompile = do
        setupHsNewer <- SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 17) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 17)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupHs [Char] -> [Char] -> IO Bool
`moreRecentFile` SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 18) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 18)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupProgFile
        cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile
        let outOfDate = Bool
setupHsNewer Bool -> Bool -> Bool
|| Bool
cabalVersionNewer
        when (outOfDate || forceCompile) $ do
          debug verbosity "Setup executable needs to be updated, compiling..."
          (compiler, progdb, options'') <- configureCompiler options'
          pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))
          let cabalPkgid = PackageName -> Version -> PackageId
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"Cabal") Version
cabalLibVersion
              (program, extraOpts) =
                case compilerFlavor compiler of
                  CompilerFlavor
GHCJS -> (Program
ghcjsProgram, [[Char]
"-build-runner"])
                  CompilerFlavor
_ -> (Program
ghcProgram, [[Char]
"-threaded"])
              cabalDep =
                [(ComponentId, PackageId)]
-> (ComponentId -> [(ComponentId, PackageId)])
-> Maybe ComponentId
-> [(ComponentId, PackageId)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  []
                  (\ComponentId
ipkgid -> [(ComponentId
ipkgid, PackageId
cabalPkgid)])
                  Maybe ComponentId
maybeCabalLibInstalledPkgId

              -- With 'useDependenciesExclusive' and Custom build type,
              -- we enforce the deps specified, so only the given ones can be used.
              -- Otherwise we add on a dep on the Cabal library
              -- (unless 'useDependencies' already contains one).
              selectedDeps
                |  (SetupScriptOptions -> Bool
useDependenciesExclusive SetupScriptOptions
options' Bool -> Bool -> Bool
&& (BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
/= BuildType
Hooks))
                -- NB: to compile build-type: Hooks packages, we need Cabal
                -- in order to compile @main = defaultMainWithSetupHooks setupHooks@.
                Bool -> Bool -> Bool
|| ((ComponentId, PackageId) -> Bool)
-> [(ComponentId, PackageId)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PackageId -> Bool
isCabalPkgId (PackageId -> Bool)
-> ((ComponentId, PackageId) -> PackageId)
-> (ComponentId, PackageId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentId, PackageId) -> PackageId
forall a b. (a, b) -> b
snd) (SetupScriptOptions -> [(ComponentId, PackageId)]
useDependencies SetupScriptOptions
options')
                = SetupScriptOptions -> [(ComponentId, PackageId)]
useDependencies SetupScriptOptions
options'
                | Bool
otherwise =
                    SetupScriptOptions -> [(ComponentId, PackageId)]
useDependencies SetupScriptOptions
options' [(ComponentId, PackageId)]
-> [(ComponentId, PackageId)] -> [(ComponentId, PackageId)]
forall a. [a] -> [a] -> [a]
++ [(ComponentId, PackageId)]
cabalDep
              addRenaming (ComponentId
ipid, b
_) =
                -- Assert 'DefUnitId' invariant
                ( DefUnitId -> OpenUnitId
Backpack.DefiniteUnitId (UnitId -> DefUnitId
unsafeMkDefUnitId (ComponentId -> UnitId
newSimpleUnitId ComponentId
ipid))
                , ModuleRenaming
defaultRenaming
                )
              cppMacrosFile = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 21))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
setupDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 21))
-> RelativePath (ZonkAny 21) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 21) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"setup_macros.h"
              ghcOptions =
                GhcOptions
forall a. Monoid a => a
mempty
                  { -- Respect -v0, but don't crank up verbosity on GHC if
                    -- Cabal verbosity is requested. For that, use
                    -- --ghc-option=-v instead!
                    ghcOptVerbosity = Flag (min verbosity normal)
                  , ghcOptMode = Flag GhcModeMake
                  , ghcOptInputFiles = toNubListR [setupHs]
                  , ghcOptOutputFile = Flag $ setupProgFile
                  , ghcOptObjDir = Flag $ setupDir
                  , ghcOptHiDir = Flag $ setupDir
                  , ghcOptSourcePathClear = Flag True
                  , ghcOptSourcePath = case bt of
                      BuildType
Custom -> [SymbolicPath Pkg ('Dir Source)]
-> NubListR (SymbolicPath Pkg ('Dir Source))
forall a. Ord a => [a] -> NubListR a
toNubListR [SymbolicPath Pkg ('Dir Source)
forall (allowAbsolute :: AllowAbsolute) from to.
SymbolicPathX allowAbsolute from ('Dir to)
sameDirectory]
                      BuildType
Hooks -> [SymbolicPath Pkg ('Dir Source)]
-> NubListR (SymbolicPath Pkg ('Dir Source))
forall a. Ord a => [a] -> NubListR a
toNubListR [SymbolicPath Pkg ('Dir Source)
forall (allowAbsolute :: AllowAbsolute) from to.
SymbolicPathX allowAbsolute from ('Dir to)
sameDirectory]
                      BuildType
_ -> NubListR (SymbolicPath Pkg ('Dir Source))
forall a. Monoid a => a
mempty
                  , ghcOptPackageDBs = pkgDbs
                  , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
                  , ghcOptCabal = Flag (useDependenciesExclusive options')
                  , ghcOptPackages = toNubListR $ map addRenaming selectedDeps
                  -- With 'useVersionMacros', use a version CPP macros .h file.
                  , ghcOptCppIncludes =
                      toNubListR
                        [ cppMacrosFile
                        | useVersionMacros options'
                        ]
                  , ghcOptExtra = extraOpts
                  , ghcOptExtensions = toNubListR $
                      if bt == Custom || any (isBasePkgId . snd) selectedDeps
                      then []
                      else [ Simple.DisableExtension Simple.ImplicitPrelude ]
                        -- Pass -WNoImplicitPrelude to avoid depending on base
                        -- when compiling a Simple Setup.hs file.
                  , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler
                  }
          let ghcCmdLine = Compiler -> Platform -> GhcOptions -> [[Char]]
renderGhcOptions Compiler
compiler Platform
platform GhcOptions
ghcOptions
          when (useVersionMacros options') $
            rewriteFileEx verbosity (i cppMacrosFile) $
              generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)
          case useLoggingHandle options of
            Maybe Handle
Nothing -> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [[Char]]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [[Char]]
-> IO ()
runDbProgramCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir Program
program ProgramDb
progdb [[Char]]
ghcCmdLine
            -- If build logging is enabled, redirect compiler output to
            -- the log file.
            Just Handle
logHandle -> do
              output <-
                Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [[Char]]
-> IO [Char]
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [[Char]]
-> IO [Char]
getDbProgramOutputCwd
                  Verbosity
verbosity
                  Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
                  Program
program
                  ProgramDb
progdb
                  [[Char]]
ghcCmdLine
              hPutStr logHandle output
        return $ i setupProgFile

isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool
isCabalPkgId :: PackageId -> Bool
isCabalPkgId (PackageIdentifier PackageName
pname Version
_) = PackageName
pname PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> PackageName
mkPackageName [Char]
"Cabal"
isBasePkgId :: PackageId -> Bool
isBasePkgId (PackageIdentifier PackageName
pname Version
_) = PackageName
pname PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> PackageName
mkPackageName [Char]
"base"