{-# LANGUAGE DataKinds #-}
{-# 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
  ( CommonSetupFlags (..)
  , 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 Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )

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

  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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
config'

-- | Return the saved \"dist/\" prefix, or the default prefix.
findSavedDistPref :: SavedConfig -> Flag (SymbolicPath Pkg (Dir Dist)) -> IO (SymbolicPath Pkg (Dir Dist))
findSavedDistPref :: SavedConfig
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findSavedDistPref SavedConfig
config Flag (SymbolicPath Pkg ('Dir Dist))
flagDistPref = do
  let defDistPref :: SymbolicPath Pkg ('Dir Dist)
defDistPref = SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
defaultSetupScriptOptions
      flagDistPref' :: Flag (SymbolicPath Pkg ('Dir Dist))
flagDistPref' =
        (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref (ConfigFlags -> CommonSetupFlags
configCommonFlags (ConfigFlags -> CommonSetupFlags)
-> ConfigFlags -> CommonSetupFlags
forall a b. (a -> b) -> a -> b
$ SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config))
          Flag (SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
forall a. Monoid a => a -> a -> a
`mappend` Flag (SymbolicPath Pkg ('Dir Dist))
flagDistPref
  SymbolicPath Pkg ('Dir Dist)
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findDistPref SymbolicPath Pkg ('Dir Dist)
defDistPref Flag (SymbolicPath Pkg ('Dir Dist))
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
  let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
  SymbolicPath Pkg ('Dir Dist)
distPref <- Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findDistPrefOrDefault (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
common)
  Maybe LocalBuildInfo
mlbi <- Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist) -> IO (Maybe LocalBuildInfo)
maybeGetPersistBuildConfig (Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir CommonSetupFlags
common) SymbolicPath Pkg ('Dir Dist)
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 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
        )