{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{- 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
  ( SetupRunnerArgs(..)
  , SPostConfigurePhase(..)
  , InLibraryArgs(..)
  , SetupRunnerRes
  , InLibraryLBI(..)
  , RightFlagsForPhase
  , setupWrapper
  , SetupScriptOptions (..)
  , defaultSetupScriptOptions
  , externalSetupMethod
  ) where

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

import qualified Distribution.Backpack as Backpack
import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)
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
  ( exeExtension
  )
import Distribution.Simple.Compiler
import Distribution.Simple.Configure
  hiding ( getInstalledPackages )
import Distribution.Simple.PackageDescription
  ( readGenericPackageDescription
  )
import Distribution.Simple.PreProcess
  ( ppUnlit
  , runSimplePreProcessor
  )
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
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.FileMonitor
  ( MonitorFilePath )
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
  )
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.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.Simple.Setup
import Distribution.Compat.Process (proc)
import Distribution.System (Platform (..), buildPlatform)
import Distribution.Utils.NubList
  ( toNubListR
  )
import Distribution.Types.LocalBuildInfo ( LocalBuildInfo )
import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Verbosity
import Distribution.Client.Errors
import qualified Distribution.Client.InLibrary as InLibrary
import Distribution.Client.ProjectPlanning.Types
import Distribution.Simple.SetupHooks.HooksMain
  ( hooksVersion )
import Distribution.Client.SetupHooks.CallHooksExe
  ( externalSetupHooksABI, hooksProgFilePath )

import Control.Concurrent.STM (TVar, readTVarIO)
import qualified Data.ByteString.Lazy as BS
import Data.List (foldl1')
import Data.Kind (Type, Constraint)
import qualified Data.Map.Lazy as Map
import Data.Type.Equality  ( type (==) )
import Data.Type.Bool      ( If )
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import Data.Functor ((<&>))
import System.IO (Handle, hPutStr)
import System.Process (StdStream (..))
import qualified System.Process as Process

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

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

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

data AllowInLibrary
  = AllowInLibrary
  | Don'tAllowInLibrary
  deriving AllowInLibrary -> AllowInLibrary -> Bool
(AllowInLibrary -> AllowInLibrary -> Bool)
-> (AllowInLibrary -> AllowInLibrary -> Bool) -> Eq AllowInLibrary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AllowInLibrary -> AllowInLibrary -> Bool
== :: AllowInLibrary -> AllowInLibrary -> Bool
$c/= :: AllowInLibrary -> AllowInLibrary -> Bool
/= :: AllowInLibrary -> AllowInLibrary -> Bool
Eq

data SetupKind
  = InLibrary
  | GeneralSetup

-- | If we end up using the in-library method, we use the v'InLibraryLBI'
-- constructor. If not, we use the 'NotInLibraryNoLBI' constructor.
--
-- NB: we don't know ahead of time whether we can use the in-library method;
-- e.g. for a package with Hooks build-type, it depends on whether the Cabal
-- version used by the package matches with the Cabal version that cabal-install
-- was built against.
data InLibraryLBI
  = InLibraryLBI LocalBuildInfo
  | NotInLibraryNoLBI

data SPostConfigurePhase (flags :: Type) where
  SBuildPhase    :: SPostConfigurePhase BuildFlags
  SHaddockPhase  :: SPostConfigurePhase HaddockFlags
  SReplPhase     :: SPostConfigurePhase ReplFlags
  SCopyPhase     :: SPostConfigurePhase CopyFlags
  SRegisterPhase :: SPostConfigurePhase RegisterFlags
  STestPhase     :: SPostConfigurePhase TestFlags
  SBenchPhase    :: SPostConfigurePhase BenchmarkFlags

data SetupWrapperSpec
  = TryInLibrary Type
  | UseGeneralSetup

type family RightFlagsForPhase (flags :: Type) (setupSpec :: SetupWrapperSpec) :: Constraint where
  RightFlagsForPhase flags UseGeneralSetup = ()
  RightFlagsForPhase flags (TryInLibrary flags') = flags ~ flags'

data SetupRunnerArgs (spec :: SetupWrapperSpec) where
  NotInLibrary
    :: SetupRunnerArgs UseGeneralSetup
  InLibraryArgs
    :: InLibraryArgs flags
    -> SetupRunnerArgs (TryInLibrary flags)

data InLibraryArgs (flags :: Type) where
  InLibraryConfigureArgs
    :: ElaboratedSharedConfig
    -> ElaboratedReadyPackage
    -> TVar InstalledPackageIndex
    -> InLibraryArgs ConfigFlags
  InLibraryPostConfigureArgs
    :: SPostConfigurePhase flags
    -> InLibraryLBI
    -> InLibraryArgs flags

type family SetupRunnerRes (spec :: SetupWrapperSpec) where
  SetupRunnerRes UseGeneralSetup = ()
  SetupRunnerRes (TryInLibrary phase) = InLibraryPhaseRes phase

type family InLibraryPhaseRes flags where
  InLibraryPhaseRes ConfigFlags  = InLibraryLBI
  InLibraryPhaseRes BuildFlags   = [MonitorFilePath]
  InLibraryPhaseRes HaddockFlags = [MonitorFilePath]
  InLibraryPhaseRes ReplFlags    = [MonitorFilePath]
  InLibraryPhaseRes _            = ()

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

data ASetup = forall kind. ASetup ( Setup kind )

-- | @SetupMethod@ represents one of the methods used to run Cabal commands.
data SetupMethod (kind :: SetupKind) where
  -- | Directly use Cabal library functions, bypassing the Setup
  -- mechanism entirely.
    LibraryMethod :: SetupMethod InLibrary
  -- | run Cabal commands through a custom \"Setup\" executable
    ExternalMethod :: FilePath -> SetupMethod GeneralSetup

-- 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 avoids 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 -> [(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
    -- and Configure 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
    , 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 kind =
  Verbosity
  -> SetupScriptOptions
  -> BuildType
  -> [String]
  -> SetupRunnerArgs kind
  -> IO (SetupRunnerRes kind)

-- | 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
  -> AllowInLibrary
  -> IO ASetup
getSetup :: Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> AllowInLibrary
-> IO ASetup
getSetup Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg AllowInLibrary
allowInLibrary = 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
  withSetupMethod verbosity options' pkg buildType' allowInLibrary $
    \ (Version
version, SetupMethod kind
method, SetupScriptOptions
options'') ->
        Setup kind -> ASetup
forall (kind :: SetupKind). Setup kind -> ASetup
ASetup (Setup kind -> ASetup) -> Setup kind -> ASetup
forall a b. (a -> b) -> a -> b
$ Setup
          { setupMethod :: SetupMethod kind
setupMethod = SetupMethod kind
method
          , setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
options''
          , setupVersion :: Version
setupVersion = Version
version
          , setupBuildType :: BuildType
setupBuildType = BuildType
buildType'
          , setupPackage :: PackageDescription
setupPackage = PackageDescription
pkg
          }
  where
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options
    getPkg :: IO PackageDescription
getPkg =
      (Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir IO (RelativePath Pkg 'File)
-> (RelativePath 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
>>= Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (SymbolicPath Pkg 'File -> IO GenericPackageDescription)
-> (RelativePath Pkg 'File -> SymbolicPath Pkg 'File)
-> RelativePath Pkg 'File
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath)
        IO GenericPackageDescription
-> (GenericPackageDescription -> PackageDescription)
-> IO PackageDescription
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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.
withSetupMethod
  :: Verbosity
  -> SetupScriptOptions
  -> PackageDescription
  -> BuildType
  -> AllowInLibrary
  -> ( forall kind. (Version, SetupMethod kind, SetupScriptOptions ) -> r )
  -> IO r
withSetupMethod :: forall r.
Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> AllowInLibrary
-> (forall (kind :: SetupKind).
    (Version, SetupMethod kind, SetupScriptOptions) -> r)
-> IO r
withSetupMethod Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
buildType' AllowInLibrary
allowInLibrary forall (kind :: SetupKind).
(Version, SetupMethod kind, SetupScriptOptions) -> r
with
  | BuildType
buildType' BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Custom
      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)
      Bool -> Bool -> Bool
|| AllowInLibrary
allowInLibrary AllowInLibrary -> AllowInLibrary -> Bool
forall a. Eq a => a -> a -> Bool
== AllowInLibrary
Don'tAllowInLibrary
      Bool -> Bool -> Bool
|| (BuildType
buildType' BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Hooks Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasHooksMain) =
      IO r
withExternalSetupMethod
  | BuildType
buildType' BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Hooks = do
      -- NB: needs 'hooksMain' available in Cabal to compile the external
      -- hooks executable, hence the 'not hasHooksMain' guard above.
      Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> WantedExternalExe 'HooksExe
-> IO
     (If
        ('HooksExe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> WantedExternalExe exe
-> IO
     (If
        (exe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
compileExternalExe Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
buildType' WantedExternalExe 'HooksExe
WantHooks
      externalHooksABI <-
        Verbosity -> [Char] -> IO HooksVersion
externalSetupHooksABI Verbosity
verbosity ([Char] -> IO HooksVersion) -> [Char] -> IO HooksVersion
forall a b. (a -> b) -> a -> b
$
          Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist) -> [Char]
hooksProgFilePath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options) (SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
options)
      let internalHooksABI = HooksVersion
hooksVersion
      if externalHooksABI == internalHooksABI
        then do
          debug verbosity "Using in-library setup method with build-type Hooks."
          return $ with (cabalVersion, LibraryMethod, options)
        else do
          debug verbosity "Hooks ABI mismatch; falling back to external setup method."
          withExternalSetupMethod
  | Bool
otherwise = do
      Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Using in-library setup method with build-type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuildType -> [Char]
forall a. Show a => a -> [Char]
show BuildType
buildType'
      r -> IO r
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> IO r) -> r -> IO r
forall a b. (a -> b) -> a -> b
$ (Version, SetupMethod 'InLibrary, SetupScriptOptions) -> r
forall (kind :: SetupKind).
(Version, SetupMethod kind, SetupScriptOptions) -> r
with (Version
cabalVersion, SetupMethod 'InLibrary
LibraryMethod, SetupScriptOptions
options)
  where
    hasHooksMain :: Bool
hasHooksMain =
      case SetupScriptOptions -> Maybe (Version, Maybe ComponentId)
cabalLibFromOptions SetupScriptOptions
options of
        Just (Version
v, Maybe ComponentId
_) -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
3, Int
17]
        Maybe (Version, Maybe ComponentId)
Nothing     -> Bool
False
    withExternalSetupMethod :: IO r
withExternalSetupMethod = 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
buildType'
      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)
      (Version, SetupMethod 'GeneralSetup, SetupScriptOptions) -> r
forall (kind :: SetupKind).
(Version, SetupMethod kind, SetupScriptOptions) -> r
with ((Version, SetupMethod 'GeneralSetup, SetupScriptOptions) -> r)
-> IO (Version, SetupMethod 'GeneralSetup, SetupScriptOptions)
-> IO r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> WantedExternalExe 'SetupExe
-> IO
     (If
        ('SetupExe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> WantedExternalExe exe
-> IO
     (If
        (exe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
compileExternalExe Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
buildType' WantedExternalExe 'SetupExe
WantSetup

runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup)
runSetupMethod :: WithCallStack
  (SetupMethod 'GeneralSetup -> SetupRunner 'UseGeneralSetup)
runSetupMethod (ExternalMethod [Char]
path) = WithCallStack ([Char] -> SetupRunner 'UseGeneralSetup)
[Char] -> SetupRunner 'UseGeneralSetup
externalSetupMethod [Char]
path

-- | Run a configured 'Setup' with specific arguments.
runSetup
  :: Verbosity
  -> Setup GeneralSetup
  -> [String]
  -- ^ command-line arguments
  -> SetupRunnerArgs UseGeneralSetup
  -> IO (SetupRunnerRes UseGeneralSetup)
runSetup :: Verbosity
-> Setup 'GeneralSetup
-> [[Char]]
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
runSetup Verbosity
verbosity Setup 'GeneralSetup
setup [[Char]]
args0 SetupRunnerArgs 'UseGeneralSetup
setupArgs = do
  let method :: SetupMethod 'GeneralSetup
method = Setup 'GeneralSetup -> SetupMethod 'GeneralSetup
forall (kind :: SetupKind). Setup kind -> SetupMethod kind
setupMethod Setup 'GeneralSetup
setup
      options :: SetupScriptOptions
options = Setup 'GeneralSetup -> SetupScriptOptions
forall (kind :: SetupKind). Setup kind -> SetupScriptOptions
setupScriptOptions Setup 'GeneralSetup
setup
      bt :: BuildType
bt = Setup 'GeneralSetup -> BuildType
forall (kind :: SetupKind). Setup kind -> BuildType
setupBuildType Setup 'GeneralSetup
setup
      args :: [[Char]]
args = Version -> [[Char]] -> [[Char]]
verbosityHack (Setup 'GeneralSetup -> Version
forall (kind :: SetupKind). Setup kind -> Version
setupVersion Setup 'GeneralSetup
setup) [[Char]]
args0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
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
verbosity { verbosityFlags = 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 'GeneralSetup -> SetupRunner 'UseGeneralSetup)
SetupMethod 'GeneralSetup -> SetupRunner 'UseGeneralSetup
runSetupMethod SetupMethod 'GeneralSetup
method Verbosity
verbosity SetupScriptOptions
options BuildType
bt [[Char]]
args SetupRunnerArgs 'UseGeneralSetup
setupArgs

-- | 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 VerbosityFlags -> [Char] -> Either [Char] VerbosityFlags
forall a. ReadE a -> [Char] -> Either [Char] a
runReadE ReadE VerbosityFlags
flagToVerbosity [Char]
rest of
        Right VerbosityFlags
v
          | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0]
          , VerbosityFlags -> Bool
verboseHasFlags VerbosityFlags
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 (VerbosityFlags -> [Char]
showForCabal (VerbosityFlags -> VerbosityFlags
verboseNoFlags VerbosityFlags
v))
          | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
1]
          , VerbosityFlags -> Bool
isVerboseTimestamp VerbosityFlags
v ->
              -- +timestamp wasn't yet available in Cabal-2.0.0
              [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (VerbosityFlags -> [Char]
showForCabal (VerbosityFlags -> VerbosityFlags
verboseNoTimestamp VerbosityFlags
v))
        Either [Char] VerbosityFlags
_ -> Maybe [Char]
forall a. Maybe a
Nothing

-- | Run a command through a configured 'Setup'.
runSetupCommand
  :: Verbosity
  -> Setup GeneralSetup
  -> CommandUI flags
  -- ^ command definition
  -> (flags -> CommonSetupFlags)
  -> flags
  -- ^ command flags
  -> [String]
  -- ^ extra command-line arguments
  -> SetupRunnerArgs UseGeneralSetup
  -> IO (SetupRunnerRes UseGeneralSetup)
runSetupCommand :: forall flags.
Verbosity
-> Setup 'GeneralSetup
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> flags
-> [[Char]]
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
runSetupCommand Verbosity
verbosity Setup 'GeneralSetup
setup CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags flags
flags [[Char]]
extraArgs SetupRunnerArgs 'UseGeneralSetup
setupArgs =
  -- 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 7)] -> 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 'GeneralSetup
-> [[Char]]
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
runSetup Verbosity
verbosity Setup 'GeneralSetup
setup [[Char]]
args SetupRunnerArgs 'UseGeneralSetup
setupArgs

-- | Configure a 'Setup' and run a command in one step. The command flags
-- may depend on the Cabal library version in use.
setupWrapper
  :: forall setupSpec flags
  .  RightFlagsForPhase flags setupSpec
  => Verbosity
  -> SetupScriptOptions
  -> Maybe PackageDescription
  -> CommandUI flags
  -> (flags -> CommonSetupFlags)
  -> (Version -> IO flags)
  -- ^ produce command flags given the Cabal library version
  -> (Version -> [String])
  -> SetupRunnerArgs setupSpec
  -> IO (SetupRunnerRes setupSpec)
setupWrapper :: forall (setupSpec :: SetupWrapperSpec) flags.
RightFlagsForPhase flags setupSpec =>
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [[Char]])
-> SetupRunnerArgs setupSpec
-> IO (SetupRunnerRes setupSpec)
setupWrapper Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags Version -> IO flags
getFlags Version -> [[Char]]
getExtraArgs SetupRunnerArgs setupSpec
wrapperArgs = do
  let allowInLibrary :: AllowInLibrary
allowInLibrary = case SetupRunnerArgs setupSpec
wrapperArgs of
        InLibraryArgs {} -> AllowInLibrary
AllowInLibrary
        SetupRunnerArgs setupSpec
NotInLibrary -> AllowInLibrary
Don'tAllowInLibrary
  ASetup (setup :: Setup kind) <- Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> AllowInLibrary
-> IO ASetup
getSetup Verbosity
verbosity SetupScriptOptions
options Maybe PackageDescription
mpkg AllowInLibrary
allowInLibrary
  let version = Setup kind -> Version
forall (kind :: SetupKind). Setup kind -> Version
setupVersion Setup kind
setup
  flags <- getFlags version
  let
    verbHandles = Verbosity -> VerbosityHandles
verbosityHandles Verbosity
verbosity
    extraArgs = Version -> [[Char]]
getExtraArgs Version
version
    notInLibraryMethod :: kind ~ GeneralSetup => IO (SetupRunnerRes setupSpec)
    notInLibraryMethod = do
      Verbosity
-> Setup 'GeneralSetup
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> flags
-> [[Char]]
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
forall flags.
Verbosity
-> Setup 'GeneralSetup
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> flags
-> [[Char]]
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
runSetupCommand Verbosity
verbosity Setup kind
Setup 'GeneralSetup
setup CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags flags
flags [[Char]]
extraArgs SetupRunnerArgs 'UseGeneralSetup
NotInLibrary
      SetupRunnerRes setupSpec -> IO (SetupRunnerRes setupSpec)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SetupRunnerRes setupSpec -> IO (SetupRunnerRes setupSpec))
-> SetupRunnerRes setupSpec -> IO (SetupRunnerRes setupSpec)
forall a b. (a -> b) -> a -> b
$ case SetupRunnerArgs setupSpec
wrapperArgs of
       SetupRunnerArgs setupSpec
NotInLibrary -> ()
       InLibraryArgs InLibraryArgs flags
libArgs ->
         case InLibraryArgs flags
libArgs of
           InLibraryConfigureArgs {} -> InLibraryLBI
SetupRunnerRes setupSpec
NotInLibraryNoLBI
           InLibraryPostConfigureArgs SPostConfigurePhase flags
sPhase InLibraryLBI
_ ->
             case SPostConfigurePhase flags
sPhase of
               SPostConfigurePhase flags
SBuildPhase    -> []
               SPostConfigurePhase flags
SHaddockPhase  -> []
               SPostConfigurePhase flags
SReplPhase     -> []
               SPostConfigurePhase flags
SCopyPhase     -> ()
               SPostConfigurePhase flags
SRegisterPhase -> ()
               SPostConfigurePhase flags
STestPhase     -> ()
               SPostConfigurePhase flags
SBenchPhase    -> ()
  case setupMethod setup of
    SetupMethod kind
LibraryMethod ->
      case SetupRunnerArgs setupSpec
wrapperArgs of
        InLibraryArgs InLibraryArgs flags
libArgs ->
          case InLibraryArgs flags
libArgs of
            InLibraryConfigureArgs ElaboratedSharedConfig
elabSharedConfig ElaboratedReadyPackage
elabReadyPkg TVar InstalledPackageIndex
ipiTVar -> do
              -- Start from the pre-configured compiler ProgramDb, augmented
              -- with all builtin programs (restored as unconfigured).
              -- This ensures:
              --   (a) configureAllKnownPrograms inside configureFinal skips
              --       compiler programs (already configured at project level),
              --   (b) builtin preprocessors like alex and happy are present as
              --       unconfigured programs, so configureFinal's
              --       configureAllKnownPrograms can find them using the
              --       per-package search path (respecting extra-prog-path).
              -- See (1) in Note [Constructing the ProgramDb].

              -- Apply per-package user-supplied program args/paths.
              -- See (2)(a) in Note [Constructing the ProgramDb]
              baseProgDb <-
                -- Use 'mkProgramDb' to pass user-supplied per-package
                -- program options (--PROG-options=...).
                VerbosityHandles -> ConfigFlags -> ProgramDb -> IO ProgramDb
mkProgramDb VerbosityHandles
verbHandles flags
ConfigFlags
flags
                  ([Program] -> ProgramDb -> ProgramDb
restoreProgramDb [Program]
builtinPrograms (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
                    ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs ElaboratedSharedConfig
elabSharedConfig)
              setupProgDb <-
                prependProgramSearchPath verbosity
                  (useExtraPathEnv options)
                  (useExtraEnvOverrides options)
                  baseProgDb
              -- Read the project InstalledPackageIndex to avoid needing to query
              -- @ghc-pkg@ to obtain it.
              -- in Distribution.Client.ProjectBuilding.
              ipi <- readTVarIO ipiTVar
              lbi0 <-
                InLibrary.configure
                  (InLibrary.libraryConfigureInputsFromElabPackage
                     verbHandles
                     (setupBuildType setup)
                     setupProgDb
                     elabSharedConfig
                     elabReadyPkg
                     ipi
                     extraArgs
                  )
                  flags
              let progs0 = LocalBuildInfo -> ProgramDb
LBI.withPrograms LocalBuildInfo
lbi0
              -- See (2)(b) in Note [Constructing the ProgramDb]
              progs1 <- updatePathProgDb verbosity progs0
              let
                  lbi =
                    LocalBuildInfo
lbi0
                      { LBI.withPrograms = progs1
                      }
                  mbWorkDir = SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options
                  distPref = SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
options
              -- Write the LocalBuildInfo to disk. This is needed, for instance, if we
              -- skip re-configuring; we retrieve the LocalBuildInfo stored on disk from
              -- the previous invocation of 'configure' and pass it to 'build'.
              writePersistBuildConfig mbWorkDir distPref lbi
              return (InLibraryLBI lbi)
            InLibraryPostConfigureArgs SPostConfigurePhase flags
sPhase InLibraryLBI
mbLBI ->
              case InLibraryLBI
mbLBI of
                InLibraryLBI
NotInLibraryNoLBI ->
                  [Char] -> IO (SetupRunnerRes setupSpec)
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: in-library post-conf but no LBI"
                  -- To avoid running into the above error, we must ensure that
                  -- when we skip re-configuring, we retrieve the cached
                  -- LocalBuildInfo (see "whenReconfigure"
                  --   in Distribution.Client.ProjectBuilding.UnpackedPackage).
                InLibraryLBI LocalBuildInfo
lbi ->
                  case SPostConfigurePhase flags
sPhase of
                    SPostConfigurePhase flags
SBuildPhase    -> VerbosityHandles
-> BuildFlags -> LocalBuildInfo -> [[Char]] -> IO [MonitorFilePath]
InLibrary.build    VerbosityHandles
verbHandles flags
BuildFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
SHaddockPhase  -> VerbosityHandles
-> HaddockFlags
-> LocalBuildInfo
-> [[Char]]
-> IO [MonitorFilePath]
InLibrary.haddock  VerbosityHandles
verbHandles flags
HaddockFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
SReplPhase     -> VerbosityHandles
-> ReplFlags -> LocalBuildInfo -> [[Char]] -> IO [MonitorFilePath]
InLibrary.repl     VerbosityHandles
verbHandles flags
ReplFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
SCopyPhase     -> VerbosityHandles
-> CopyFlags -> LocalBuildInfo -> [[Char]] -> IO ()
InLibrary.copy     VerbosityHandles
verbHandles flags
CopyFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
STestPhase     -> VerbosityHandles
-> TestFlags -> LocalBuildInfo -> [[Char]] -> IO ()
InLibrary.test     VerbosityHandles
verbHandles flags
TestFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
SBenchPhase    -> VerbosityHandles
-> BenchmarkFlags -> LocalBuildInfo -> [[Char]] -> IO ()
InLibrary.bench    VerbosityHandles
verbHandles flags
BenchmarkFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
                    SPostConfigurePhase flags
SRegisterPhase -> RegisterFlags -> LocalBuildInfo -> [[Char]] -> IO ()
InLibrary.register             flags
RegisterFlags
flags LocalBuildInfo
lbi [[Char]]
extraArgs
        SetupRunnerArgs setupSpec
NotInLibrary ->
          [Char] -> IO (SetupRunnerRes setupSpec)
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: NotInLibrary argument but getSetup chose InLibrary"
    ExternalMethod {} -> IO (SetupRunnerRes setupSpec)
(kind ~ 'GeneralSetup) => IO (SetupRunnerRes setupSpec)
notInLibraryMethod

{- Note [Constructing the ProgramDb]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When using the in-library method for configuring a package, we want to start off
with the information cabal-install already has in hand, such as the compiler.
Specifically, we skip 'Cabal.Distribution.Simple.preConfigurePackage', which
includes the call to 'configCompilerEx'.

To obtain a program database with all the required information, we do a few
things:

  (1) We retrieve the pre-configured compiler program database (typically
      containing ghc, ghc-pkg, haddock, and toolchain programs such as ar, ld),
      and restore all builtin programs (alex, happy, hsc2hs, ...) as unconfigured
      entries on top of it.

      This serves two purposes:

        (a) The compiler programs (ghc, ghc-pkg, haddock, hsc2hs, ...) that were
            already configured at the project level appear in 'configuredProgs'.
            The 'configureAllKnownPrograms' call inside the Cabal per-package
            'configureFinal' skips them, saving redundant work.

        (b) Builtin preprocessors (e.g. alex, happy) are NOT configured at the
            project level; restoring them here means the call to
            'configureAllKnownPrograms' in 'configureFinal' can find them using
            the per-package search path (including 'extra-prog-path').

  (2)
    (a) When building a package with internal build tools, we must ensure that
        these build tools are available in PATH, with appropriate environment
        variable overrides for their data directory. To do this, we call
        'prependProgramSearchPath'.

    (b) Moreover, these programs must be available in the search paths for the
        compiler itself, in case they are run at compile-time (e.g. with a Template
        Haskell splice). We achieve this using 'updatePathProgDb'.
-}

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

-- * 'invoke' function

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

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 = StdStream -> (Handle -> StdStream) -> Maybe Handle -> StdStream
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
Inherit Handle -> StdStream
UseHandle (SetupScriptOptions -> Maybe Handle
useLoggingHandle SetupScriptOptions
options)
      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

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

-- * External SetupMethod

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

externalSetupMethod :: WithCallStack (FilePath -> SetupRunner UseGeneralSetup)
externalSetupMethod :: WithCallStack ([Char] -> SetupRunner 'UseGeneralSetup)
externalSetupMethod [Char]
path Verbosity
verbosity SetupScriptOptions
options BuildType
_ [[Char]]
args SetupRunnerArgs 'UseGeneralSetup
NotInLibrary =
#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 (workingDir options) "cabal-tmp" $ \tmpDir ->
        bracket
          (moveOutOfTheWay tmpDir origPath)
          (\tmpPath -> maybeRestore origPath tmpPath)
          (\tmpPath -> invoke' tmpPath)

    moveOutOfTheWay tmpDir origPath = do
      let tmpPath = tmpDir </> takeFileName origPath
      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

useCachedSetupExecutable :: BuildType -> Bool
useCachedSetupExecutable :: BuildType -> Bool
useCachedSetupExecutable BuildType
bt =
  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

data ExternalExe = HooksExe | SetupExe
data WantedExternalExe (meth :: ExternalExe) where
  WantHooks :: WantedExternalExe HooksExe
  WantSetup :: WantedExternalExe SetupExe

compileExternalExe
  :: Verbosity
  -> SetupScriptOptions
  -> PackageDescription
  -> BuildType
  -> WantedExternalExe exe
  -> IO (If (exe == HooksExe) () (Version, SetupMethod GeneralSetup, SetupScriptOptions))
compileExternalExe :: forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
-> WantedExternalExe exe
-> IO
     (If
        (exe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
compileExternalExe Verbosity
verbosity SetupScriptOptions
options PackageDescription
pkg BuildType
bt WantedExternalExe exe
wantedExe = do
  Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 8)) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i (SetupScriptOptions
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 8))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
options)
  (cabalLibVersion, mCabalLibInstalledPkgId, options') <-
    Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
cabalLibVersionToUse Verbosity
verbosity SetupScriptOptions
options (PackageDescription -> PackageId
package PackageDescription
pkg) BuildType
bt WantedExternalExe exe
wantedExe
  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion
  exePath <-
    if useCachedSetupExecutable bt
      then
        getCachedSetupExecutable
          verbosity
          platform
          (package pkg)
          bt
          options'
          cabalLibVersion
          mCabalLibInstalledPkgId
      else
        compileExe
          verbosity
          platform
          (package pkg)
          bt
          wantedExe
          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.
  exePath' <- tryCanonicalizePath exePath

  -- 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 options)
  let win32CleanHackNeeded =
        (useWin32CleanHack options)
          -- Skip when a cached setup script is used.
          && setupProgFile' `equalFilePath` exePath'
#else
  let win32CleanHackNeeded = Bool
False
#endif
  let options'' = SetupScriptOptions
options'{useWin32CleanHack = win32CleanHackNeeded}

  case wantedExe of
    WantedExternalExe exe
WantHooks -> If
  (exe == 'HooksExe)
  ()
  (Version, SetupMethod 'GeneralSetup, SetupScriptOptions)
-> IO
     (If
        (exe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    WantedExternalExe exe
WantSetup -> If
  (exe == 'HooksExe)
  ()
  (Version, SetupMethod 'GeneralSetup, SetupScriptOptions)
-> IO
     (If
        (exe == 'HooksExe)
        ()
        (Version, SetupMethod 'GeneralSetup, SetupScriptOptions))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
cabalLibVersion, [Char] -> SetupMethod 'GeneralSetup
ExternalMethod [Char]
exePath', SetupScriptOptions
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 allowAbs Pkg to -> FilePath
    i :: forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbs 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
    platform :: Platform
platform = Platform -> Maybe Platform -> Platform
forall a. a -> Maybe a -> a
fromMaybe Platform
buildPlatform (SetupScriptOptions -> Maybe Platform
usePlatform SetupScriptOptions
options)

-- | Extract the Cabal library version from 'SetupScriptOptions' if it is
-- already determined: either by the solver via 'useDependencies', or directly
-- via 'useCabalSpecVersion' (used for build-type: Custom packages whose
-- setup-depends does not include a transitive Cabal dependency).
cabalLibFromOptions
  :: SetupScriptOptions
  -> Maybe (Version, Maybe ComponentId)
cabalLibFromOptions :: SetupScriptOptions -> Maybe (Version, Maybe ComponentId)
cabalLibFromOptions SetupScriptOptions
options =
  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) -> (Version, Maybe ComponentId) -> Maybe (Version, Maybe ComponentId)
forall a. a -> Maybe a
Just (PackageId -> Version
pkgVersion PackageId
pkgId, ComponentId -> Maybe ComponentId
forall a. a -> Maybe a
Just ComponentId
unitId)
    Maybe (ComponentId, PackageId)
Nothing ->
      case SetupScriptOptions -> Maybe Version
useCabalSpecVersion SetupScriptOptions
options of
        Just Version
version -> (Version, Maybe ComponentId) -> Maybe (Version, Maybe ComponentId)
forall a. a -> Maybe a
Just (Version
version, Maybe ComponentId
forall a. Maybe a
Nothing)
        Maybe Version
Nothing      -> Maybe (Version, Maybe ComponentId)
forall a. Maybe a
Nothing

-- | Choose the version of Cabal to use if the setup script has a dependency
-- on Cabal. With v2 commands, 'cabalLibFromOptions' returns 'Just ...' and
-- we use that. With v1 commands, we fall back to a bunch of heuristics
-- (see 'v1CabalLibVersionToUse').
cabalLibVersionToUse
  :: Verbosity
  -> SetupScriptOptions
  -> PackageId
  -> BuildType
  -> WantedExternalExe exe
  -> IO (Version, Maybe ComponentId, SetupScriptOptions)
cabalLibVersionToUse :: forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
cabalLibVersionToUse Verbosity
verbosity SetupScriptOptions
options PackageId
pkgId BuildType
bt WantedExternalExe exe
wantedExe =
  case SetupScriptOptions -> Maybe (Version, Maybe ComponentId)
cabalLibFromOptions SetupScriptOptions
options of
    Just (Version
version, Maybe ComponentId
mUnitId) -> do
      Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()
updateSetupScript Verbosity
verbosity SetupScriptOptions
options 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
mUnitId, SetupScriptOptions
options)
    Maybe (Version, Maybe ComponentId)
Nothing ->
      Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
v1CabalLibVersionToUse Verbosity
verbosity SetupScriptOptions
options PackageId
pkgId BuildType
bt WantedExternalExe exe
wantedExe
  where
    writeSetupVersionFile :: Version -> IO ()
    writeSetupVersionFile :: Version -> IO ()
writeSetupVersionFile Version
version =
      [Char] -> [Char] -> IO ()
writeFile
        (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options) (SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
options))
        (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
version [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

-- | Update a Setup.hs script, creating it if necessary.
updateSetupScript :: Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()
updateSetupScript :: Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()
updateSetupScript Verbosity
verbosity SetupScriptOptions
options 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 options)
  when srcNewer $
    if useHs
      then copyFileVerbose verbosity src (i (setupHs options))
      else runSimplePreProcessor ppUnlit src (i (setupHs options)) 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"
    i :: SymbolicPath Pkg 'File -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options)
updateSetupScript Verbosity
verbosity SetupScriptOptions
options 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 options))
  rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript Hooks cabalLibVersion)
  rewriteFileLBS verbosity (i (hooksHs options)) hooksExeScript
  where
    i :: SymbolicPath Pkg 'File -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options)
updateSetupScript Verbosity
verbosity SetupScriptOptions
options Version
cabalLibVersion BuildType
bt' =
  Verbosity -> [Char] -> ByteString -> IO ()
rewriteFileLBS Verbosity
verbosity (SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupHs SetupScriptOptions
options)) (BuildType -> Version -> ByteString
buildTypeScript BuildType
bt' Version
cabalLibVersion)
  where
    i :: SymbolicPath Pkg 'File -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options)

-- | The source code for a non-Custom 'Setup' executable.
buildTypeScript :: BuildType -> Version -> BS.ByteString
buildTypeScript :: BuildType -> Version -> ByteString
buildTypeScript BuildType
bt 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 -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"buildtypeScript Make is no longer supported"
  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"

-- | The source code for an external hooks executable.
hooksExeScript :: BS.ByteString
hooksExeScript :: ByteString
hooksExeScript =
  ByteString
"{-# LANGUAGE NoImplicitPrelude #-}\nimport Distribution.Simple.SetupHooks.HooksMain (hooksMain); import SetupHooks; main = hooksMain setupHooks\n"

-- | Figure out which compiler we are using to compile the Setup script.
configureCompiler
  :: Verbosity
  -> SetupScriptOptions
  -> IO (Compiler, ProgramDb, SetupScriptOptions)
configureCompiler :: Verbosity
-> SetupScriptOptions
-> IO (Compiler, ProgramDb, SetupScriptOptions)
configureCompiler Verbosity
verbosity 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 verbosity options' comp progdb
  return
    ( comp
    , progdb
    , options'
        { useCompiler = Just comp
        , usePackageIndex = Just index
        , useProgramDb = progdb
        }
    )

maybeGetInstalledPackages
  :: Verbosity
  -> SetupScriptOptions
  -> Compiler
  -> ProgramDb
  -> IO InstalledPackageIndex
maybeGetInstalledPackages :: Verbosity
-> SetupScriptOptions
-> Compiler
-> ProgramDb
-> IO InstalledPackageIndex
maybeGetInstalledPackages Verbosity
verbosity 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

-- | Path to the setup exe cache directory and path to the cached setup
-- executable.
cachedSetupDirAndProg
  :: Platform
  -> BuildType
  -> SetupScriptOptions
  -> Version
  -> IO (FilePath, FilePath)
cachedSetupDirAndProg :: Platform
-> BuildType
-> SetupScriptOptions
-> Version
-> IO ([Char], [Char])
cachedSetupDirAndProg Platform
platform BuildType
bt 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 executable in the cache; update the cache if the executable
-- is not found.
getCachedSetupExecutable
  :: Verbosity
  -> Platform
  -> PackageIdentifier
  -> BuildType
  -> SetupScriptOptions
  -> Version
  -> Maybe InstalledPackageId
  -> IO FilePath
getCachedSetupExecutable :: Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> IO [Char]
getCachedSetupExecutable
  Verbosity
verbosity
  Platform
platform
  PackageId
pkgId
  BuildType
bt
  SetupScriptOptions
options'
  Version
cabalLibVersion
  Maybe ComponentId
maybeCabalLibInstalledPkgId = do
    (setupCacheDir, cachedSetupProgFile) <-
      Platform
-> BuildType
-> SetupScriptOptions
-> Version
-> IO ([Char], [Char])
cachedSetupDirAndProg Platform
platform BuildType
bt 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 <-
              compileExe
                verbosity
                platform
                pkgId
                bt
                WantSetup
                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 () -> IO ()
criticalSection' = (IO () -> IO ())
-> (Lock -> IO () -> IO ()) -> Maybe Lock -> IO () -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO () -> IO ()
forall a. a -> a
id Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
criticalSection (Maybe Lock -> IO () -> IO ()) -> Maybe Lock -> IO () -> IO ()
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.
compileExe
  :: Verbosity
  -> Platform
  -> PackageIdentifier
  -> BuildType
  -> WantedExternalExe exe
  -> SetupScriptOptions
  -> Version
  -> Maybe ComponentId
  -> Bool
  -> IO FilePath
compileExe :: forall (exe :: ExternalExe).
Verbosity
-> Platform
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileExe Verbosity
verbosity Platform
platform PackageId
pkgId BuildType
bt WantedExternalExe exe
wantedExe SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile =
  case WantedExternalExe exe
wantedExe of
    WantedExternalExe exe
WantHooks ->
      Verbosity
-> Platform
-> PackageId
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileHooksScript Verbosity
verbosity Platform
platform PackageId
pkgId SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile
    WantedExternalExe exe
WantSetup ->
      Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileSetupScript Verbosity
verbosity Platform
platform PackageId
pkgId BuildType
bt SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile

compileSetupScript
  :: Verbosity
  -> Platform
  -> PackageIdentifier
  -> BuildType
  -> SetupScriptOptions
  -> Version
  -> Maybe ComponentId
  -> Bool
  -> IO FilePath
compileSetupScript :: Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileSetupScript Verbosity
verbosity Platform
platform PackageId
pkgId BuildType
bt SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile =
  [Char]
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileSetupX [Char]
"Setup"
    [SetupScriptOptions -> SymbolicPath Pkg 'File
setupHs SetupScriptOptions
opts] (SetupScriptOptions -> SymbolicPath Pkg 'File
setupProgFile SetupScriptOptions
opts)
    Verbosity
verbosity Platform
platform PackageId
pkgId BuildType
bt SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile

compileHooksScript
  :: Verbosity
  -> Platform
  -> PackageIdentifier
  -> SetupScriptOptions
  -> Version
  -> Maybe ComponentId
  -> Bool
  -> IO FilePath
compileHooksScript :: Verbosity
-> Platform
-> PackageId
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileHooksScript Verbosity
verbosity Platform
platform PackageId
pkgId SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile =
  [Char]
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileSetupX [Char]
"SetupHooks"
    [SetupScriptOptions -> SymbolicPath Pkg 'File
setupHooks SetupScriptOptions
opts, SetupScriptOptions -> SymbolicPath Pkg 'File
hooksHs SetupScriptOptions
opts] (SetupScriptOptions -> SymbolicPath Pkg 'File
hooksProgFile SetupScriptOptions
opts)
    Verbosity
verbosity Platform
platform PackageId
pkgId BuildType
Hooks SetupScriptOptions
opts Version
ver Maybe ComponentId
mbCompId Bool
forceCompile

setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup)
setupDir :: forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
opts SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist ('Dir setup) -> SymbolicPath Pkg ('Dir setup)
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath Dist ('Dir setup)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"setup"
setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File
setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 0))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 0))
-> RelativePath (ZonkAny 0) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 0) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"setup" [Char] -> [Char] -> [Char]
<.> [Char]
"version" )
setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File
setupHs :: SetupScriptOptions -> SymbolicPath Pkg 'File
setupHs SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 1))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 1))
-> RelativePath (ZonkAny 1) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 1) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"setup" [Char] -> [Char] -> [Char]
<.> [Char]
"hs" )
hooksHs :: SetupScriptOptions -> SymbolicPath Pkg 'File
hooksHs SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 2))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 2))
-> RelativePath (ZonkAny 2) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 2) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"hooks" [Char] -> [Char] -> [Char]
<.> [Char]
"hs" )
setupHooks :: SetupScriptOptions -> SymbolicPath Pkg 'File
setupHooks SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 3))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 3))
-> RelativePath (ZonkAny 3) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 3) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"SetupHooks" [Char] -> [Char] -> [Char]
<.> [Char]
"hs" )
setupProgFile :: SetupScriptOptions -> SymbolicPath Pkg 'File
setupProgFile SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 4))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 4))
-> RelativePath (ZonkAny 4) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 4) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"setup" [Char] -> [Char] -> [Char]
<.> Platform -> [Char]
exeExtension Platform
buildPlatform )
hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg 'File
hooksProgFile SetupScriptOptions
opts = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 5))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
opts SymbolicPath Pkg ('Dir (ZonkAny 5))
-> RelativePath (ZonkAny 5) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 5) 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ( [Char]
"hooks" [Char] -> [Char] -> [Char]
<.> Platform -> [Char]
exeExtension Platform
buildPlatform )

compileSetupX
  :: String
  -> [SymbolicPath Pkg File] -- input files
  -> SymbolicPath Pkg File   -- output file
  -> Verbosity
  -> Platform
  -> PackageIdentifier
  -> BuildType
  -> SetupScriptOptions
  -> Version
  -> Maybe ComponentId
  -> Bool
  -> IO FilePath
compileSetupX :: [Char]
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> Verbosity
-> Platform
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Version
-> Maybe ComponentId
-> Bool
-> IO [Char]
compileSetupX
  [Char]
what
  [SymbolicPath Pkg 'File]
inPaths SymbolicPath Pkg 'File
outPath
  Verbosity
verbosity
  Platform
platform
  PackageId
pkgId
  BuildType
bt
  SetupScriptOptions
options'
  Version
cabalLibVersion
  Maybe ComponentId
maybeCabalLibInstalledPkgId
  Bool
forceCompile = do
    setupXHsNewer <-
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymbolicPath Pkg 'File]
-> (SymbolicPath Pkg 'File -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [SymbolicPath Pkg 'File]
inPaths (\ SymbolicPath Pkg 'File
inPath -> SymbolicPath Pkg 'File -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPath Pkg 'File
inPath [Char] -> [Char] -> IO Bool
`moreRecentFile` SymbolicPath Pkg 'File -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPath Pkg 'File
outPath)
    cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath
    let outOfDate = Bool
setupXHsNewer Bool -> Bool -> Bool
|| Bool
cabalVersionNewer
    when (outOfDate || forceCompile) $ do
      debug verbosity $ what ++ " executable needs to be updated, compiling..."
      (compiler, progdb, options'') <- configureCompiler verbosity 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 = SetupScriptOptions -> SymbolicPath Pkg ('Dir (ZonkAny 6))
forall setup. SetupScriptOptions -> SymbolicPath Pkg ('Dir setup)
setupDir SetupScriptOptions
options' SymbolicPath Pkg ('Dir (ZonkAny 6))
-> RelativePath (ZonkAny 6) 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
Cabal.Path.</> [Char] -> RelativePath (ZonkAny 6) 'File
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 (verbosityLevel verbosity) Normal
              , ghcOptMode = Flag GhcModeMake
              , ghcOptInputFiles = toNubListR inPaths
              , ghcOptOutputFile = Flag outPath
              , ghcOptObjDir = Flag (setupDir options')
              , ghcOptHiDir = Flag (setupDir options')
              , 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 $
                  [ Simple.DisableExtension Simple.ImplicitPrelude
                  | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps
                  ]
                  -- 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 pkgId) (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 outPath
  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 allowAbs Pkg to -> FilePath
    i :: forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbs 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

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"

--------------------------------------------------------------------------------
-- THE FORSAKEN ZONE: v1-only logic
--
-- Hopefully we can get rid of all of this before long, simplifying this
-- annoyingly complex module.
--
-- The v1 code path corresponds to 'useDependencies' being unset
-- (no pre-computed dependencies by the solver).

-- | **v1-only**
--
-- Fallback logic to find which Cabal library version to use: try the previously
-- saved version first, then search for available versions in the installed
-- package index, picking a "best" option heuristically.
v1CabalLibVersionToUse
  :: Verbosity
  -> SetupScriptOptions
  -> PackageId
  -> BuildType
  -> WantedExternalExe exe
  -> IO (Version, Maybe ComponentId, SetupScriptOptions)
v1CabalLibVersionToUse :: forall (exe :: ExternalExe).
Verbosity
-> SetupScriptOptions
-> PackageId
-> BuildType
-> WantedExternalExe exe
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
v1CabalLibVersionToUse Verbosity
verbosity SetupScriptOptions
options PackageId
pkgId BuildType
bt WantedExternalExe exe
wantedExe = do
  savedVer <- IO (Maybe Version)
savedVersion
  case savedVer of
    Just Version
version | Version
version Version -> VersionRange -> Bool
`withinRange` SetupScriptOptions -> VersionRange
useCabalVersion SetupScriptOptions
options ->
      do
        Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()
updateSetupScript Verbosity
verbosity SetupScriptOptions
options 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
    platform :: Platform
platform = Platform -> Maybe Platform -> Platform
forall a. a -> Maybe a -> a
fromMaybe Platform
buildPlatform (SetupScriptOptions -> Maybe Platform
usePlatform SetupScriptOptions
options)

    i :: SymbolicPath Pkg File -> FilePath
    i :: SymbolicPath Pkg 'File -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath (SetupScriptOptions -> Maybe (SymbolicPath CWD ('Dir Pkg))
useWorkingDir SetupScriptOptions
options)

    writeSetupVersionFile :: Version -> IO ()
    writeSetupVersionFile :: Version -> IO ()
writeSetupVersionFile Version
version =
      [Char] -> [Char] -> IO ()
writeFile (SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
options)) (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
version [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

    savedVersion :: IO (Maybe Version)
    savedVersion :: IO (Maybe Version)
savedVersion = do
      versionString <- [Char] -> IO [Char]
readFile (SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
options)) 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

    -- This check duplicates the checks in 'getCachedSetupExecutable' /
    -- 'compileExe'. 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 BuildType -> Bool
useCachedSetupExecutable BuildType
bt
        then do
          (_, cachedSetupProgFile) <- Platform
-> BuildType
-> SetupScriptOptions
-> Version
-> IO ([Char], [Char])
cachedSetupDirAndProg Platform
platform BuildType
bt SetupScriptOptions
options Version
version
          doesFileExist cachedSetupProgFile
        else case WantedExternalExe exe
wantedExe of
          WantedExternalExe exe
WantSetup ->
            Bool -> Bool -> Bool
(&&)
              (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupProgFile SetupScriptOptions
options) [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupHs SetupScriptOptions
options)
              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
<*> SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupProgFile SetupScriptOptions
options) [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
options)
          WantedExternalExe exe
WantHooks ->
            Bool -> Bool -> Bool
(&&)
              (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
hooksProgFile SetupScriptOptions
options) [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupHooks SetupScriptOptions
options)
              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
<*> SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
hooksProgFile SetupScriptOptions
options) [Char] -> [Char] -> IO Bool
`existsAndIsMoreRecentThan` SymbolicPath Pkg 'File -> [Char]
i (SetupScriptOptions -> SymbolicPath Pkg 'File
setupVersionFile SetupScriptOptions
options)

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

-- | **v1-only**
--
-- Find the version of the installed @Cabal@ package that satisfies the
-- version range in 'useCabalVersion'.
installedCabalVersion
  :: Verbosity
  -> PackageId
  -> BuildType
  -> SetupScriptOptions
  -> Compiler
  -> ProgramDb
  -> IO
      ( Version
      , Maybe InstalledPackageId
      , SetupScriptOptions
      )
installedCabalVersion :: Verbosity
-> PackageId
-> BuildType
-> SetupScriptOptions
-> Compiler
-> ProgramDb
-> IO (Version, Maybe ComponentId, SetupScriptOptions)
installedCabalVersion Verbosity
_verbosity PackageId
pkgId BuildType
bt SetupScriptOptions
options' Compiler
_ ProgramDb
_
  | PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgId 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 (PackageId -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageId
pkgId, Maybe ComponentId
forall a. Maybe a
Nothing, SetupScriptOptions
options')
installedCabalVersion Verbosity
verbosity PackageId
pkgId BuildType
_bt SetupScriptOptions
options' Compiler
compiler ProgramDb
progdb = do
  index <- Verbosity
-> SetupScriptOptions
-> Compiler
-> ProgramDb
-> IO InstalledPackageIndex
maybeGetInstalledPackages Verbosity
verbosity 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, 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 (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgId) (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''
            )

-- | **v1-only**
--
-- Pick the best version from a non-empty list, preferring the one that
-- matches or is closest to the currently running @cabal-install@\'s own
-- @Cabal@ library version.
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

-- End of v1-only logic
--------------------------------------------------------------------------------