--  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 )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , withStdOpts, nodefaults
    , commandAlias, commandStub
    , putWarning, putInfo
    , amInHashedRepository
    )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, quiet, pathsFromArgs )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository.Flags ( UpdatePending (..) )
import Darcs.Repository
    ( Repository
    , withRepoLock
    , RepoJob(..)
    , addToPending
    , readRecordedAndPending
    , 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(..), (+>+), 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 :: 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
"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
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UseIndex -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UseIndex -> UMask -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
removeAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Bool -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Bool -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> a)
removeBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> 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
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
removeOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> 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
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
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 :: OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
removeAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) UseIndex
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> 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 (UMask -> a)
PrimDarcsOption UMask
O.umask
    removeOpts :: DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
removeOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> a)
removeBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseIndex
      -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> Bool
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseIndex
      -> 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)
  (UseIndex
   -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
relargs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot remove a repository's root directory!"
    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 (PrimDarcsOption UMask
umask PrimDarcsOption 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
        Tree IO
recorded_and_pending <- Repository rt p wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR 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 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 rt p wR wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wR wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch [DarcsFlag]
opts Repository rt p wR wU wR
repository [AnchoredPath]
exploded_paths
        -- TODO whether command fails depends on verbosity BAD BAD BAD
        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 (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths) Bool -> Bool -> Bool
&& Bool -> Bool
not ([DarcsFlag] -> Bool
quiet [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No files were removed."
        Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wX -> 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) FL (PrimOf p) wU wX
p
        [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 (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 wR wU wR
                -> [AnchoredPath] -> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch :: [DarcsFlag]
-> Repository rt p wR wU wR
-> [AnchoredPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch [DarcsFlag]
opts Repository rt p wR 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 wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repository
                             Tree IO
unrecorded <- Repository rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded 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) (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 :: * -> * -> *).
(CleanMerge prim, Commute prim, Invert prim, Eq2 prim, IsHunk prim,
 PatchInspect prim, RepairToFL prim, Show2 prim, PrimConstruct prim,
 PrimCanonize prim, PrimClassify 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 (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)) -> FreeLeft (FL (PrimOf p)))
-> FreeLeft (FL (PrimOf p))
-> [FreeLeft (FL (PrimOf p))]
-> FreeLeft (FL (PrimOf p))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((forall wX wY wZ.
 FL (PrimOf p) wX wY -> FL (PrimOf p) wY wZ -> FL (PrimOf p) wX wZ)
-> FreeLeft (FL (PrimOf p))
-> FreeLeft (FL (PrimOf p))
-> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *)
       (q :: * -> * -> *) (r :: * -> * -> *).
Gap w =>
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> w p -> w q -> w r
joinGap forall wX wY wZ.
FL (PrimOf p) wX wY -> FL (PrimOf p) wY wZ -> FL (PrimOf p) wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+)) ((forall wX. FL (PrimOf p) wX wX) -> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) ([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 (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 :: [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 (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 (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 (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (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 (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 (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 (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 (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (AnchoredPath -> prim wX Any
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 (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 (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 (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (AnchoredPath -> prim wX Any
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 (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 (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