module Darcs.Commands.Move ( move, mv ) where
import Control.Applicative ( (<$>) )
import Control.Monad ( when, unless, zipWithM_ )
import Data.Maybe ( catMaybes )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )
import Darcs.Arguments ( DarcsFlag(), maybeFixSubPaths,
fixSubPaths, workingRepoDir,
listFiles, allowProblematicFilenames, umaskOption,
)
import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved )
import Darcs.RepoPath ( SubPath(), toFilePath )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Workaround ( renameFile )
import Darcs.Repository.State ( readRecordedAndPending, readRecorded )
import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository, addToPending )
import Darcs.Witnesses.Ordered ( FL(..), toFL )
import Darcs.Witnesses.Sealed ( Sealed(..), unseal, freeGap, FreeLeft, unFreeLeft )
import Darcs.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, PrimPatch )
import Darcs.Patch.FileName ( fp2fn, fn2fp, superName )
import Darcs.Patch.Apply( ApplyState )
import Data.List ( nub, sort )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.Utils( treeHas, treeHasDir, treeHasAnycase, treeHasFile )
import Storage.Hashed.Tree( Tree, modifyTree )
import Storage.Hashed.Plain( readPlainTree )
import Storage.Hashed.AnchoredPath( floatPath )
#include "gadts.h"
moveDescription :: String
moveDescription = "Move or rename files."
moveHelp :: String
moveHelp =
"Darcs cannot reliably distinguish between a file being deleted and a\n" ++
"new one added, and a file being moved. Therefore Darcs always assumes\n" ++
"the former, and provides the `darcs mv' command to let Darcs know when\n" ++
"you want the latter. This command will also move the file in the\n" ++
"working tree (unlike `darcs remove'), unless it has already been moved.\n" ++
"\n" ++
"Darcs will not rename a file if another file in the same folder has\n" ++
"the same name, except for case. The --case-ok option overrides this\n" ++
"behaviour. Windows and OS X usually use filesystems that do not allow\n" ++
"files a folder to have the same name except for case (for example,\n" ++
"`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++
"unusable on those systems!\n"
move :: DarcsCommand
move = DarcsCommand {commandProgramName = "darcs",
commandName = "move",
commandHelp = moveHelp,
commandDescription = moveDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"],
commandCommand = moveCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = listFiles,
commandArgdefaults = nodefaults,
commandAdvancedOptions = [umaskOption],
commandBasicOptions = [allowProblematicFilenames, workingRepoDir]}
moveCmd :: [DarcsFlag] -> [String] -> IO ()
moveCmd opts args
| length args < 2 =
fail $ "The `darcs move' command requires at least two arguments."
| length args == 2 = do
xs <- maybeFixSubPaths opts args
case xs of
[Just from, Just to]
| from == to -> fail "Cannot rename a file or directory onto itself!"
| toFilePath from == "" -> fail "Cannot move the root of the repository"
| otherwise -> moveFile opts from to
_ -> fail "Both source and destination must be valid."
| otherwise = let (froms, to) = (init args, last args) in do
x <- head <$> maybeFixSubPaths opts [to]
case x of
Nothing -> fail "Invalid destination directory."
Just to' -> do
xs <- nub . sort <$> fixSubPaths opts froms
if to' `elem` xs
then fail "Cannot rename a file or directory onto itself!"
else case xs of
[] -> fail "Nothing to move."
froms' -> moveFilesToDir opts froms' to'
data FileKind = Dir | File
deriving (Show, Eq)
data FileStatus =
Nonexistant
| Unadded FileKind
| Shadow FileKind
| Known FileKind
deriving Show
fileStatus :: Tree IO -> Tree IO -> Tree IO ->
FilePath -> IO FileStatus
fileStatus work cur rec fp = do
exists_in_cur <- treeHas cur fp
exists_in_rec <- treeHas rec fp
exists_in_work <- treeHas work fp
case (exists_in_rec, exists_in_cur, exists_in_work) of
(_, True, True) -> do
isDirCur <- treeHasDir cur fp
isDirWork <- treeHasDir work fp
unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp
return . Known $ if isDirCur then Dir else File
(_, False, True) -> do
isDir <- treeHasDir work fp
if isDir
then return $ Unadded Dir
else return $ Unadded File
(False, False, False) -> return Nonexistant
(_, _, False) -> do
isDir <- treeHasDir cur fp
if isDir
then return $ Shadow Dir
else return $ Shadow File
moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile opts old new = withRepoLock opts $ RepoJob $ \repository -> do
work <- readPlainTree "."
cur <- readRecordedAndPending repository
rec <- readRecorded repository
let old_fp = toFilePath old
new_fp = toFilePath new
new_fs <- fileStatus work cur rec new_fp
old_fs <- fileStatus work cur rec old_fp
case (old_fs, new_fs) of
(Nonexistant, _) -> fail $ old_fp ++ " is inexistant."
(Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."
(Known _, Nonexistant) -> simpleMove repository opts cur work old_fp new_fp
(Known _, Shadow _) -> simpleMove repository opts cur work old_fp new_fp
(_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."
(Known _, Known Dir) -> moveToDir repository opts [old_fp] new_fp
(Known _, Unadded Dir) -> fail $ new_fp ++ " is not known to darcs; please add it to the repository."
(Known _, _) -> fail $ new_fp ++ " already exists."
(Shadow k, Unadded k') | k == k' -> simpleMove repository opts cur work old_fp new_fp
(Shadow _, Known Dir) -> moveToDir repository opts [old_fp] new_fp
(Shadow k, _) -> fail $ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp ++ " : " ++
"did you already move it elsewhere?"
simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)
-> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath
-> IO ()
simpleMove repository opts cur work old_fp new_fp = do
addpatch <- checkNewAndOldFilenames opts cur work (old_fp,new_fp)
withSignalsBlocked $ do
case unFreeLeft <$> addpatch of
Nothing -> addToPending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)
Just (Sealed p) -> addToPending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)
moveFileOrDir work old_fp new_fp
moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir opts froms to = withRepoLock opts $ RepoJob $ \repo ->
moveToDir repo opts (map toFilePath froms) $ toFilePath to
moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()
moveToDir repository opts moved finaldir =
let movefns = map takeFileName moved
movetargets = map (finaldir </>) movefns
movepatches = zipWith (\a b -> freeGap (Darcs.Patch.move a b)) moved movetargets
in do
cur <- readRecordedAndPending repository
work <- readPlainTree "."
addpatches <- mapM (checkNewAndOldFilenames opts cur work) $ zip moved movetargets
withSignalsBlocked $ do
unseal (addToPending repository) $ toFL $ catMaybes addpatches ++ movepatches
zipWithM_ (moveFileOrDir work) moved movetargets
checkNewAndOldFilenames
:: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO -> (FilePath, FilePath) -> IO (Maybe (FreeLeft prim))
checkNewAndOldFilenames opts cur work (old,new) = do
unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $
fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++
"Use --reserved-ok to allow such filenames."
has_work <- treeHas work old
maybe_add_file_thats_been_moved <-
if has_work
then do has_target <- treeHasDir work (fn2fp $ superName $ fp2fn new)
unless has_target $
fail $ "The target directory " ++
(fn2fp $ superName $ fp2fn new)++
" isn't known in working directory, did you forget to add it?"
has_new <- it_has work
when has_new $ fail $ already_exists "working directory"
return Nothing
else do
has_new <- treeHas work new
has_cur_dir <- treeHasDir cur old
unless has_new $ fail $ doesnt_exist "working directory"
let add_patch = if has_cur_dir
then Darcs.Patch.adddir old
else Darcs.Patch.addfile old
return (Just (freeGap (add_patch)))
has_target <- treeHasDir cur (fn2fp $ superName $ fp2fn new)
unless has_target $
fail $ "The target directory " ++
(fn2fp $ superName $ fp2fn new)++
" isn't known in working directory, did you forget to add it?"
has_new <- it_has cur
when has_new $ fail $ already_exists "repository"
return maybe_add_file_thats_been_moved
where it_has s = treeHas_case (modifyTree s (floatPath old) Nothing) new
treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase
already_exists what_slurpy =
if doAllowCaseOnly opts
then "A file or dir named "++new++" already exists in "
++ what_slurpy ++ "."
else "A file or dir named "++new++" (or perhaps differing"++
" only in case)\nalready exists in "++
what_slurpy ++ ".\n"++
"Use --case-ok to allow files differing only in case."
doesnt_exist what_slurpy =
"There is no file or dir named " ++ old ++
" in the "++ what_slurpy ++ "."
moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()
moveFileOrDir work old new = do
has_file <- treeHasFile work old
has_dir <- treeHasDir work old
when has_file $ do debugMessage $ unwords ["renameFile",old,new]
renameFile old new
when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]
renameDirectory old new
mv :: DarcsCommand
mv = commandAlias "mv" Nothing move