{-# 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.Client.ProjectConfig
( readProjectLocalExtraConfig
, writeProjectLocalExtraConfig
)
import Distribution.Client.ProjectFlags
( removeIgnoreProjectOption
)
import Distribution.Client.ProjectOrchestration
import Distribution.Simple.Flag
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..)
, defaultNixStyleFlags
, nixStyleOptions
)
import Distribution.Client.Setup
( ConfigExFlags (..)
, ConfigFlags (..)
, GlobalFlags
)
import Distribution.Verbosity
( normal
)
import Distribution.Simple.Command
( CommandUI (..)
, usageAlternatives
)
import Distribution.Simple.Utils
( dieWithException
, notice
, wrapText
)
import Distribution.Client.DistDirLayout
( DistDirLayout (..)
)
import Distribution.Client.Errors
import Distribution.Client.HttpUtils
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Types.CondTree
( CondTree (..)
)
import Distribution.Utils.NubList
( fromNubList
)
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 = (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{()
HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
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
(baseCtx, projConfig) <- NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' NixStyleFlags ()
flags [String]
extraArgs GlobalFlags
globalFlags
if shouldNotWriteFile baseCtx
then notice v "Config file not written due to flag(s)."
else writeProjectLocalExtraConfig (distDirLayout baseCtx) 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{()
HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
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
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
..} [String]
_extraArgs GlobalFlags
globalFlags = do
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
v ProjectConfig
cliConfig CurrentCommand
OtherCommand
let localFile = DistDirLayout -> String -> String
distProjectFile (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) String
"local"
let 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 -> 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
localFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"~"
if shouldNotWriteFile baseCtx
then return (baseCtx, cliConfig)
else do
exists <- doesFileExist localFile
when (exists && backups) $ do
notice v $
quote (takeFileName localFile)
<> " already exists, backing it up to "
<> quote (takeFileName backupFile)
<> "."
copyFile localFile backupFile
if exists && appends
then do
httpTransport <-
configureTransport
v
(fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
(flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
(CondNode conf imps bs) <-
runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx)
when (not (null imps && null bs)) $ dieWithException v UnableToPerformInplaceUpdate
return (baseCtx, conf <> cliConfig)
else return (baseCtx, 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)