{-# LANGUAGE RankNTypes #-}
module Darcs.UI.Commands.Move ( move, mv ) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when, unless, forM_, forM )
import Data.Maybe ( fromMaybe )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository
, putInfo
)
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
( DarcsFlag
, allowCaseDifferingFilenames, allowWindowsReservedFilenames
, useCache, dryRun, umask
, maybeFixSubPaths, fixSubPaths
)
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex )
import Darcs.Repository
( Repository
, withRepoLock
, RepoJob(..)
, addPendingDiffToPending
)
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft )
import Darcs.Util.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, PrimPatch )
import Darcs.Patch.Apply( ApplyState )
import Data.List ( nub, sort )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile )
import Darcs.Util.Tree( Tree, modifyTree )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Path
( floatPath
, fp2fn
, fn2fp
, superName
, SubPath()
, toFilePath
, AbsolutePath
)
import Darcs.Util.Printer ( text, hsep )
import Darcs.Util.Workaround ( renameFile )
moveDescription :: String
moveDescription :: String
moveDescription = "Move or rename files."
moveHelp :: String
moveHelp :: String
moveHelp =
"Darcs cannot reliably distinguish between a file being deleted and a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"new one added, and a file being moved. Therefore Darcs always assumes\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"the former, and provides the `darcs mv` command to let Darcs know when\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"you want the latter. This command will also move the file in the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"working tree (unlike `darcs remove`), unless it has already been moved.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Darcs will not rename a file if another file in the same folder has\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"the same name, except for case. The `--case-ok` option overrides this\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"behaviour. Windows and OS X usually use filesystems that do not allow\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"files a folder to have the same name except for case (for example,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"unusable on those systems!\n"
move :: DarcsCommand [DarcsFlag]
move :: DarcsCommand [DarcsFlag]
move = 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 = "move"
, commandHelp :: String
commandHelp = String
moveHelp
, commandDescription :: String
commandDescription = String
moveDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd
, 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
moveAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Maybe String -> Any)
forall a.
OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Bool
-> Bool
-> Maybe String
-> 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]
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
moveOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(Bool
-> Bool
-> Maybe String
-> 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
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
moveOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Bool
-> Bool
-> Maybe String
-> 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]
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
moveOpts
}
where
moveBasicOpts :: OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts = DarcsOption (Maybe String -> a) (Bool -> Bool -> Maybe String -> a)
forall a. DarcsOption a (Bool -> Bool -> a)
O.allowProblematicFilenames DarcsOption (Maybe String -> a) (Bool -> Bool -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> 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 (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
moveAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
moveOpts :: DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
moveOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> 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
moveAdvancedOpts
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args
| [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 =
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "The `darcs move' command requires at least two arguments."
| [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = do
[Maybe SubPath]
xs <- (AbsolutePath, AbsolutePath) -> [String] -> IO [Maybe SubPath]
maybeFixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args
case [Maybe SubPath]
xs of
[Just from :: SubPath
from, Just to :: SubPath
to]
| SubPath
from SubPath -> SubPath -> Bool
forall a. Eq a => a -> a -> Bool
== SubPath
to -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot rename a file or directory onto itself."
| SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
from String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot move the root of the repository."
| Bool
otherwise -> [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile [DarcsFlag]
opts SubPath
from SubPath
to
_ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Both source and destination must be valid."
| Bool
otherwise = let (froms :: [String]
froms, to :: String
to) = ([String] -> [String]
forall a. [a] -> [a]
init [String]
args, [String] -> String
forall a. [a] -> a
last [String]
args) in do
Maybe SubPath
x <- [Maybe SubPath] -> Maybe SubPath
forall a. [a] -> a
head ([Maybe SubPath] -> Maybe SubPath)
-> IO [Maybe SubPath] -> IO (Maybe SubPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [Maybe SubPath]
maybeFixSubPaths (AbsolutePath, AbsolutePath)
fps [String
to]
case Maybe SubPath
x of
Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Invalid destination directory."
Just to' :: SubPath
to' -> do
[SubPath]
xs <- [SubPath] -> [SubPath]
forall a. Eq a => [a] -> [a]
nub ([SubPath] -> [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
sort ([SubPath] -> [SubPath]) -> IO [SubPath] -> IO [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
froms
if SubPath
to' SubPath -> [SubPath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SubPath]
xs
then String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot rename a file or directory onto itself."
else case [SubPath]
xs of
[] -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Nothing to move."
froms' :: [SubPath]
froms' ->
if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((SubPath -> Bool) -> [SubPath] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (SubPath -> String) -> SubPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath) [SubPath]
froms') then
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot move the root of the repository."
else
[DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir [DarcsFlag]
opts [SubPath]
froms' SubPath
to'
data FileKind = Dir | File
deriving (Int -> FileKind -> String -> String
[FileKind] -> String -> String
FileKind -> String
(Int -> FileKind -> String -> String)
-> (FileKind -> String)
-> ([FileKind] -> String -> String)
-> Show FileKind
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileKind] -> String -> String
$cshowList :: [FileKind] -> String -> String
show :: FileKind -> String
$cshow :: FileKind -> String
showsPrec :: Int -> FileKind -> String -> String
$cshowsPrec :: Int -> FileKind -> String -> String
Show, FileKind -> FileKind -> Bool
(FileKind -> FileKind -> Bool)
-> (FileKind -> FileKind -> Bool) -> Eq FileKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileKind -> FileKind -> Bool
$c/= :: FileKind -> FileKind -> Bool
== :: FileKind -> FileKind -> Bool
$c== :: FileKind -> FileKind -> Bool
Eq)
data FileStatus =
Nonexistant
| Unadded FileKind
| Shadow FileKind
| Known FileKind
deriving Int -> FileStatus -> String -> String
[FileStatus] -> String -> String
FileStatus -> String
(Int -> FileStatus -> String -> String)
-> (FileStatus -> String)
-> ([FileStatus] -> String -> String)
-> Show FileStatus
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileStatus] -> String -> String
$cshowList :: [FileStatus] -> String -> String
show :: FileStatus -> String
$cshow :: FileStatus -> String
showsPrec :: Int -> FileStatus -> String -> String
$cshowsPrec :: Int -> FileStatus -> String -> String
Show
fileStatus :: Tree IO
-> Tree IO
-> Tree IO
-> FilePath
-> IO FileStatus
fileStatus :: Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus work :: Tree IO
work cur :: Tree IO
cur recorded :: Tree IO
recorded fp :: String
fp = do
Bool
existsInCur <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
cur String
fp
Bool
existsInRec <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
recorded String
fp
Bool
existsInWork <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
work String
fp
case (Bool
existsInRec, Bool
existsInCur, Bool
existsInWork) of
(_, True, True) -> do
Bool
isDirCur <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
fp
Bool
isDirWork <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
fp
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isDirCur Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isDirWork) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "don't know what to do with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus)
-> (FileKind -> FileStatus) -> FileKind -> IO FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileKind -> FileStatus
Known (FileKind -> IO FileStatus) -> FileKind -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ if Bool
isDirCur then FileKind
Dir else FileKind
File
(_, False, True) -> do
Bool
isDir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
fp
if Bool
isDir
then FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
Dir
else FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
File
(False, False, False) -> FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
Nonexistant
(_, _, False) -> do
Bool
isDir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
fp
if Bool
isDir
then FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
Dir
else FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
File
moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile opts :: [DarcsFlag]
opts old :: SubPath
old new :: SubPath
new = [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(repo :: Repository rt p wR wU wR
repo, work :: Tree IO
work, cur :: Tree IO
cur, recorded :: Tree IO
recorded) -> do
let old_fp :: String
old_fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
old
new_fp :: String
new_fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
new
FileStatus
new_fs <- Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded String
new_fp
FileStatus
old_fs <- Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded String
old_fp
let doSimpleMove :: IO ()
doSimpleMove = Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
simpleMove Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work String
old_fp String
new_fp
case (FileStatus
old_fs, FileStatus
new_fs) of
(Nonexistant, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " does not exist."
(Unadded k :: FileKind
k, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ FileKind -> String
forall a. Show a => a -> String
show FileKind
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is unadded."
(Known _, Nonexistant) -> IO ()
doSimpleMove
(Known _, Shadow _) -> IO ()
doSimpleMove
(_, Nonexistant) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not in the repository."
(Known _, Known Dir) -> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [String
old_fp] String
new_fp
(Known _, Unadded Dir) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
new_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not known to darcs; please add it to the repository."
(Known _, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
new_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already exists."
(Shadow k :: FileKind
k, Unadded k' :: FileKind
k') | FileKind
k FileKind -> FileKind -> Bool
forall a. Eq a => a -> a -> Bool
== FileKind
k' -> IO ()
doSimpleMove
(Shadow File, Known Dir) -> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [String
old_fp] String
new_fp
(Shadow Dir, Known Dir) -> IO ()
doSimpleMove
(Shadow File, Known File) -> IO ()
doSimpleMove
(Shadow k :: FileKind
k, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"cannot move " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileKind -> String
forall a. Show a => a -> String
show FileKind
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new_fp
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "did you already move it elsewhere?"
moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir opts :: [DarcsFlag]
opts froms :: [SubPath]
froms to :: SubPath
to = [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(repo :: Repository rt p wR wU wR
repo, work :: Tree IO
work, cur :: Tree IO
cur, _) ->
Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath [SubPath]
froms) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
to
withRepoAndState :: [DarcsFlag]
-> (forall rt p wR wU .
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO)
-> IO ())
-> IO ()
withRepoAndState :: [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState opts :: [DarcsFlag]
opts f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f =
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
$ \repo :: Repository rt p wR wU wR
repo -> do
Tree IO
work <- String -> IO (Tree IO)
readPlainTree "."
Tree IO
cur <- Repository rt p wR wU wR -> 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 wR
repo
Tree IO
recorded <- Repository rt p wR wU wR -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f (Repository rt p wR wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
recorded)
simpleMove :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath
-> IO ()
simpleMove :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
simpleMove repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work old_fp :: String
old_fp new_fp :: String
new_fp = do
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves Repository rt p wR wU wT
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(String
old_fp, String
new_fp)]
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([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 ["Moved:", String
old_fp, "to:", String
new_fp]
moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath
-> IO ()
moveToDir :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work moved :: [String]
moved finaldir :: String
finaldir = do
let movetargets :: [String]
movetargets = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
finaldir String -> String -> String
</>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName) [String]
moved
moves :: [(String, String)]
moves = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
moved [String]
movetargets
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves Repository rt p wR wU wT
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(String, String)]
moves
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([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
$ ["Moved:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
moved [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["to:", String
finaldir]
doMoves :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO
-> [(FilePath, FilePath)] -> IO ()
doMoves :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work moves :: [(String, String)]
moves = do
[(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
patches <- [(String, String)]
-> ((String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
-> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
moves (((String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
-> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)])
-> ((String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
-> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
forall a b. (a -> b) -> a -> b
$ \(old :: String
old, new :: String
new) -> do
Maybe (FreeLeft (FL (PrimOf p)))
prePatch <- [DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))))
forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (String
old,String
new)
(Maybe (FreeLeft (FL (PrimOf p))), String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL (PrimOf p)))
prePatch, String
old, String
new)
IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
-> ((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
patches (((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
-> IO ())
-> ((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(prePatch :: Maybe (FreeLeft (FL (PrimOf p)))
prePatch, old :: String
old, new :: String
new) -> do
let
pendingDiff :: FreeLeft (FL (PrimOf p))
pendingDiff = (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
(+>+)
(FreeLeft (FL (PrimOf p))
-> Maybe (FreeLeft (FL (PrimOf p))) -> FreeLeft (FL (PrimOf p))
forall a. a -> Maybe a -> a
fromMaybe ((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) Maybe (FreeLeft (FL (PrimOf p)))
prePatch)
((forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap ((forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p)))
-> (forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p))
forall a b. (a -> b) -> a -> b
$ String -> String -> PrimOf p wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> prim wX wY
Darcs.Patch.move String
old String
new PrimOf p wX wY -> FL (PrimOf p) wY wY -> FL (PrimOf p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PrimOf p) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
Repository rt p wR wU wT
-> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending Repository rt p wR wU wT
repository UpdateWorking
YesUpdateWorking FreeLeft (FL (PrimOf p))
pendingDiff
Tree IO -> String -> String -> IO ()
moveFileOrDir Tree IO
work String
old String
new
Repository rt p wR wU wT -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
updateIndex Repository rt p wR wU wT
repository
generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO
-> (FilePath, FilePath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches :: [DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work (old :: String
old,new :: String
new) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newIsOkWindowsPath (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
newNotOkWindowsPathMsg
let dirPath :: String
dirPath = FileName -> String
fn2fp (FileName -> String) -> FileName -> String
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
superName (FileName -> FileName) -> FileName -> FileName
forall a b. (a -> b) -> a -> b
$ String -> FileName
fp2fn String
new
Bool
haveNewParent <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
dirPath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveNewParent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "The target directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dirPath
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " isn't known in the repository, did you forget to add it?"
Bool
newInRecorded <- Tree IO -> IO Bool
hasNew Tree IO
cur
Bool
newInWorking <- Tree IO -> IO Bool
hasNew Tree IO
work
Bool
oldInWorking <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
work String
old
if Bool
oldInWorking
then do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newInWorking (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
alreadyExists "working directory"
if Bool
newInRecorded
then 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
<$> IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
else Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing
else do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Detected post-hoc move."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newInWorking (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Cannot determine post-hoc move target, "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "no file/dir named:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new
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
<$> if Bool
newInRecorded
then IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
else FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX. FL prim wX wX) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
where
newIsOkWindowsPath :: Bool
newIsOkWindowsPath =
PrimDarcsOption Bool
allowWindowsReservedFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Bool -> Bool -> Bool
|| String -> Bool
WindowsFilePath.isValid String
new
newNotOkWindowsPathMsg :: String
newNotOkWindowsPathMsg =
"The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not valid under Windows.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Use --reserved-ok to allow such filenames."
deleteNewFromRepoPatches :: IO (FreeLeft (FL prim))
deleteNewFromRepoPatches = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
"Existing recorded contents of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ " will be overwritten."
String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
let curNoNew :: Tree IO
curNoNew = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
cur (String -> AnchoredPath
floatPath String
new) Maybe (TreeItem IO)
forall a. Maybe a
Nothing
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 DiffAlgorithm
MyersDiff String -> FileType
ftf Tree IO
cur Tree IO
curNoNew
hasNew :: Tree IO -> IO Bool
hasNew s :: Tree IO
s = Tree IO -> String -> IO Bool
treeHas_case (Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
s (String -> AnchoredPath
floatPath String
old) Maybe (TreeItem IO)
forall a. Maybe a
Nothing) String
new
treeHas_case :: Tree IO -> String -> IO Bool
treeHas_case = if PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas else Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasAnycase
alreadyExists :: String -> String
alreadyExists inWhat :: String
inWhat =
if PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
then "A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newString -> String -> String
forall a. [a] -> [a] -> [a]
++" already exists in "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
else "A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newString -> String -> String
forall a. [a] -> [a] -> [a]
++" (or perhaps differing "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "only in case)\nalready exists in "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Use --case-ok to allow files differing only in case."
moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()
moveFileOrDir :: Tree IO -> String -> String -> IO ()
moveFileOrDir work :: Tree IO
work old :: String
old new :: String
new = do
Bool
has_file <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasFile Tree IO
work String
old
Bool
has_dir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
old
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_file (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ["renameFile",String
old,String
new]
String -> String -> IO ()
renameFile String
old String
new
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ["renameDirectory",String
old,String
new]
String -> String -> IO ()
renameDirectory String
old String
new
mv :: DarcsCommand [DarcsFlag]
mv :: DarcsCommand [DarcsFlag]
mv = String
-> Maybe (DarcsCommand [DarcsFlag])
-> DarcsCommand [DarcsFlag]
-> DarcsCommand [DarcsFlag]
forall pf.
String
-> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias "mv" Maybe (DarcsCommand [DarcsFlag])
forall a. Maybe a
Nothing DarcsCommand [DarcsFlag]
move