module Darcs.UI.Commands.SetPref ( setpref ) where
import Prelude ()
import Darcs.Prelude
import System.Exit ( exitWith, ExitCode(..) )
import Control.Monad ( when )
import Data.Maybe ( fromMaybe )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask)
import Darcs.UI.Options
( odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..) )
import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) )
import Darcs.Patch ( changepref )
import Darcs.Patch.Witnesses.Ordered ( FL(..) )
import Darcs.Repository.Prefs ( getPrefval, changePrefval )
import Darcs.Util.English ( orClauses )
import Darcs.Util.Path ( AbsolutePath )
validPrefData :: [(String, String)]
validPrefData :: [(String, String)]
validPrefData =
[("test", "a shell command that runs regression tests"),
("predist", "a shell command to run before `darcs dist'"),
("boringfile", "the path to a version-controlled boring file"),
("binariesfile", "the path to a version-controlled binaries file")]
validPrefs :: [String]
validPrefs :: [String]
validPrefs = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
validPrefData
setprefDescription :: String
setprefDescription :: String
setprefDescription =
"Set a preference (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
orClauses [String]
validPrefs String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")."
setprefHelp :: String
setprefHelp :: String
setprefHelp =
"When working on project with multiple repositories and contributors,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"it is sometimes desirable for a preference to be set consistently\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"project-wide. This is achieved by treating a preference set with\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"`darcs setpref` as an unrecorded change, which can then be recorded\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"and then treated like any other patch.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Valid preferences are:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
unlines ["* "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++" -- "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
y | (x :: String
x,y :: String
y) <- [(String, String)]
validPrefData] String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"For example, a project using GNU autotools, with a `make test` target\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"to perform regression tests, might enable Darcs' integrated regression\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"testing with the following command:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
" darcs setpref test 'autoconf && ./configure && make && make test'\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Note that merging is not currently implemented for preferences: if two\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"patches attempt to set the same preference, the last patch applied to\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"the repository will always take precedence. This is considered a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"low-priority bug, because preferences are seldom set.\n"
setpref :: DarcsCommand [DarcsFlag]
setpref :: DarcsCommand [DarcsFlag]
setpref = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "setpref"
, commandHelp :: String
commandHelp = String
setprefHelp
, commandDescription :: String
commandDescription = String
setprefDescription
, commandExtraArgs :: Int
commandExtraArgs = 2
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["<PREF>", "<VALUE>"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
setprefCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
forall (m :: * -> *) p p a. Monad m => p -> p -> [a] -> m [String]
completeArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
setprefAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
setprefBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
setprefOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
setprefOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
setprefOpts
}
where
setprefBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
setprefBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
O.repoDir
setprefAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
setprefAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
setprefOpts :: DarcsOption
a
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
setprefOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Maybe String)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
setprefBasicOpts PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Maybe String)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
setprefAdvancedOpts
completeArgs :: p -> p -> [a] -> m [String]
completeArgs _ _ [] = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
validPrefs
completeArgs _ _ _args :: [a]
_args = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
setprefCmd _ opts :: [DarcsFlag]
opts [pref :: String
pref,val :: String
val] =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
pref) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++
"' is not a valid preference name: no spaces allowed!"
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
pref String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
validPrefs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++"' is not a valid preference name!"
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Try one of: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
validPrefs
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1
Maybe String
oval <- String -> IO (Maybe String)
getPrefval String
pref
let old :: String
old = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
oval
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ('\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ "is not a valid preference value: newlines forbidden!"
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1
String -> String -> String -> IO ()
changePrefval String
pref String
old String
val
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Changing value of "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++" from '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
oldString -> String -> String
forall a. [a] -> [a] -> [a]
++"' to '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
valString -> String -> String
forall a. [a] -> [a] -> [a]
++"'"
Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU Any -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking (String -> String -> String -> PrimOf p wU Any
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> String -> prim wX wY
changepref String
pref String
old String
val PrimOf p wU Any -> FL (PrimOf p) Any Any -> FL (PrimOf p) wU Any
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PrimOf p) Any Any
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
setprefCmd _ _ _ = IO ()
forall a. a
impossible