--  Copyright (C) 2002-2005 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.

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Darcs.UI.Commands.Revert ( revert, clean ) where

import Darcs.Prelude

import Control.Monad ( unless, when, void )

import Darcs.UI.Flags
    ( DarcsFlag
    , diffAlgorithm
    , diffingOpts
    , isInteractive
    , pathSetFromArgs
    , umask
    , useCache
    )
import Darcs.UI.Options ( (^), (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInHashedRepository
    , commandAlias
    , nodefaults
    , putInfo
    , putFinished
    , withStdOpts
    )
import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )
import Darcs.Repository.Unrevert ( writeUnrevert )
import Darcs.UI.Completion ( modifiedFileArgs )

import Darcs.Util.Global ( debugMessage )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer ( Doc, formatWords, vsep )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Repository
    ( RepoJob(..)
    , addToPending
    , finalizeRepositoryChanges
    , applyToWorking
    , readPatches
    , unrecordedChanges
    , withRepoLock
    )
import Darcs.Patch ( invert, commuteFL )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , (:>)(..)
    , nullFL
    , (+>>+)
    , reverseFL
    )
import Darcs.UI.SelectChanges
    ( WhichChanges(Last)
    , selectionConfigPrim
    , runInvertibleSelection
    )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )


revertDescription :: String
revertDescription :: String
revertDescription = String
"Discard unrecorded changes."

revertHelp :: Doc
revertHelp :: Doc
revertHelp = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"The `darcs revert` command discards unrecorded changes in the working"
    , String
"tree.  As with `darcs record`, you will be asked which hunks (changes)"
    , String
"to revert.  The `--all` switch can be used to avoid such prompting. If"
    , String
"files or directories are specified, other parts of the working tree"
    , String
"are not reverted."
    ]
  , [ String
"In you accidentally reverted something you wanted to keep (for"
    , String
"example, typing `darcs rev -a` instead of `darcs rec -a`), you can"
    , String
"immediately run `darcs unrevert` to restore it.  This is only"
    , String
"guaranteed to work if the repository has not changed since `darcs"
    , String
"revert` ran."
    ]
  ]

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
flags = S.PatchSelectionOptions
    { verbosity :: Verbosity
S.verbosity = PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
O.verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
    , matchFlags :: [MatchFlag]
S.matchFlags = []
    , interactive :: Bool
S.interactive = Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
flags
    , selectDeps :: SelectDeps
S.selectDeps = SelectDeps
O.PromptDeps -- option not supported, use default
    , withSummary :: WithSummary
S.withSummary = WithSummary
O.NoSummary -- option not supported, use default
    }

revert :: DarcsCommand
revert :: DarcsCommand
revert = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"revert"
    , commandHelp :: Doc
commandHelp = Doc
revertHelp
    , commandDescription :: String
commandDescription = String
revertDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[FILE or DIRECTORY]..."]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
revertCmd
    , 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]
modifiedFileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
opts
    }
  where
    basicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
basicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool)
PrimDarcsOption (Maybe Bool)
O.interactive -- True
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> LookForAdds -> a)
     (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> LookForAdds -> a)
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> LookForAdds -> a)
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (LookForAdds -> a)
     (DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (LookForAdds -> a)
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (LookForAdds -> a)
  (DiffAlgorithm -> LookForAdds -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (LookForAdds -> a)
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ LookForAdds -> PrimDarcsOption LookForAdds
O.maybelookforadds LookForAdds
O.NoLookForAdds
    advancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
advancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    opts :: CommandOptions
opts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> LookForAdds
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> 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
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> LookForAdds
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
basicOpts DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
advancedOpts

revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
revertCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args =
  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
    Maybe [AnchoredPath]
existing_paths <- Repository 'RW p wU wR
-> Maybe [AnchoredPath] -> IO (Maybe [AnchoredPath])
forall {p :: * -> * -> *} {rt :: AccessType} {wU} {wR}.
(ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, Check p,
 Conflict p, Effect p, FromPrim p, IsHunk p, Merge p,
 PrimPatchBase p, Summary p, ToPrim p, Unwind p, PatchInspect p,
 RepairToFL p, Commute p, Eq2 p, ReadPatch p, ShowPatch p,
 ShowContextPatch p, PatchListFormat p) =>
Repository rt p wU wR
-> Maybe [AnchoredPath] -> IO (Maybe [AnchoredPath])
existingPaths Repository 'RW p wU wR
_repository (Maybe [AnchoredPath] -> IO (Maybe [AnchoredPath]))
-> IO (Maybe [AnchoredPath]) -> IO (Maybe [AnchoredPath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AbsolutePath, AbsolutePath)
-> [String] -> IO (Maybe [AnchoredPath])
pathSetFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
    Verbosity -> Maybe [AnchoredPath] -> String -> IO ()
announceFiles Verbosity
verbosity Maybe [AnchoredPath]
existing_paths String
"Reverting changes in"
    FL (PrimOf p) wR wU
changes <- DiffOpts
-> Repository 'RW p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges DiffOpts
diffOpts Repository 'RW p wU wR
_repository Maybe [AnchoredPath]
existing_paths
    case FL (PrimOf p) wR wU
changes of
      FL (PrimOf p) wR wU
NilFL -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"There are no changes to revert!"
      FL (PrimOf p) wR wU
_ -> do
        let selection_config :: SelectionConfig (PrimOf p)
selection_config =
              WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PrimOf p))
-> Maybe [AnchoredPath]
-> SelectionConfig (PrimOf p)
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> SelectionConfig prim
selectionConfigPrim WhichChanges
Last String
"revert" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts)
                (Splitter (PrimOf p) -> Maybe (Splitter (PrimOf p))
forall a. a -> Maybe a
Just (DiffAlgorithm -> Splitter (PrimOf p)
forall (prim :: * -> * -> *).
PrimPatch prim =>
DiffAlgorithm -> Splitter prim
reversePrimSplitter (PrimOptSpec DarcsOptDescr DarcsFlag a DiffAlgorithm
PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)))
                Maybe [AnchoredPath]
existing_paths
        FL (PrimOf p) wR wZ
norevert :> FL (PrimOf p) wZ wU
torevert <- FL (PrimOf p) wR wU
-> SelectionConfig (PrimOf p)
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall (p :: * -> * -> *) wX wY.
(Invert p, MatchableRP p, ShowPatch p, ShowContextPatch p,
 ApplyState p ~ Tree) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runInvertibleSelection FL (PrimOf p) wR wU
changes SelectionConfig (PrimOf p)
selection_config
        if FL (PrimOf p) wZ wU -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wZ wU
torevert
          then
            [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
              Doc
"If you don't want to revert after all, that's fine with me!"
          else do
            IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wZ -> 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 DiffOpts
diffOpts (FL (PrimOf p) wU wZ -> IO ()) -> FL (PrimOf p) wU wZ -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ wU -> FL (PrimOf p) wU wZ
forall wX wY. FL (PrimOf p) wX wY -> FL (PrimOf p) wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wZ wU
torevert
              String -> IO ()
debugMessage String
"About to write the unrevert file."
              {- The user has split unrecorded into the sequence 'norevert'
                 then 'torevert', which is natural as the bit we keep in
                 unrecorded should have pristine as the context.

                 But the unrevert patch also needs to have pristine as the
                 context, not unrecorded (which can be changed by the user
                 at any time).

                 So we need to commute 'torevert' with 'norevert', and if
                 that fails then we need to keep some of 'norevert' in the
                 actual unrevert patch so it still makes sense. The use of
                 genCommuteWhatWeCanRL minimises the amount of 'norevert'
                 that we need to keep.
              -}
              case CommuteFn (PrimOf p) (FL (PrimOf p))
-> (:>) (RL (PrimOf p)) (FL (PrimOf p)) wR wU
-> (:>) (RL (PrimOf p)) (FL (PrimOf p) :> RL (PrimOf p)) wR wU
forall (p :: * -> * -> *) (q :: * -> * -> *) wX wY.
Commute p =>
CommuteFn p q
-> (:>) (RL p) q wX wY -> (:>) (RL p) (q :> RL p) wX wY
genCommuteWhatWeCanRL (:>) (PrimOf p) (FL (PrimOf p)) wX wY
-> Maybe ((:>) (FL (PrimOf p)) (PrimOf p) wX wY)
CommuteFn (PrimOf p) (FL (PrimOf p))
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (FL (PrimOf p) wR wZ -> RL (PrimOf p) wR wZ
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) wR wZ
norevert RL (PrimOf p) wR wZ
-> FL (PrimOf p) wZ wU
-> (:>) (RL (PrimOf p)) (FL (PrimOf p)) wR wU
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wZ wU
torevert) of
                RL (PrimOf p) wR wZ
deps :> FL (PrimOf p) wZ wZ
torevert' :> RL (PrimOf p) wZ wU
_ -> do
                  PatchSet p Origin wR
recorded <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
_repository
                  PatchSet p Origin wR -> FL (PrimOf p) wR wZ -> IO ()
forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert PatchSet p Origin wR
recorded (RL (PrimOf p) wR wZ
deps RL (PrimOf p) wR wZ -> FL (PrimOf p) wZ wZ -> FL (PrimOf p) wR wZ
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> FL p wX wZ
+>>+ FL (PrimOf p) wZ wZ
torevert')
              Repository 'RO p wU wR
_repository <-
                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)
              String -> IO ()
debugMessage String
"About to apply to the working tree."
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (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)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IO (Repository 'RO p wZ wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wZ wR) -> IO ())
-> IO (Repository 'RO p wZ wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR
-> Verbosity -> FL (PrimOf p) wU wZ -> IO (Repository 'RO p wZ wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository 'RO p wU wR
_repository Verbosity
verbosity (FL (PrimOf p) wZ wU -> FL (PrimOf p) wU wZ
forall wX wY. FL (PrimOf p) wX wY -> FL (PrimOf p) wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wZ wU
torevert)
            [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts String
"reverting"
  where
    verbosity :: Verbosity
verbosity = PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
O.verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
    diffOpts :: DiffOpts
diffOpts = [DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts
    existingPaths :: Repository rt p wU wR
-> Maybe [AnchoredPath] -> IO (Maybe [AnchoredPath])
existingPaths Repository rt p wU wR
repo Maybe [AnchoredPath]
paths = do
      Maybe ([AnchoredPath], [AnchoredPath])
paths' <- ([AnchoredPath] -> IO ([AnchoredPath], [AnchoredPath]))
-> Maybe [AnchoredPath]
-> IO (Maybe ([AnchoredPath], [AnchoredPath]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Repository rt p wU wR
-> Verbosity
-> DiffOpts
-> [AnchoredPath]
-> IO ([AnchoredPath], [AnchoredPath])
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> Verbosity
-> DiffOpts
-> [AnchoredPath]
-> IO ([AnchoredPath], [AnchoredPath])
filterExistingPaths Repository rt p wU wR
repo Verbosity
verbosity DiffOpts
diffOpts) Maybe [AnchoredPath]
paths
      let paths'' :: Maybe [AnchoredPath]
paths'' = (([AnchoredPath], [AnchoredPath]) -> [AnchoredPath])
-> Maybe ([AnchoredPath], [AnchoredPath]) -> Maybe [AnchoredPath]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([AnchoredPath], [AnchoredPath]) -> [AnchoredPath]
forall a b. (a, b) -> b
snd Maybe ([AnchoredPath], [AnchoredPath])
paths'
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [AnchoredPath]
paths'' Maybe [AnchoredPath] -> Maybe [AnchoredPath] -> Bool
forall a. Eq a => a -> a -> Bool
== [AnchoredPath] -> Maybe [AnchoredPath]
forall a. a -> Maybe a
Just []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"None of the paths you specified exist."
      Maybe [AnchoredPath] -> IO (Maybe [AnchoredPath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [AnchoredPath]
paths''

-- | An alias for 'revert -l' i.e. remove every (non-boring) file or change
-- that is not in pristine.
clean :: DarcsCommand
clean :: DarcsCommand
clean = DarcsCommand
alias
    { commandDescription = desc
    , commandHelp = vsep $ map formatWords
        [ [ "Remove unrecorded changes from the working tree."
          ]
        , [ "This is an alias for `darcs revert -l/--look-for-adds` which"
          , "means it works also on files that have not been added."
          , "You can additionally pass `--boring` to get rid of *every*"
          , "unrecorded file or directory."
          ]
        , [ "See description of `darcs revert` for more details."
          ]
        ]
    , commandOptions = opts
    }
  where
    alias :: DarcsCommand
alias = String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias String
"clean" Maybe DarcsCommand
forall a. Maybe a
Nothing DarcsCommand
revert
    desc :: String
desc = String
"Alias for `darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand -> String
commandName DarcsCommand
revert String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -l`."
    basicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
basicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool)
PrimDarcsOption (Maybe Bool)
O.interactive -- True
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> LookForAdds -> a)
     (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> LookForAdds -> a)
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> LookForAdds -> a)
  (Maybe String -> DiffAlgorithm -> LookForAdds -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> LookForAdds -> a)
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (LookForAdds -> a)
     (DiffAlgorithm -> LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (LookForAdds -> a)
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (LookForAdds -> a)
  (DiffAlgorithm -> LookForAdds -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (LookForAdds -> a)
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (LookForAdds -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ LookForAdds -> PrimDarcsOption LookForAdds
O.maybelookforadds LookForAdds
O.YesLookForAdds
    advancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
advancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    opts :: CommandOptions
opts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> LookForAdds
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> 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
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> LookForAdds
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> LookForAdds -> a)
basicOpts DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
advancedOpts