--  Copyright (C) 2003 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

module Darcs.UI.Commands.SetPref ( setpref ) where

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, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdatePending (..) )
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 )
import Darcs.Util.Printer ( Doc, text )

-- | A list of all valid preferences for @_darcs/prefs/prefs@.
validPrefData :: [(String, String)] -- ^ (name, one line description)
validPrefData :: [(String, String)]
validPrefData =
    [(String
"test", String
"a shell command that runs regression tests"),
     (String
"predist", String
"a shell command to run before `darcs dist'"),
     (String
"boringfile", String
"the path to a version-controlled boring file"),
     (String
"binariesfile", String
"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 =
    String
"Set a preference (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
orClauses [String]
validPrefs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")."

setprefHelp :: Doc
setprefHelp :: Doc
setprefHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"When working on project with multiple repositories and contributors,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"it is sometimes desirable for a preference to be set consistently\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"project-wide.  This is achieved by treating a preference set with\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"`darcs setpref` as an unrecorded change, which can then be recorded\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"and then treated like any other patch.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Valid preferences are:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 [String] -> String
unlines [String
"* "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -- "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
y | (String
x,String
y) <- [(String, String)]
validPrefData] String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"For example, a project using GNU autotools, with a `make test` target\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"to perform regression tests, might enable Darcs' integrated regression\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"testing with the following command:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    darcs setpref test 'autoconf && ./configure && make && make test'\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Note that merging is not currently implemented for preferences: if two\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"patches attempt to set the same preference, the last patch applied to\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"the repository will always take precedence.  This is considered a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"low-priority bug, because preferences are seldom set.\n"

setpref :: DarcsCommand
setpref :: DarcsCommand
setpref = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"setpref"
    , commandHelp :: Doc
commandHelp = Doc
setprefHelp
    , commandDescription :: String
commandDescription = String
setprefDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
2
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<PREF>", String
"<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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
setprefOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
setprefOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
setprefBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
setprefAdvancedOpts
    completeArgs :: p -> p -> [a] -> m [String]
completeArgs p
_ p
_ [] = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
validPrefs
    completeArgs p
_ p
_ [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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String
pref,String
val] =
 DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 rt p wR wU wR
repository -> do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' 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 -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"' 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 Int
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 -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' is not a valid preference name!"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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 Int
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 String
"" Maybe String
oval
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
'\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]
++ String
"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 Int
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
$ String
"Changing value of "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
prefString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" from '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
oldString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' to '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
valString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"
  Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU Any -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository (PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"impossible case"