{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: configure
--
module Distribution.Client.CmdConfigure (
    configureCommand,
    configureAction,
    configureAction',
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import System.Directory
import System.FilePath

import Distribution.Simple.Flag
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectConfig
         ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig )
import Distribution.Client.ProjectFlags
         ( removeIgnoreProjectOption )

import Distribution.Client.NixStyleOptions
         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Setup
         ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) )
import Distribution.Verbosity
         ( normal )

import Distribution.Simple.Command
         ( CommandUI(..), usageAlternatives )
import Distribution.Simple.Utils
         ( wrapText, notice, die' )

import Distribution.Client.DistDirLayout
         ( DistDirLayout(..) )
import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.HttpUtils
import Distribution.Utils.NubList
         ( fromNubList )
import Distribution.Types.CondTree
         ( CondTree (..) )

configureCommand :: CommandUI (NixStyleFlags ())
configureCommand :: CommandUI (NixStyleFlags ())
configureCommand = CommandUI {
  commandName :: String
commandName         = String
"v2-configure",
  commandSynopsis :: String
commandSynopsis     = String
"Add extra project configuration.",
  commandUsage :: String -> String
commandUsage        = String -> [String] -> String -> String
usageAlternatives String
"v2-configure" [ String
"[FLAGS]" ],
  commandDescription :: Maybe (String -> String)
commandDescription  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \String
_ -> String -> String
wrapText forall a b. (a -> b) -> a -> b
$
        String
"Adjust how the project is built by setting additional package flags "
     forall a. [a] -> [a] -> [a]
++ String
"and other flags.\n\n"

     forall a. [a] -> [a] -> [a]
++ String
"The configuration options are written to the 'cabal.project.local' "
     forall a. [a] -> [a] -> [a]
++ String
"file (or '$project_file.local', if '--project-file' is specified) "
     forall a. [a] -> [a] -> [a]
++ String
"which extends the configuration from the 'cabal.project' file "
     forall a. [a] -> [a] -> [a]
++ String
"(if any). This combination is used as the project configuration for "
     forall a. [a] -> [a] -> [a]
++ String
"all other commands (such as 'v2-build', 'v2-repl' etc) though it "
     forall a. [a] -> [a] -> [a]
++ String
"can be extended/overridden on a per-command basis.\n\n"

     forall a. [a] -> [a] -> [a]
++ String
"The v2-configure command also checks that the project configuration "
     forall a. [a] -> [a] -> [a]
++ String
"will work. In particular it checks that there is a consistent set of "
     forall a. [a] -> [a] -> [a]
++ String
"dependencies for the project as a whole.\n\n"

     forall a. [a] -> [a] -> [a]
++ String
"The 'cabal.project.local' file persists across 'v2-clean' but is "
     forall a. [a] -> [a] -> [a]
++ String
"overwritten on the next use of the 'v2-configure' command. The "
     forall a. [a] -> [a] -> [a]
++ String
"intention is that the 'cabal.project' file should be kept in source "
     forall a. [a] -> [a] -> [a]
++ String
"control but the 'cabal.project.local' should not.\n\n"

     forall a. [a] -> [a] -> [a]
++ String
"It is never necessary to use the 'v2-configure' command. It is "
     forall a. [a] -> [a] -> [a]
++ String
"merely a convenience in cases where you do not want to specify flags "
     forall a. [a] -> [a] -> [a]
++ String
"to 'v2-build' (and other commands) every time and yet do not want "
     forall a. [a] -> [a] -> [a]
++ String
"to alter the 'cabal.project' persistently.",
  commandNotes :: Maybe (String -> String)
commandNotes        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"Examples:\n"
     forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" v2-configure --with-compiler ghc-7.10.3\n"
     forall a. [a] -> [a] -> [a]
++ String
"    Adjust the project configuration to use the given compiler\n"
     forall a. [a] -> [a] -> [a]
++ String
"    program and check the resulting configuration works.\n"
     forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" v2-configure\n"
     forall a. [a] -> [a] -> [a]
++ String
"    Reset the local configuration to empty. To check that the\n"
     forall a. [a] -> [a] -> [a]
++ String
"    project configuration works, use 'cabal build'.\n"

  , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
  , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions      = forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions (forall a b. a -> b -> a
const [])
  }

-- | To a first approximation, the @configure@ just runs the first phase of
-- the @build@ command where we bring the install plan up to date (thus
-- checking that it's possible).
--
-- The only difference is that @configure@ also allows the user to specify
-- some extra config flags which we save in the file @cabal.project.local@.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
configureAction flags :: NixStyleFlags ()
flags@NixStyleFlags {()
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: ()
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [String]
extraArgs GlobalFlags
globalFlags = do
    (ProjectBaseContext
baseCtx, ProjectConfig
projConfig) <- NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' NixStyleFlags ()
flags [String]
extraArgs GlobalFlags
globalFlags

    if ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx
      then Verbosity -> String -> IO ()
notice Verbosity
v String
"Config file not written due to flag(s)."
      else DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) ProjectConfig
projConfig
  where
    v :: Verbosity
v = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)

configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)
configureAction' :: NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' flags :: NixStyleFlags ()
flags@NixStyleFlags {()
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: ()
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
..} [String]
_extraArgs GlobalFlags
globalFlags = do
    --TODO: deal with _extraArgs, since flags with wrong syntax end up there

    ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
v ProjectConfig
cliConfig CurrentCommand
OtherCommand

    let localFile :: String
localFile  = DistDirLayout -> String -> String
distProjectFile (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) String
"local"
    -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~
    let backups :: Bool
backups = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
True  forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configBackup ConfigExFlags
configExFlags
        appends :: Bool
appends = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configAppend ConfigExFlags
configExFlags
        backupFile :: String
backupFile = String
localFile forall a. Semigroup a => a -> a -> a
<> String
"~"

    if ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx
      then
        forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
      else do
        Bool
exists <- String -> IO Bool
doesFileExist String
localFile
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
backups) forall a b. (a -> b) -> a -> b
$ do
          Verbosity -> String -> IO ()
notice Verbosity
v forall a b. (a -> b) -> a -> b
$
            String -> String
quote (String -> String
takeFileName String
localFile) forall a. Semigroup a => a -> a -> a
<> String
" already exists, backing it up to "
            forall a. Semigroup a => a -> a -> a
<> String -> String
quote (String -> String
takeFileName String
backupFile) forall a. Semigroup a => a -> a -> a
<> String
"."
          String -> String -> IO ()
copyFile String
localFile String
backupFile

         -- If the flag @configAppend@ is set to true, append and do not overwrite
        if Bool
exists Bool -> Bool -> Bool
&& Bool
appends
          then do
            HttpTransport
httpTransport <- Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
v
                     (forall a. NubList a -> [a]
fromNubList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList String
projectConfigProgPathExtra forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
                     (forall a. Flag a -> Maybe a
flagToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)
            (CondNode ProjectConfig
conf [String]
imps [CondBranch ConfVar [String] ProjectConfig]
bs)  <- forall a. String -> Rebuild a -> IO a
runRebuild (DistDirLayout -> String
distProjectRootDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> DistDirLayout
distDirLayout forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
baseCtx) forall a b. (a -> b) -> a -> b
$
              Verbosity
-> HttpTransport
-> DistDirLayout
-> Rebuild (CondTree ConfVar [String] ProjectConfig)
readProjectLocalExtraConfig Verbosity
v HttpTransport
httpTransport (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
imps Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondBranch ConfVar [String] ProjectConfig]
bs)) forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> String -> IO a
die' Verbosity
v String
"local project file has conditional and/or import logic, unable to perform and automatic in-place update"
            forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
conf forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig)
          else
            forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
  where
    v :: Verbosity
v = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
    cliConfig :: ProjectConfig
cliConfig = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags ()
flags
                  forall a. Monoid a => a
mempty -- ClientInstallFlags, not needed here
    quote :: String -> String
quote String
s = String
"'" forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"'"

-- Config file should not be written when certain flags are present
shouldNotWriteFile :: ProjectBaseContext -> Bool
shouldNotWriteFile :: ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx =
     BuildTimeSettings -> Bool
buildSettingDryRun (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
  Bool -> Bool -> Bool
|| BuildTimeSettings -> Bool
buildSettingOnlyDownload (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)