{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Client.Sandbox
( loadConfigOrSandboxConfig
, findSavedDistPref
, updateInstallDirs
, getPersistOrConfigCompiler
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.Config
( SavedConfig (..)
, defaultUserInstall
, loadConfig
)
import Distribution.Client.Setup
( ConfigFlags (..)
, GlobalFlags (..)
, configCompilerAux'
)
import Distribution.Client.Sandbox.PackageEnvironment
( PackageEnvironmentType (..)
, classifyPackageEnvironment
, loadUserConfig
)
import Distribution.Client.SetupWrapper
( SetupScriptOptions (..)
, defaultSetupScriptOptions
)
import Distribution.Simple.Compiler (Compiler (..))
import Distribution.Simple.Configure
( findDistPref
, findDistPrefOrDefault
, maybeGetPersistBuildConfig
)
import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
import Distribution.Simple.Program (ProgramDb)
import Distribution.Simple.Setup
( Flag (..)
, flagToMaybe
, fromFlagOrDefault
)
import Distribution.System (Platform)
import System.Directory (getCurrentDirectory)
updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs Flag Bool
userInstallFlag SavedConfig
savedConfig =
SavedConfig
savedConfig
{ savedConfigureFlags =
configureFlags
{ configInstallDirs = installDirs
}
}
where
configureFlags :: ConfigFlags
configureFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
savedConfig
userInstallDirs :: InstallDirs (Flag PathTemplate)
userInstallDirs = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
savedConfig
globalInstallDirs :: InstallDirs (Flag PathTemplate)
globalInstallDirs = SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs SavedConfig
savedConfig
installDirs :: InstallDirs (Flag PathTemplate)
installDirs
| Bool
userInstall = InstallDirs (Flag PathTemplate)
userInstallDirs
| Bool
otherwise = InstallDirs (Flag PathTemplate)
globalInstallDirs
userInstall :: Bool
userInstall =
Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault
Bool
defaultUserInstall
(ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configureFlags Flag Bool -> Flag Bool -> Flag Bool
forall a. Monoid a => a -> a -> a
`mappend` Flag Bool
userInstallFlag)
loadConfigOrSandboxConfig
:: Verbosity
-> GlobalFlags
-> IO SavedConfig
loadConfigOrSandboxConfig :: Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags = do
let configFileFlag :: Flag FilePath
configFileFlag = GlobalFlags -> Flag FilePath
globalConfigFile GlobalFlags
globalFlags
pkgEnvDir <- IO FilePath
getCurrentDirectory
pkgEnvType <- classifyPackageEnvironment pkgEnvDir
case pkgEnvType of
PackageEnvironmentType
UserPackageEnvironment -> do
config <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
userConfig <- loadUserConfig verbosity pkgEnvDir Nothing
let config' = SavedConfig
config SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
userConfig
return config'
PackageEnvironmentType
AmbientPackageEnvironment -> do
config <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
let globalConstraintsOpt =
Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (SavedConfig -> Flag FilePath) -> SavedConfig -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalFlags -> Flag FilePath
globalConstraintsFile (GlobalFlags -> Flag FilePath)
-> (SavedConfig -> GlobalFlags) -> SavedConfig -> Flag FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> GlobalFlags
savedGlobalFlags (SavedConfig -> Maybe FilePath) -> SavedConfig -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ SavedConfig
config
globalConstraintConfig <-
loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
let config' = SavedConfig
config SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
globalConstraintConfig
return config'
findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath
findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath
findSavedDistPref SavedConfig
config Flag FilePath
flagDistPref = do
let defDistPref :: FilePath
defDistPref = SetupScriptOptions -> FilePath
useDistPref SetupScriptOptions
defaultSetupScriptOptions
flagDistPref' :: Flag FilePath
flagDistPref' =
ConfigFlags -> Flag FilePath
configDistPref (SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config)
Flag FilePath -> Flag FilePath -> Flag FilePath
forall a. Monoid a => a -> a -> a
`mappend` Flag FilePath
flagDistPref
FilePath -> Flag FilePath -> IO FilePath
findDistPref FilePath
defDistPref Flag FilePath
flagDistPref'
getPersistOrConfigCompiler
:: ConfigFlags
-> IO (Compiler, Platform, ProgramDb)
getPersistOrConfigCompiler :: ConfigFlags -> IO (Compiler, Platform, ProgramDb)
getPersistOrConfigCompiler ConfigFlags
configFlags = do
distPref <- Flag FilePath -> IO FilePath
findDistPrefOrDefault (ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags)
mlbi <- maybeGetPersistBuildConfig distPref
case mlbi of
Maybe LocalBuildInfo
Nothing -> do ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags
Just LocalBuildInfo
lbi ->
(Compiler, Platform, ProgramDb)
-> IO (Compiler, Platform, ProgramDb)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
( LocalBuildInfo -> Compiler
LocalBuildInfo.compiler LocalBuildInfo
lbi
, LocalBuildInfo -> Platform
LocalBuildInfo.hostPlatform LocalBuildInfo
lbi
, LocalBuildInfo -> ProgramDb
LocalBuildInfo.withPrograms LocalBuildInfo
lbi
)