{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Client.Sandbox (
loadConfigOrSandboxConfig,
findSavedDistPref,
updateInstallDirs,
getPersistOrConfigCompiler
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Setup
( ConfigFlags(..), GlobalFlags(..), configCompilerAux' )
import Distribution.Client.Config
( SavedConfig(..), defaultUserInstall, loadConfig )
import Distribution.Client.Sandbox.PackageEnvironment
( PackageEnvironmentType(..)
, classifyPackageEnvironment
, loadUserConfig
)
import Distribution.Client.SetupWrapper
( SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.Configure ( maybeGetPersistBuildConfig
, findDistPrefOrDefault
, findDistPref )
import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
import Distribution.Simple.Program ( ProgramDb )
import Distribution.Simple.Setup ( Flag(..)
, fromFlagOrDefault, flagToMaybe )
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 :: ConfigFlags
savedConfigureFlags = ConfigFlags
configureFlags
{ configInstallDirs :: InstallDirs (Flag PathTemplate)
configInstallDirs = InstallDirs (Flag PathTemplate)
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
FilePath
pkgEnvDir <- IO FilePath
getCurrentDirectory
PackageEnvironmentType
pkgEnvType <- FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment FilePath
pkgEnvDir
case PackageEnvironmentType
pkgEnvType of
PackageEnvironmentType
UserPackageEnvironment -> do
SavedConfig
config <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
SavedConfig
userConfig <- Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
forall a. Maybe a
Nothing
let config' :: SavedConfig
config' = SavedConfig
config SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
userConfig
SavedConfig -> IO SavedConfig
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
config'
PackageEnvironmentType
AmbientPackageEnvironment -> do
SavedConfig
config <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
let globalConstraintsOpt :: Maybe FilePath
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
SavedConfig
globalConstraintConfig <-
Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConstraintsOpt
let config' :: SavedConfig
config' = SavedConfig
config SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
globalConstraintConfig
SavedConfig -> IO SavedConfig
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
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
FilePath
distPref <- Flag FilePath -> IO FilePath
findDistPrefOrDefault (ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags)
Maybe LocalBuildInfo
mlbi <- FilePath -> IO (Maybe LocalBuildInfo)
maybeGetPersistBuildConfig FilePath
distPref
case Maybe LocalBuildInfo
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 (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
)