{-# 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 :: forall flags.
String
-> String
-> (String -> String)
-> Maybe (String -> String)
-> Maybe (String -> String)
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
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 = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ -> String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
String
"Adjust how the project is built by setting additional package flags "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"and other flags.\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The configuration options are written to the 'cabal.project.local' "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"file (or '$project_file.local', if '--project-file' is specified) "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"which extends the configuration from the 'cabal.project' file "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(if any). This combination is used as the project configuration for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"all other commands (such as 'v2-build', 'v2-repl' etc) though it "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"can be extended/overridden on a per-command basis.\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The v2-configure command also checks that the project configuration "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"will work. In particular it checks that there is a consistent set of "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"dependencies for the project as a whole.\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The 'cabal.project.local' file persists across 'v2-clean' but is "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"overwritten on the next use of the 'v2-configure' command. The "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"intention is that the 'cabal.project' file should be kept in source "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"control but the 'cabal.project.local' should not.\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"It is never necessary to use the 'v2-configure' command. It is "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"merely a convenience in cases where you do not want to specify flags "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to 'v2-build' (and other commands) every time and yet do not want "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to alter the 'cabal.project' persistently.",
commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
String
"Examples:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-configure --with-compiler ghc-7.10.3\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Adjust the project configuration to use the given compiler\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" program and check the resulting configuration works.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-configure\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Reset the local configuration to empty. To check that the\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" project configuration works, use 'cabal build'.\n"
, commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
, commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions = [OptionField (NixStyleFlags ())]
-> [OptionField (NixStyleFlags ())]
forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption
([OptionField (NixStyleFlags ())]
-> [OptionField (NixStyleFlags ())])
-> (ShowOrParseArgs -> [OptionField (NixStyleFlags ())])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
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 = Verbosity -> Flag Verbosity -> Verbosity
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 = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
True (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configBackup ConfigExFlags
configExFlags
appends :: Bool
appends = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configAppend ConfigExFlags
configExFlags
backupFile :: String
backupFile = String
localFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"~"
if ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx
then
(ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
else do
Bool
exists <- String -> IO Bool
doesFileExist String
localFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
backups) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
notice Verbosity
v (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> String
quote (String -> String
takeFileName String
localFile) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" already exists, backing it up to "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quote (String -> String
takeFileName String
backupFile) String -> String -> String
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
(NubList String -> [String]
forall a. NubList a -> [a]
fromNubList (NubList String -> [String])
-> (ProjectConfigShared -> NubList String)
-> ProjectConfigShared
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList String
projectConfigProgPathExtra (ProjectConfigShared -> [String])
-> ProjectConfigShared -> [String]
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
(Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (ProjectConfigBuildOnly -> Flag String)
-> ProjectConfigBuildOnly
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport (ProjectConfigBuildOnly -> Maybe String)
-> ProjectConfigBuildOnly -> Maybe String
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)
(CondNode ProjectConfig
conf [String]
imps [CondBranch ConfVar [String] ProjectConfig]
bs) <- String
-> Rebuild (CondTree ConfVar [String] ProjectConfig)
-> IO (CondTree ConfVar [String] ProjectConfig)
forall a. String -> Rebuild a -> IO a
runRebuild (DistDirLayout -> String
distProjectRootDirectory (DistDirLayout -> String)
-> (ProjectBaseContext -> DistDirLayout)
-> ProjectBaseContext
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> DistDirLayout
distDirLayout (ProjectBaseContext -> String) -> ProjectBaseContext -> String
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
baseCtx) (Rebuild (CondTree ConfVar [String] ProjectConfig)
-> IO (CondTree ConfVar [String] ProjectConfig))
-> Rebuild (CondTree ConfVar [String] ProjectConfig)
-> IO (CondTree ConfVar [String] ProjectConfig)
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)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
imps Bool -> Bool -> Bool
&& [CondBranch ConfVar [String] ProjectConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondBranch ConfVar [String] ProjectConfig]
bs)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
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"
(ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
conf ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig)
else
(ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
where
v :: Verbosity
v = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
cliConfig :: ProjectConfig
cliConfig = GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags ()
flags
ClientInstallFlags
forall a. Monoid a => a
mempty
quote :: String -> String
quote String
s = String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
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)