module Darcs.UI.Commands.Move ( move, mv ) where
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, pathsFromArgs
)
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( UpdatePending (..), DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.Directory ( renameDirectory, renameFile )
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.Ordered ( nubSort )
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
( AbsolutePath
, AnchoredPath
, displayPath
, isRoot
, parent
, realPath
, replaceParent
)
import Darcs.Util.Printer ( Doc, text, hsep )
moveDescription :: String
moveDescription :: String
moveDescription = String
"Move or rename files."
moveHelp :: Doc
moveHelp :: Doc
moveHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Darcs cannot reliably distinguish between a file being deleted and a\n" forall a. [a] -> [a] -> [a]
++
String
"new one added, and a file being moved. Therefore Darcs always assumes\n" forall a. [a] -> [a] -> [a]
++
String
"the former, and provides the `darcs mv` command to let Darcs know when\n" forall a. [a] -> [a] -> [a]
++
String
"you want the latter. This command will also move the file in the\n" forall a. [a] -> [a] -> [a]
++
String
"working tree (unlike `darcs remove`), unless it has already been moved.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Darcs will not rename a file if another file in the same folder has\n" forall a. [a] -> [a] -> [a]
++
String
"the same name, except for case. The `--case-ok` option overrides this\n" forall a. [a] -> [a] -> [a]
++
String
"behaviour. Windows and OS X usually use filesystems that do not allow\n" forall a. [a] -> [a] -> [a]
++
String
"files a folder to have the same name except for case (for example,\n" forall a. [a] -> [a] -> [a]
++
String
"`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" forall a. [a] -> [a] -> [a]
++
String
"unusable on those systems!\n"
move :: DarcsCommand
move :: DarcsCommand
move = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"move"
, commandHelp :: Doc
commandHelp = Doc
moveHelp
, commandDescription :: String
commandDescription = String
moveDescription
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<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 = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
moveOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
moveOpts
}
where
moveBasicOpts :: OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts = forall a. DarcsOption a (Bool -> Bool -> a)
O.allowProblematicFilenames forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
moveAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
moveOpts :: DarcsOption
a
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
moveOpts = forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args forall a. Ord a => a -> a -> Bool
< Int
2 =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The `darcs move' command requires at least two arguments."
| Bool
otherwise = do
[AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnchoredPath]
paths forall a. Ord a => a -> a -> Bool
< Int
2) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Note enough valid path arguments remaining."
case [AnchoredPath]
paths of
[AnchoredPath
from, AnchoredPath
to] -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
from forall a. Eq a => a -> a -> Bool
== AnchoredPath
to) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath -> Bool
isRoot AnchoredPath
from) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
[DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile [DarcsFlag]
opts AnchoredPath
from AnchoredPath
to
[AnchoredPath]
_ -> do
let froms :: [AnchoredPath]
froms = forall a. [a] -> [a]
init [AnchoredPath]
paths
to :: AnchoredPath
to = forall a. [a] -> a
last [AnchoredPath]
paths
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
to forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
froms) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredPath -> Bool
isRoot [AnchoredPath]
froms) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
[DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir [DarcsFlag]
opts (forall a. Ord a => [a] -> [a]
nubSort [AnchoredPath]
froms) AnchoredPath
to
data FileKind = Dir | File
deriving (Int -> FileKind -> ShowS
[FileKind] -> ShowS
FileKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileKind] -> ShowS
$cshowList :: [FileKind] -> ShowS
show :: FileKind -> String
$cshow :: FileKind -> String
showsPrec :: Int -> FileKind -> ShowS
$cshowsPrec :: Int -> FileKind -> ShowS
Show, FileKind -> FileKind -> Bool
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 -> ShowS
[FileStatus] -> ShowS
FileStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileStatus] -> ShowS
$cshowList :: [FileStatus] -> ShowS
show :: FileStatus -> String
$cshow :: FileStatus -> String
showsPrec :: Int -> FileStatus -> ShowS
$cshowsPrec :: Int -> FileStatus -> ShowS
Show
fileStatus :: Tree IO
-> Tree IO
-> Tree IO
-> AnchoredPath
-> IO FileStatus
fileStatus :: Tree IO -> Tree IO -> Tree IO -> AnchoredPath -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded AnchoredPath
fp = do
Bool
existsInCur <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur AnchoredPath
fp
Bool
existsInRec <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
recorded AnchoredPath
fp
Bool
existsInWork <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
work AnchoredPath
fp
case (Bool
existsInRec, Bool
existsInCur, Bool
existsInWork) of
(Bool
_, Bool
True, Bool
True) -> do
Bool
isDirCur <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
fp
Bool
isDirWork <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
fp
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isDirCur forall a. Eq a => a -> a -> Bool
== Bool
isDirWork) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"don't know what to do with " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileKind -> FileStatus
Known forall a b. (a -> b) -> a -> b
$ if Bool
isDirCur then FileKind
Dir else FileKind
File
(Bool
_, Bool
False, Bool
True) -> do
Bool
isDir <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
fp
if Bool
isDir
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
Dir
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
File
(Bool
False, Bool
False, Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
Nonexistant
(Bool
_, Bool
_, Bool
False) -> do
Bool
isDir <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
fp
if Bool
isDir
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
Dir
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
File
moveFile :: [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile :: [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile [DarcsFlag]
opts AnchoredPath
old AnchoredPath
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 a b. (a -> b) -> a -> b
$ \(Repository rt p wR wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
recorded) -> do
FileStatus
new_fs <- Tree IO -> Tree IO -> Tree IO -> AnchoredPath -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded AnchoredPath
new
FileStatus
old_fs <- Tree IO -> Tree IO -> Tree IO -> AnchoredPath -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded AnchoredPath
old
let doSimpleMove :: IO ()
doSimpleMove = forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
simpleMove Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work AnchoredPath
old AnchoredPath
new
case (FileStatus
old_fs, FileStatus
new_fs) of
(FileStatus
Nonexistant, FileStatus
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
old forall a. [a] -> [a] -> [a]
++ String
" does not exist."
(Unadded FileKind
k, FileStatus
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show FileKind
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
old forall a. [a] -> [a] -> [a]
++ String
" is unadded."
(Known FileKind
_, FileStatus
Nonexistant) -> IO ()
doSimpleMove
(Known FileKind
_, Shadow FileKind
_) -> IO ()
doSimpleMove
(FileStatus
_, FileStatus
Nonexistant) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
old forall a. [a] -> [a] -> [a]
++ String
" is not in the repository."
(Known FileKind
_, Known FileKind
Dir) -> forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath
old] AnchoredPath
new
(Known FileKind
_, Unadded FileKind
Dir) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
AnchoredPath -> String
displayPath AnchoredPath
new forall a. [a] -> [a] -> [a]
++ String
" is not known to darcs; please add it to the repository."
(Known FileKind
_, FileStatus
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
new forall a. [a] -> [a] -> [a]
++ String
" already exists."
(Shadow FileKind
k, Unadded FileKind
k') | FileKind
k forall a. Eq a => a -> a -> Bool
== FileKind
k' -> IO ()
doSimpleMove
(Shadow FileKind
File, Known FileKind
Dir) -> forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath
old] AnchoredPath
new
(Shadow FileKind
Dir, Known FileKind
Dir) -> IO ()
doSimpleMove
(Shadow FileKind
File, Known FileKind
File) -> IO ()
doSimpleMove
(Shadow FileKind
k, FileStatus
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"cannot move " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FileKind
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
old forall a. [a] -> [a] -> [a]
++ String
" into " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new
forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ String
"did you already move it elsewhere?"
moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir [DarcsFlag]
opts [AnchoredPath]
froms AnchoredPath
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 a b. (a -> b) -> a -> b
$ \(Repository rt p wR wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
_) -> do
Bool
froms_exist <- forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
froms (forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur)
if Bool
froms_exist then
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath]
froms AnchoredPath
to
else
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Some of the paths you want to move aren't know to darcs. Use `darcs add` to add them first."
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 [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 ()
f =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
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 a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> do
Tree IO
work <- String -> IO (Tree IO)
readPlainTree String
"."
Tree IO
cur <- 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
repo
Tree IO
recorded <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
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 wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath
-> IO ()
simpleMove :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
simpleMove Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work AnchoredPath
old AnchoredPath
new = do
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath
old, AnchoredPath
new)]
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String
"Finished moving:", AnchoredPath -> String
displayPath AnchoredPath
old, String
"to:", AnchoredPath -> String
displayPath AnchoredPath
new]
moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath
-> IO ()
moveToDir :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath]
moved AnchoredPath
finaldir = do
let replaceParentPath :: AnchoredPath -> AnchoredPath -> AnchoredPath
replaceParentPath AnchoredPath
a1 AnchoredPath
a2 =
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"cannot replace parent of root path") forall a b. (a -> b) -> a -> b
$ AnchoredPath -> AnchoredPath -> Maybe AnchoredPath
replaceParent AnchoredPath
a1 AnchoredPath
a2
let moves :: [(AnchoredPath, AnchoredPath)]
moves = forall a b. [a] -> [b] -> [(a, b)]
zip [AnchoredPath]
moved forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath
replaceParentPath AnchoredPath
finaldir) [AnchoredPath]
moved
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
moves
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text forall a b. (a -> b) -> a -> b
$ [String
"Finished moving:"] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
moved forall a. [a] -> [a] -> [a]
++ [String
"to:", AnchoredPath -> String
displayPath AnchoredPath
finaldir]
doMoves :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO
-> [(AnchoredPath, AnchoredPath)] -> IO ()
doMoves :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
moves = do
[(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(AnchoredPath, AnchoredPath)]
moves forall a b. (a -> b) -> a -> b
$ \(AnchoredPath
old, AnchoredPath
new) -> do
Maybe (FreeLeft (FL (PrimOf p)))
prePatch <- forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (AnchoredPath
old,AnchoredPath
new)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL (PrimOf p)))
prePatch, AnchoredPath
old, AnchoredPath
new)
forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches forall a b. (a -> b) -> a -> b
$ \(Maybe (FreeLeft (FL (PrimOf p)))
prePatch, AnchoredPath
old, AnchoredPath
new) -> do
let
pendingDiff :: FreeLeft (FL (PrimOf p))
pendingDiff = 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 (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+)
(forall a. a -> Maybe a -> a
fromMaybe (forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) Maybe (FreeLeft (FL (PrimOf p)))
prePatch)
(forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
Darcs.Patch.move AnchoredPath
old AnchoredPath
new forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending Repository rt p wR wU wR
repository FreeLeft (FL (PrimOf p))
pendingDiff
Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir Tree IO
work AnchoredPath
old AnchoredPath
new
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ()
updateIndex Repository rt p wR wU wR
repository
generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches :: forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (AnchoredPath
old,AnchoredPath
new) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newIsOkWindowsPath forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
newNotOkWindowsPathMsg
let dirPath :: AnchoredPath
dirPath =
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"unexpected root path in generatePreMovePatches") forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
new
Bool
haveNewParent <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
dirPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveNewParent forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The target directory " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
dirPath
forall a. [a] -> [a] -> [a]
++ String
" 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 <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
work AnchoredPath
old
if Bool
oldInWorking
then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newInWorking forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ ShowS
alreadyExists String
"working directory"
if Bool
newInRecorded
then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Detected post-hoc move."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newInWorking forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot determine post-hoc move target, "
forall a. [a] -> [a] -> [a]
++ String
"no file/dir named:\n" forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
newInRecorded
then IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
where
newIsOkWindowsPath :: Bool
newIsOkWindowsPath =
PrimDarcsOption Bool
allowWindowsReservedFilenames forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Bool -> Bool -> Bool
|| String -> Bool
WindowsFilePath.isValid (AnchoredPath -> String
realPath AnchoredPath
new)
newNotOkWindowsPathMsg :: String
newNotOkWindowsPathMsg =
String
"The filename " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new forall a. [a] -> [a] -> [a]
++ String
" is not valid under Windows.\n"
forall a. [a] -> [a] -> [a]
++ String
"Use --reserved-ok to allow such filenames."
deleteNewFromRepoPatches :: IO (FreeLeft (FL prim))
deleteNewFromRepoPatches = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Existing recorded contents of " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new forall a. [a] -> [a] -> [a]
++ String
" will be overwritten."
String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
let curNoNew :: Tree IO
curNoNew = forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
cur AnchoredPath
new forall a. Maybe a
Nothing
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 Tree IO
s = Tree IO -> AnchoredPath -> IO Bool
treeHas_case (forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
s AnchoredPath
old forall a. Maybe a
Nothing) AnchoredPath
new
treeHas_case :: Tree IO -> AnchoredPath -> IO Bool
treeHas_case = if PrimDarcsOption Bool
allowCaseDifferingFilenames forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas else forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasAnycase
alreadyExists :: ShowS
alreadyExists String
inWhat =
if PrimDarcsOption Bool
allowCaseDifferingFilenames forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
then String
"A file or dir named "forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newforall a. [a] -> [a] -> [a]
++String
" already exists in "
forall a. [a] -> [a] -> [a]
++ String
inWhat forall a. [a] -> [a] -> [a]
++ String
"."
else String
"A file or dir named "forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newforall a. [a] -> [a] -> [a]
++String
" (or perhaps differing "
forall a. [a] -> [a] -> [a]
++ String
"only in case)\nalready exists in "forall a. [a] -> [a] -> [a]
++ String
inWhat forall a. [a] -> [a] -> [a]
++ String
".\n"
forall a. [a] -> [a] -> [a]
++ String
"Use --case-ok to allow files differing only in case."
moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir Tree IO
work AnchoredPath
old AnchoredPath
new = do
Bool
has_file <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasFile Tree IO
work AnchoredPath
old
Bool
has_dir <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
old
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_file forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"renameFile", AnchoredPath -> String
displayPath AnchoredPath
old, AnchoredPath -> String
displayPath AnchoredPath
new]
String -> String -> IO ()
renameFile (AnchoredPath -> String
realPath AnchoredPath
old) (AnchoredPath -> String
realPath AnchoredPath
new)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_dir forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"renameDirectory", AnchoredPath -> String
displayPath AnchoredPath
old, AnchoredPath -> String
displayPath AnchoredPath
new]
String -> String -> IO ()
renameDirectory (AnchoredPath -> String
realPath AnchoredPath
old) (AnchoredPath -> String
realPath AnchoredPath
new)
mv :: DarcsCommand
mv :: DarcsCommand
mv = String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias String
"mv" forall a. Maybe a
Nothing DarcsCommand
move