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