{-# 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 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 )


-- * Basic sandbox functions.
--

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)

-- | 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

  FilePath
pkgEnvDir  <- IO FilePath
getCurrentDirectory
  PackageEnvironmentType
pkgEnvType <- FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment FilePath
pkgEnvDir
  case PackageEnvironmentType
pkgEnvType of
    -- Only @cabal.config@ is present.
    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'

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

-- | 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
  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
                       )