--  Copyright (C) 2002-2004 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.Remove ( remove, rm, unadd ) where

import Darcs.Prelude

import Control.Monad ( when, foldM, void )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , withStdOpts, nodefaults
    , commandAlias, commandStub
    , putWarning, putInfo
    , amInHashedRepository
    )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag, diffingOpts
    , useCache, umask, diffAlgorithm, pathsFromArgs )
import Darcs.UI.Options ( (^), parseFlags, (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository
    ( Repository
    , withRepoLock
    , RepoJob(..)
    , addToPending
    , finalizeRepositoryChanges
    , readPristineAndPending
    , readUnrecorded
    )
import Darcs.Repository.Diff( treeDiff )

import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile,
                     listTouchedFiles )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )
import Darcs.Repository.Prefs ( filetypeFunction, FileType )
import Darcs.Util.Tree( Tree, TreeItem(..), explodePaths )
import qualified Darcs.Util.Tree as T ( find, modifyTree, expand, list )
import Darcs.Util.Path( AnchoredPath, displayPath, isRoot, AbsolutePath )
import Darcs.Util.Printer ( Doc, text, vcat )

removeDescription :: String
removeDescription :: String
removeDescription = String
"Remove files from version control."

removeHelp :: Doc
removeHelp :: Doc
removeHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"The `darcs remove` command exists primarily for symmetry with `darcs\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"add`, as the normal way to remove a file from version control is\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"simply to delete it from the working tree.  This command is only\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"useful in the unusual case where one wants to record a removal patch\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"WITHOUT deleting the copy in the working tree (which can be re-added).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Note that applying a removal patch to a repository (e.g. by pulling\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"the patch) will ALWAYS affect the working tree of that repository.\n"

remove :: DarcsCommand
remove :: DarcsCommand
remove = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"remove"
    , commandHelp :: Doc
commandHelp = Doc
removeHelp
    , commandDescription :: String
commandDescription = String
removeDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<FILE or DIRECTORY> ..."]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
removeCmd
    , 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]
knownFileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
removeOpts
    }
  where
    removeBasicOpts :: OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> a)
removeBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag (Bool -> a) (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec DarcsOptDescr DarcsFlag (Bool -> a) (Maybe String)
-> OptSpec DarcsOptDescr DarcsFlag a (Bool -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> 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 a (Bool -> a)
PrimDarcsOption Bool
O.recursive
    removeAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
removeAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    removeOpts :: CommandOptions
removeOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> a)
removeBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> 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
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
removeAdvancedOpts

removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
removeCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
relargs = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
relargs) (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
"Nothing specified, nothing removed."
    [AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
relargs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredPath -> Bool
isRoot [AnchoredPath]
paths) (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
"Cannot remove a repository's root directory!"
    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
        Tree IO
recorded_and_pending <- Repository 'RW p wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository 'RW p wU wR
repository
        let exploded_paths :: [AnchoredPath]
exploded_paths =
              (if PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.recursive [DarcsFlag]
opts
                then [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a]
reverse ([AnchoredPath] -> [AnchoredPath])
-> ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath]
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> [AnchoredPath] -> [AnchoredPath]
explodePaths Tree IO
recorded_and_pending
                else [AnchoredPath] -> [AnchoredPath]
forall a. a -> a
id) [AnchoredPath]
paths
        Sealed FL (PrimOf p) wU wX
p <- [DarcsFlag]
-> Repository 'RW p wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch [DarcsFlag]
opts Repository 'RW p wU wR
repository [AnchoredPath]
exploded_paths
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FL (PrimOf p) wU wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wU wX
p Bool -> Bool -> Bool
&& Bool -> Bool
not ([AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths)) (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
"No files were removed."
        Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wX -> 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) FL (PrimOf p) wU wX
p
        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)
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([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
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [String
"Will stop tracking:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath (FL (PrimOf p) wU wX -> [AnchoredPath]
forall wX wY. FL (PrimOf p) wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimOf p) wU wX
p)

-- | makeRemovePatch builds a list of patches to remove the given filepaths.
--   This function does not recursively process directories. The 'Recursive'
--   flag should be handled by the caller by adding all offspring of a directory
--   to the files list.
makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)
                => [DarcsFlag] -> Repository rt p wU wR
                -> [AnchoredPath] -> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch [DarcsFlag]
opts Repository rt p wU wR
repository [AnchoredPath]
files = do
  Tree IO
recorded <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
T.expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repository rt p wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository rt p wU wR
repository
  Tree IO
unrecorded <- Repository rt p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository rt p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (Maybe [AnchoredPath] -> IO (Tree IO))
-> Maybe [AnchoredPath] -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ [AnchoredPath] -> Maybe [AnchoredPath]
forall a. a -> Maybe a
Just [AnchoredPath]
files
  String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
  (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
result <- ((String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
 -> AnchoredPath
 -> IO
      (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))]))
-> (String -> FileType, Tree IO, Tree IO,
    [FreeLeft (FL (PrimOf p))])
-> [AnchoredPath]
-> IO
     (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
-> AnchoredPath
-> IO
     (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
forall {prim :: * -> * -> *}.
(Annotate prim, CleanMerge prim, IsHunk prim, PatchInspect prim,
 RepairToFL prim, Show2 prim, PrimConstruct prim, PrimCoalesce prim,
 PrimDetails prim, PrimApply prim, PrimSift prim,
 PrimMangleUnravelled prim, ReadPatch prim, ShowPatch prim,
 ShowContextPatch prim, PatchListFormat prim) =>
(String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
-> AnchoredPath
-> IO (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
removeOnePath (String -> FileType
ftf, Tree IO
recorded, Tree IO
unrecorded, []) [AnchoredPath]
files
  case (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
result of
    (String -> FileType
_, Tree IO
_, Tree IO
_, [FreeLeft (FL (PrimOf p))]
patches) ->
      Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU)))
-> Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a b. (a -> b) -> a -> b
$
      FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wU)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wU))
-> FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wU)
forall a b. (a -> b) -> a -> b
$ [FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
[w (FL p)] -> w (FL p)
concatGapsFL ([FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (PrimOf p)))
-> [FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (PrimOf p))
forall a b. (a -> b) -> a -> b
$ [FreeLeft (FL (PrimOf p))] -> [FreeLeft (FL (PrimOf p))]
forall a. [a] -> [a]
reverse [FreeLeft (FL (PrimOf p))]
patches
  where
    removeOnePath :: (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
-> AnchoredPath
-> IO (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
removeOnePath (String -> FileType
ftf, Tree IO
recorded, Tree IO
unrecorded, [FreeLeft (FL prim)]
patches) AnchoredPath
f = do
      let recorded' :: Tree IO
recorded' = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
T.modifyTree Tree IO
recorded AnchoredPath
f Maybe (TreeItem IO)
forall a. Maybe a
Nothing
          unrecorded' :: Tree IO
unrecorded' = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
T.modifyTree Tree IO
unrecorded AnchoredPath
f Maybe (TreeItem IO)
forall a. Maybe a
Nothing
      Maybe (FreeLeft (FL prim))
local <- [DarcsFlag]
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> Tree IO
-> AnchoredPath
-> IO (Maybe (FreeLeft (FL prim)))
forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> Tree IO
-> AnchoredPath
-> IO (Maybe (FreeLeft (FL prim)))
makeRemoveGap [DarcsFlag]
opts String -> FileType
ftf Tree IO
recorded Tree IO
unrecorded Tree IO
unrecorded' AnchoredPath
f
      -- we can tell if the remove succeeded by looking if local is
      -- empty. If the remove succeeded, we should pass on updated
      -- recorded and unrecorded that reflect the removal
      (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
-> IO (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
 -> IO (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)]))
-> (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
-> IO (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL prim)])
forall a b. (a -> b) -> a -> b
$
        case Maybe (FreeLeft (FL prim))
local of
          Just FreeLeft (FL prim)
gap -> (String -> FileType
ftf, Tree IO
recorded', Tree IO
unrecorded', FreeLeft (FL prim)
gap FreeLeft (FL prim) -> [FreeLeft (FL prim)] -> [FreeLeft (FL prim)]
forall a. a -> [a] -> [a]
: [FreeLeft (FL prim)]
patches)
          Maybe (FreeLeft (FL prim))
_ -> (String -> FileType
ftf, Tree IO
recorded, Tree IO
unrecorded, [FreeLeft (FL prim)]
patches)

-- | Takes a file path and returns the FL of patches to remove that, wrapped in
--   a 'Gap'.
--   Returns 'Nothing' in case the path cannot be removed (if it is not tracked,
--   or if it's a directory and it's not tracked).
--   The three 'Tree' arguments are the recorded state, the unrecorded state
--   excluding the removal of this file, and the unrecorded state including the
--   removal of this file.
makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)
                -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath
                -> IO (Maybe (FreeLeft (FL prim)))
makeRemoveGap :: forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> Tree IO
-> AnchoredPath
-> IO (Maybe (FreeLeft (FL prim)))
makeRemoveGap [DarcsFlag]
opts String -> FileType
ftf Tree IO
recorded Tree IO
unrecorded Tree IO
unrecorded' AnchoredPath
path =
    case (Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
T.find Tree IO
recorded AnchoredPath
path, Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
T.find Tree IO
unrecorded AnchoredPath
path) of
        (Just (SubTree Tree IO
_), Just (SubTree Tree IO
unrecordedChildren)) ->
            if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, TreeItem IO)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
T.list Tree IO
unrecordedChildren)
              then String -> IO (Maybe (FreeLeft (FL prim)))
forall {a}. String -> IO (Maybe a)
skipAndWarn String
"it is not empty"
              else Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim))))
-> Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a b. (a -> b) -> a -> b
$ FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (AnchoredPath -> prim wX wY
forall wX wY. AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
rmdir AnchoredPath
path prim wX wY -> FL prim wY wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
        (Just (File Blob IO
_), Just (File Blob IO
_)) -> do
            FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> IO (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL prim))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff (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) String -> FileType
ftf Tree IO
unrecorded Tree IO
unrecorded'
        (Just (File Blob IO
_), Maybe (TreeItem IO)
_) ->
            Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim))))
-> Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a b. (a -> b) -> a -> b
$ FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (AnchoredPath -> prim wX Any
forall wX wY. AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
addfile AnchoredPath
path prim wX Any -> FL prim Any wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: AnchoredPath -> prim Any wY
forall wX wY. AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
rmfile AnchoredPath
path prim Any wY -> FL prim wY wY -> FL prim Any wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
        (Just (SubTree Tree IO
_), Maybe (TreeItem IO)
_) ->
            Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim))))
-> Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall a b. (a -> b) -> a -> b
$ FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (AnchoredPath -> prim wX Any
forall wX wY. AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
adddir AnchoredPath
path prim wX Any -> FL prim Any wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: AnchoredPath -> prim Any wY
forall wX wY. AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
rmdir AnchoredPath
path prim Any wY -> FL prim wY wY -> FL prim Any wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
        (Maybe (TreeItem IO)
_, Maybe (TreeItem IO)
_) -> String -> IO (Maybe (FreeLeft (FL prim)))
forall {a}. String -> IO (Maybe a)
skipAndWarn String
"it is not tracked by darcs"
  where skipAndWarn :: String -> IO (Maybe a)
skipAndWarn String
reason =
            do [DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Can't remove " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
path
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
               Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing


rmDescription :: String
rmDescription :: String
rmDescription = String
"Help newbies find `darcs remove'."

rmHelp :: Doc
rmHelp :: Doc
rmHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"The `darcs rm' command does nothing.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"The normal way to remove a file from version control is simply to\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"delete it from the working tree.  To remove a file from version\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"control WITHOUT affecting the working tree, see `darcs remove'.\n"

rm :: DarcsCommand
rm :: DarcsCommand
rm = String -> Doc -> String -> DarcsCommand -> DarcsCommand
commandStub String
"rm" Doc
rmHelp String
rmDescription DarcsCommand
remove

unadd :: DarcsCommand
unadd :: DarcsCommand
unadd = String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias String
"unadd" Maybe DarcsCommand
forall a. Maybe a
Nothing DarcsCommand
remove