{-# LANGUAGE RecordWildCards #-}
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 [])
}
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
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"
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 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
quote :: String -> String
quote String
s = String
"'" forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"'"
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)