cabal-install/src/Distribution/Client/Sandbox.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE RankNTypes #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -----------------------------------------------------------------------------
   9
  10 -- |
  11 -- Module      :  Distribution.Client.Sandbox
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  portable
  14 --
  15 -- UI for the sandboxing functionality.
  16 module Distribution.Client.Sandbox
  17   ( loadConfigOrSandboxConfig
  18   , findSavedDistPref
  19   , updateInstallDirs
  20   , getPersistOrConfigCompiler
  21   ) where
  22
  23 import Distribution.Client.Compat.Prelude
  24 import Prelude ()
  25
  26 import Distribution.Client.Config
  27   ( SavedConfig (..)
  28   , defaultUserInstall
  29   , loadConfig
  30   )
  31 import Distribution.Client.Setup
  32   ( CommonSetupFlags (..)
  33   , ConfigFlags (..)
  34   , GlobalFlags (..)
  35   , configCompilerAux'
  36   )
  37
  38 import Distribution.Client.Sandbox.PackageEnvironment
  39   ( PackageEnvironmentType (..)
  40   , classifyPackageEnvironment
  41   , loadUserConfig
  42   )
  43 import Distribution.Client.SetupWrapper
  44   ( SetupScriptOptions (..)
  45   , defaultSetupScriptOptions
  46   )
  47 import Distribution.Simple.Compiler (Compiler (..))
  48 import Distribution.Simple.Configure
  49   ( findDistPref
  50   , findDistPrefOrDefault
  51   , maybeGetPersistBuildConfig
  52   )
  53 import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
  54 import Distribution.Simple.Program (ProgramDb)
  55 import Distribution.Simple.Setup
  56   ( Flag (..)
  57   , flagToMaybe
  58   , fromFlagOrDefault
  59   )
  60 import Distribution.System (Platform)
  61 import Distribution.Utils.Path hiding
  62   ( (<.>)
  63   , (</>)
  64   )
  65
  66 import System.Directory
  67   ( getCurrentDirectory
  68   )
  69
  70 -- * Basic sandbox functions.
  71
  72 --
  73
  74 updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
  75 updateInstallDirs userInstallFlag savedConfig =
  76   savedConfig
  77     { savedConfigureFlags =
  78         configureFlags
  79           { configInstallDirs = installDirs
  80           }
  81     }
  82   where
  83     configureFlags = savedConfigureFlags savedConfig
  84     userInstallDirs = savedUserInstallDirs savedConfig
  85     globalInstallDirs = savedGlobalInstallDirs savedConfig
  86     installDirs
  87       | userInstall = userInstallDirs
  88       | otherwise = globalInstallDirs
  89     userInstall =
  90       fromFlagOrDefault
  91         defaultUserInstall
  92         (configUserInstall configureFlags `mappend` userInstallFlag)
  93
  94 -- | Check which type of package environment we're in and return a
  95 -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
  96 -- whether we're working in a sandbox.
  97 loadConfigOrSandboxConfig
  98   :: Verbosity
  99   -> GlobalFlags
 100   -- ^ For @--config-file@ and
 101   -- @--sandbox-config-file@.
 102   -> IO SavedConfig
 103 loadConfigOrSandboxConfig verbosity globalFlags = do
 104   let configFileFlag = globalConfigFile globalFlags
 105
 106   pkgEnvDir <- getCurrentDirectory
 107   pkgEnvType <- classifyPackageEnvironment pkgEnvDir
 108   case pkgEnvType of
 109     -- Only @cabal.config@ is present.
 110     UserPackageEnvironment -> do
 111       config <- loadConfig verbosity configFileFlag
 112       userConfig <- loadUserConfig verbosity pkgEnvDir Nothing
 113       let config' = config `mappend` userConfig
 114       return config'
 115
 116     -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
 117     AmbientPackageEnvironment -> do
 118       config <- loadConfig verbosity configFileFlag
 119       let globalConstraintsOpt =
 120             flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config
 121       globalConstraintConfig <-
 122         loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
 123       let config' = config `mappend` globalConstraintConfig
 124       return config'
 125
 126 -- | Return the saved \"dist/\" prefix, or the default prefix.
 127 findSavedDistPref :: SavedConfig -> Flag (SymbolicPath Pkg (Dir Dist)) -> IO (SymbolicPath Pkg (Dir Dist))
 128 findSavedDistPref config flagDistPref = do
 129   let defDistPref = useDistPref defaultSetupScriptOptions
 130       flagDistPref' =
 131         (setupDistPref (configCommonFlags $ savedConfigureFlags config))
 132           `mappend` flagDistPref
 133   findDistPref defDistPref flagDistPref'
 134
 135 -- Utils (transitionary)
 136 --
 137
 138 -- | Try to read the most recently configured compiler from the
 139 -- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
 140 -- cannot be read.
 141 getPersistOrConfigCompiler
 142   :: ConfigFlags
 143   -> IO (Compiler, Platform, ProgramDb)
 144 getPersistOrConfigCompiler configFlags = do
 145   let common = configCommonFlags configFlags
 146   distPref <- findDistPrefOrDefault (setupDistPref common)
 147   mlbi <- maybeGetPersistBuildConfig (flagToMaybe $ setupWorkingDir common) distPref
 148   case mlbi of
 149     Nothing -> do configCompilerAux' configFlags
 150     Just lbi ->
 151       return
 152         ( LocalBuildInfo.compiler lbi
 153         , LocalBuildInfo.hostPlatform lbi
 154         , LocalBuildInfo.withPrograms lbi
 155         )