--  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 Prelude ()
import Darcs.Prelude

import Control.Monad ( when, foldM )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , withStdOpts, nodefaults
    , commandAlias, commandStub
    , putWarning, putInfo
    , amInHashedRepository
    )
import Darcs.UI.Commands.Util ( expandDirs )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, quiet )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..) )
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(..), find, modifyTree, expand, list )
import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn
                      , AbsolutePath, floatPath )
import Darcs.Util.Printer ( text, vcat )

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

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

remove :: DarcsCommand [DarcsFlag]
remove :: DarcsCommand [DarcsFlag]
remove = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "remove"
    , commandHelp :: String
commandHelp = String
removeHelp
    , commandDescription :: String
commandDescription = String
removeDescription
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["<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 (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
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
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
removeOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> 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
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
removeOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> 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 :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
removeAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
    removeOpts :: DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
removeOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> Bool -> a)
removeBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> Bool
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UMask
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
removeAdvancedOpts

removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
removeCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts relargs :: [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 "Nothing specified, nothing removed."
    [SubPath]
origfiles <- (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
relargs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SubPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubPath]
origfiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No valid arguments were given."
    DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> 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) UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
        [SubPath]
args <- 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 [SubPath] -> [SubPath]
forall a. [a] -> [a]
reverse ([SubPath] -> [SubPath]) -> IO [SubPath] -> IO [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Bool -> [SubPath] -> IO [SubPath]
expandDirs Bool
False [SubPath]
origfiles
                else [SubPath] -> IO [SubPath]
forall (m :: * -> *) a. Monad m => a -> m a
return [SubPath]
origfiles
        Sealed p :: FL (PrimOf p) wU wX
p <- [DarcsFlag]
-> Repository rt p wR wU wR
-> [SubPath]
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wR wU wT
-> [SubPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch [DarcsFlag]
opts Repository rt p wR wU wR
repository [SubPath]
args
        -- 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 ([SubPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubPath]
origfiles) 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 "No files were removed."
        Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking 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
$ ["Will stop tracking:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ FL (PrimOf p) wU wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
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 wT
                -> [SubPath] -> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch :: [DarcsFlag]
-> Repository rt p wR wU wT
-> [SubPath]
-> IO (Sealed (FL (PrimOf p) wU))
makeRemovePatch opts :: [DarcsFlag]
opts repository :: Repository rt p wR wU wT
repository files :: [SubPath]
files =
                          do Tree IO
recorded <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
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 wT -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wT
repository
                             Tree IO
unrecorded <- Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wT
repository (Maybe [SubPath] -> IO (Tree IO))
-> Maybe [SubPath] -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ [SubPath] -> Maybe [SubPath]
forall a. a -> Maybe a
Just [SubPath]
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 :: * -> * -> *).
PrimPatch 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]
 -> IO
      (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))]))
-> [AnchoredPath]
-> IO
     (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
forall a b. (a -> b) -> a -> b
$ (SubPath -> AnchoredPath) -> [SubPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath
floatPath (String -> AnchoredPath)
-> (SubPath -> String) -> SubPath -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
fn2fp (FileName -> String) -> (SubPath -> FileName) -> SubPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FileName
sp2fn) [SubPath]
files
                             case (String -> FileType, Tree IO, Tree IO, [FreeLeft (FL (PrimOf p))])
result of
                                 (_, _, _, patches :: [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 (ftf :: String -> FileType
ftf, recorded :: Tree IO
recorded, unrecorded :: Tree IO
unrecorded, patches :: [FreeLeft (FL prim)]
patches) f :: 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
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
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 gap :: 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)
                       _        -> (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 opts :: [DarcsFlag]
opts ftf :: String -> FileType
ftf recorded :: Tree IO
recorded unrecorded :: Tree IO
unrecorded unrecorded' :: Tree IO
unrecorded' f :: AnchoredPath
f =
    case (Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
recorded AnchoredPath
f, Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
unrecorded AnchoredPath
f) of
        (Just (SubTree _), Just (SubTree unrecordedChildren :: 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)]
list Tree IO
unrecordedChildren)
              then String -> IO (Maybe (FreeLeft (FL prim)))
forall a. String -> IO (Maybe a)
skipAndWarn "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 (String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
rmdir String
f_fp 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 _), Just (File _)) -> 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 _), _) ->
            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 (String -> prim wX Any
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
addfile String
f_fp 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
:>: String -> prim Any wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
rmfile String
f_fp 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 _), _) ->
            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 (String -> prim wX Any
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
adddir String
f_fp 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
:>: String -> prim Any wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
rmdir String
f_fp 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)
        (_, _) -> String -> IO (Maybe (FreeLeft (FL prim)))
forall a. String -> IO (Maybe a)
skipAndWarn "it is not tracked by darcs"
  where f_fp :: String
f_fp = String -> AnchoredPath -> String
anchorPath "" AnchoredPath
f
        skipAndWarn :: String -> IO (Maybe a)
skipAndWarn reason :: 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
$ "Can't remove " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f_fp
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
               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 = "Help newbies find `darcs remove'."

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

rm :: DarcsCommand [DarcsFlag]
rm :: DarcsCommand [DarcsFlag]
rm = String
-> String
-> String
-> DarcsCommand [DarcsFlag]
-> DarcsCommand [DarcsFlag]
forall pf.
String -> String -> String -> DarcsCommand pf -> DarcsCommand pf
commandStub "rm" String
rmHelp String
rmDescription DarcsCommand [DarcsFlag]
remove

unadd :: DarcsCommand [DarcsFlag]
unadd :: DarcsCommand [DarcsFlag]
unadd = String
-> Maybe (DarcsCommand [DarcsFlag])
-> DarcsCommand [DarcsFlag]
-> DarcsCommand [DarcsFlag]
forall pf.
String
-> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias "unadd" Maybe (DarcsCommand [DarcsFlag])
forall a. Maybe a
Nothing DarcsCommand [DarcsFlag]
remove