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

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