% Copyright (C) 2002-2003 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; see the file COPYING. If not, write to
% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
% Boston, MA 02110-1301, USA.
\darcsCommand{move}
\begin{code}
module Darcs.Commands.Move ( move, mv ) where
import Control.Monad ( when, unless, zipWithM_ )
import Data.Maybe ( catMaybes )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )
import Darcs.Arguments ( DarcsFlag(),
fixSubPaths, workingRepoDir,
listFiles, allowProblematicFilenames, umaskOption,
)
import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved )
import Darcs.RepoPath ( toFilePath, sp2fn )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Workaround ( renameFile )
import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,
slurp_pending, add_to_pending,
)
import Darcs.Witnesses.Ordered ( FL(..), unsafeFL )
import Darcs.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, Prim )
import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase,
slurp_remove, slurp_hasdir, slurp_hasfile )
import Darcs.Patch.FileName ( fp2fn, fn2fp, superName )
import qualified System.FilePath.Windows as WindowsFilePath
#include "impossible.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 {commandName = "move",
commandHelp = moveHelp,
commandDescription = moveDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"],
commandCommand = moveCmd,
commandPrereq = amInRepository,
commandGetArgPossibilities = listFiles,
commandArgdefaults = nodefaults,
commandAdvancedOptions = [umaskOption],
commandBasicOptions = [allowProblematicFilenames, workingRepoDir]}
moveCmd :: [DarcsFlag] -> [String] -> IO ()
moveCmd _ [] = fail "The `darcs move' command requires at least two arguments."
moveCmd _ [_] = fail "The `darcs move' command requires at least two arguments."
moveCmd opts args@[_,_] = withRepoLock opts $- \repository -> do
two_files <- fixSubPaths opts args
[old,new] <- return $ case two_files of
[_,_] -> two_files
[_] -> error "Cannot rename a file or directory onto itself!"
xs -> bug $ "Problem in moveCmd: " ++ show xs
work <- slurp "."
let old_fp = toFilePath old
new_fp = toFilePath new
if slurp_hasdir (sp2fn new) work && slurp_has old_fp work
then moveToDir repository opts [old_fp] new_fp
else do
cur <- slurp_pending repository
addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp)
withSignalsBlocked $ do
case addpatch of
Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)
Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)
moveFileOrDir work old_fp new_fp
moveCmd opts args =
withRepoLock opts $- \repository -> do
relpaths <- map toFilePath `fmap` fixSubPaths opts args
let moved = init relpaths
finaldir = last relpaths
moveToDir repository opts moved finaldir
moveToDir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()
moveToDir repository opts moved finaldir =
let movefns = map takeFileName moved
movetargets = map (finaldir </>) movefns
movepatches = zipWith Darcs.Patch.move moved movetargets
in do
cur <- slurp_pending repository
work <- slurp "."
addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets
withSignalsBlocked $ do
add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches
zipWithM_ (moveFileOrDir work) moved movetargets
check_new_and_old_filenames
:: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim)
check_new_and_old_filenames 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."
maybe_add_file_thats_been_moved <-
if slurp_has old work
then do unless (slurp_hasdir (superName $ fp2fn new) work) $
fail $ "The target directory " ++
(fn2fp $ superName $ fp2fn new)++
" isn't known in working directory, did you forget to add it?"
when (it_has new work) $ fail $ already_exists "working directory"
return Nothing
else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory"
return $ Just $ Darcs.Patch.addfile old
if slurp_has old cur
then do unless (slurp_hasdir (superName $ fp2fn new) cur) $
fail $ "The target directory " ++
(fn2fp $ superName $ fp2fn new)++
" isn't known in working directory, did you forget to add it?"
when (it_has new cur) $ fail $ already_exists "repository"
else fail $ doesnt_exist "repository"
return maybe_add_file_thats_been_moved
where it_has f s =
let ms2 = slurp_remove (fp2fn old) s
in case ms2 of
Nothing -> False
Just s2 -> if doAllowCaseOnly opts
then slurp_has f s2
else slurp_has_anycase f s2
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 :: Slurpy -> FilePath -> FilePath -> IO ()
moveFileOrDir work old new
| slurp_hasfile (fp2fn old) work =
do debugMessage $ unwords ["renameFile",old,new]
renameFile old new
| slurp_hasdir (fp2fn old) work =
do debugMessage $ unwords ["renameDirectory",old,new]
renameDirectory old new
| otherwise = return ()
mv :: DarcsCommand
mv = commandAlias "mv" move
\end{code}