--  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, void )
import Data.Maybe ( fromMaybe )

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInHashedRepository
    , nodefaults
    , withStdOpts
    )
import Darcs.UI.Flags ( DarcsFlag, diffingOpts, useCache, umask)
import Darcs.UI.Options ( (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository
    ( RepoJob(..)
    , addToPending
    , finalizeRepositoryChanges
    , withRepoLock
    )
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
    { 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
setprefOpts
    }
  where
    setprefBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
setprefBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir
    setprefAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
setprefAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    setprefOpts :: CommandOptions
setprefOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String)
PrimDarcsOption (Maybe String)
setprefBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String)
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
setprefAdvancedOpts
    completeArgs :: p -> p -> [a] -> m [String]
completeArgs p
_ p
_ [] = [String] -> m [String]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
validPrefs
    completeArgs p
_ p
_ [a]
_args = [String] -> m [String]
forall a. a -> m a
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] =
 UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU Any -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository 'RW p wU wR
repository ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) (String -> String -> String -> PrimOf p wU Any
forall wX wY. String -> String -> String -> PrimOf p wX wY
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)
  IO (Repository 'RO p wU wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wU wR) -> IO ())
-> IO (Repository 'RO p wU wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
setprefCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"impossible case"