{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Sandbox
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- UI for the sandboxing functionality.
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)

-- * Basic sandbox functions.

--

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)

-- | Check which type of package environment we're in and return a
-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
-- whether we're working in a sandbox.
loadConfigOrSandboxConfig
  :: Verbosity
  -> GlobalFlags
  -- ^ For @--config-file@ and
  -- @--sandbox-config-file@.
  -> 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
    -- Only @cabal.config@ is present.
    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'

    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
    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'

-- | Return the saved \"dist/\" prefix, or the default prefix.
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'

-- Utils (transitionary)
--

-- | Try to read the most recently configured compiler from the
-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
-- cannot be read.
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
        )