module Darcs.UI.Commands.Move ( move, mv ) where
import Darcs.Prelude
import Control.Monad ( when, unless, forM_, forM, void )
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, umask, pathsFromArgs
)
import Darcs.UI.Options ( (^), (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.Directory ( renameDirectory, renameFile )
import Darcs.Repository.State
( readPristine
, readPristineAndPending
, readUnrecordedFiltered
)
import Darcs.Repository
( Repository
, AccessType(..)
, withRepoLock
, RepoJob(..)
, unsafeAddToPending
, finalizeRepositoryChanges
)
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Patch.Witnesses.Sealed ( FreeLeft, emptyGap, freeGap, joinGap )
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.Util.Tree
( Tree
, modifyTree
, treeHas
, treeHasAnycase
, treeHasDir
, treeHasFile
)
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 (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
String
"Darcs cannot reliably distinguish between a file being deleted and a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"new one added, and a file being moved. Therefore Darcs always assumes\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"the former, and provides the `darcs mv` command to let Darcs know when\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"you want the latter. This command will also move the file in the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"working tree (unlike `darcs remove`), unless it has already been moved.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Darcs will not rename a file if another file in the same folder has\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"the same name, except for case. The `--case-ok` option overrides this\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"behaviour. Windows and OS X usually use filesystems that do not allow\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"files a folder to have the same name except for case (for example,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" String -> String -> String
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
, commandOptions :: CommandOptions
commandOptions = CommandOptions
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
PrimDarcsOption UMask
O.umask
moveOpts :: CommandOptions
moveOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
(Bool
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
-> DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
(UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
b
-> CommandOptions
`withStdOpts` DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
(UMask
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
PrimDarcsOption UMask
moveAdvancedOpts
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args
| [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 =
String -> IO ()
forall a. String -> IO a
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([AnchoredPath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnchoredPath]
paths Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Note enough valid path arguments remaining."
case [AnchoredPath]
paths of
[AnchoredPath
from, AnchoredPath
to] -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
from AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
to) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath -> Bool
isRoot AnchoredPath
from) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
[DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile [DarcsFlag]
opts AnchoredPath
from AnchoredPath
to
[AnchoredPath]
_ -> do
let froms :: [AnchoredPath]
froms = [AnchoredPath] -> [AnchoredPath]
forall a. HasCallStack => [a] -> [a]
init [AnchoredPath]
paths
to :: AnchoredPath
to = [AnchoredPath] -> AnchoredPath
forall a. HasCallStack => [a] -> a
last [AnchoredPath]
paths
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
to AnchoredPath -> [AnchoredPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
froms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredPath -> Bool
isRoot [AnchoredPath]
froms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
[DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir [DarcsFlag]
opts ([AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort [AnchoredPath]
froms) AnchoredPath
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
$cshowsPrec :: Int -> FileKind -> String -> String
showsPrec :: Int -> FileKind -> String -> String
$cshow :: FileKind -> String
show :: FileKind -> String
$cshowList :: [FileKind] -> String -> String
showList :: [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
$c== :: FileKind -> FileKind -> Bool
== :: FileKind -> FileKind -> Bool
$c/= :: FileKind -> FileKind -> Bool
/= :: 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
$cshowsPrec :: Int -> FileStatus -> String -> String
showsPrec :: Int -> FileStatus -> String -> String
$cshow :: FileStatus -> String
show :: FileStatus -> String
$cshowList :: [FileStatus] -> String -> String
showList :: [FileStatus] -> String -> String
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 <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur AnchoredPath
fp
Bool
existsInRec <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
recorded AnchoredPath
fp
Bool
existsInWork <- Tree IO -> AnchoredPath -> IO Bool
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 <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
fp
Bool
isDirWork <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"don't know what to do with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
fp
FileStatus -> IO FileStatus
forall a. a -> IO a
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
(Bool
_, Bool
False, Bool
True) -> do
Bool
isDir <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
fp
if Bool
isDir
then FileStatus -> IO FileStatus
forall a. a -> IO a
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 a. a -> IO a
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
(Bool
False, Bool
False, Bool
False) -> FileStatus -> IO FileStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
Nonexistant
(Bool
_, Bool
_, Bool
False) -> do
Bool
isDir <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
fp
if Bool
isDir
then FileStatus -> IO FileStatus
forall a. a -> IO a
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 a. a -> IO a
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] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile :: [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile [DarcsFlag]
opts AnchoredPath
old AnchoredPath
new = [DarcsFlag]
-> (forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ())
-> (forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Repository 'RW p 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 = Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
simpleMove Repository 'RW p 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
_) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist."
(Unadded FileKind
k, FileStatus
_) -> String -> IO ()
forall a. String -> IO a
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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is unadded."
(Known FileKind
_, FileStatus
Nonexistant) -> IO ()
doSimpleMove
(Known FileKind
_, Shadow FileKind
_) -> IO ()
doSimpleMove
(FileStatus
_, FileStatus
Nonexistant) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not in the repository."
(Known FileKind
_, Known FileKind
Dir) -> Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository 'RW p wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath
old] AnchoredPath
new
(Known FileKind
_, Unadded FileKind
Dir) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not known to darcs; please add it to the repository."
(Known FileKind
_, FileStatus
_) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already exists."
(Shadow FileKind
k, Unadded FileKind
k') | FileKind
k FileKind -> FileKind -> Bool
forall a. Eq a => a -> a -> Bool
== FileKind
k' -> IO ()
doSimpleMove
(Shadow FileKind
File, Known FileKind
Dir) -> Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository 'RW p 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
_) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> 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 (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ())
-> (forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Repository 'RW p wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
_) -> do
Bool
froms_exist <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AnchoredPath] -> (AnchoredPath -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
froms (Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur)
if Bool
froms_exist then
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository 'RW p wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath]
froms AnchoredPath
to
else
String -> IO ()
forall a. String -> IO a
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 p wR wU .
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO)
-> IO ())
-> IO ()
withRepoAndState :: [DarcsFlag]
-> (forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f =
UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repo -> do
Tree IO
work <-
Repository 'RW p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository 'RW p wU wR
repo (PrimOptSpec DarcsOptDescr DarcsFlag a UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
LookForAdds
O.EvenLookForBoring LookForMoves
O.NoLookForMoves Maybe [AnchoredPath]
forall a. Maybe a
Nothing
Tree IO
cur <- Repository 'RW p wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository 'RW p wU wR
repo
Tree IO
recorded <- Repository 'RW p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RW p wU wR
repo
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
forall (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f (Repository 'RW p wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
recorded)
simpleMove :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath
-> IO ()
simpleMove :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
simpleMove Repository 'RW p wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work AnchoredPath
old AnchoredPath
new = do
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository 'RW p wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath
old, AnchoredPath
new)]
[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
"Finished moving:", AnchoredPath -> String
displayPath AnchoredPath
old, String
"to:", AnchoredPath -> String
displayPath AnchoredPath
new]
moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath
-> IO ()
moveToDir :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository 'RW p 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 =
AnchoredPath -> Maybe AnchoredPath -> AnchoredPath
forall a. a -> Maybe a -> a
fromMaybe (String -> AnchoredPath
forall a. HasCallStack => String -> a
error String
"cannot replace parent of root path") (Maybe AnchoredPath -> AnchoredPath)
-> Maybe AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> AnchoredPath -> Maybe AnchoredPath
replaceParent AnchoredPath
a1 AnchoredPath
a2
let moves :: [(AnchoredPath, AnchoredPath)]
moves = [AnchoredPath] -> [AnchoredPath] -> [(AnchoredPath, AnchoredPath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [AnchoredPath]
moved ([AnchoredPath] -> [(AnchoredPath, AnchoredPath)])
-> [AnchoredPath] -> [(AnchoredPath, AnchoredPath)]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> AnchoredPath) -> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath
replaceParentPath AnchoredPath
finaldir) [AnchoredPath]
moved
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository 'RW p wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
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
$ [String
"Finished moving:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
moved [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"to:", AnchoredPath -> String
displayPath AnchoredPath
finaldir]
doMoves :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO
-> [(AnchoredPath, AnchoredPath)] -> IO ()
doMoves :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository 'RW p wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
moves = do
[(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches <- [(AnchoredPath, AnchoredPath)]
-> ((AnchoredPath, AnchoredPath)
-> IO
(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
-> IO
[(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(AnchoredPath, AnchoredPath)]
moves (((AnchoredPath, AnchoredPath)
-> IO
(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
-> IO
[(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)])
-> ((AnchoredPath, AnchoredPath)
-> IO
(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
-> IO
[(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
forall a b. (a -> b) -> a -> b
$ \(AnchoredPath
old, AnchoredPath
new) -> do
Maybe (FreeLeft (FL (PrimOf p)))
prePatch <- [DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL (PrimOf p))))
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)
(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
-> IO
(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL (PrimOf p)))
prePatch, AnchoredPath
old, AnchoredPath
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))), AnchoredPath, AnchoredPath)]
-> ((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
-> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches (((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
-> IO ())
-> IO ())
-> ((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
-> IO ())
-> IO ()
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 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 (p :: * -> * -> *) (q :: * -> * -> *) (r :: * -> * -> *).
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> FreeLeft p -> FreeLeft q -> FreeLeft r
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 FL (PrimOf p) wX wY -> FL (PrimOf p) wY wZ -> FL (PrimOf p) wX wZ
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 (p :: * -> * -> *). (forall wX. p wX wX) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap FL (PrimOf p) wX wX
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 (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft 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
$ AnchoredPath -> AnchoredPath -> PrimOf p wX wY
forall wX wY. AnchoredPath -> AnchoredPath -> PrimOf p wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
Darcs.Patch.move AnchoredPath
old AnchoredPath
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)
Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir Tree IO
work AnchoredPath
old AnchoredPath
new
Repository 'RW p wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
unsafeAddToPending Repository 'RW p wU wR
repository FreeLeft (FL (PrimOf p))
pendingDiff
IO (Repository 'RO p wU wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wU wR) -> IO ())
-> IO (Repository 'RO p wU wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
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
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
newNotOkWindowsPathMsg
let dirPath :: AnchoredPath
dirPath =
AnchoredPath -> Maybe AnchoredPath -> AnchoredPath
forall a. a -> Maybe a -> a
fromMaybe (String -> AnchoredPath
forall a. HasCallStack => String -> a
error String
"unexpected root path in generatePreMovePatches") (Maybe AnchoredPath -> AnchoredPath)
-> Maybe AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
new
Bool
haveNewParent <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"The target directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
dirPath
String -> String -> String
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 <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
work AnchoredPath
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
alreadyExists String
"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 a. a -> IO a
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 String
"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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot determine post-hoc move target, "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"no file/dir named:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
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 a. a -> IO a
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 (p :: * -> * -> *). (forall wX. p wX wX) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap FL prim wX wX
forall wX. FL prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
where
newIsOkWindowsPath :: Bool
newIsOkWindowsPath =
PrimOptSpec DarcsOptDescr DarcsFlag a Bool
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 (AnchoredPath -> String
realPath AnchoredPath
new)
newNotOkWindowsPathMsg :: String
newNotOkWindowsPathMsg =
String
"The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not valid under Windows.\n"
String -> String -> String
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 (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
$
String
"Existing recorded contents of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 AnchoredPath
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 Tree IO
s = Tree IO -> AnchoredPath -> 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 AnchoredPath
old Maybe (TreeItem IO)
forall a. Maybe a
Nothing) AnchoredPath
new
treeHas_case :: Tree IO -> AnchoredPath -> IO Bool
treeHas_case = if PrimOptSpec DarcsOptDescr DarcsFlag a Bool
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 -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas else Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasAnycase
alreadyExists :: String -> String
alreadyExists String
inWhat =
if PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
then String
"A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" already exists in "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
else String
"A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" (or perhaps differing "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"only in case)\nalready exists in "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".\n"
String -> String -> String
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 <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasFile Tree IO
work AnchoredPath
old
Bool
has_dir <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
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 [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)
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 [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" Maybe DarcsCommand
forall a. Maybe a
Nothing DarcsCommand
move