Move.lhs

%  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}
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

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, command_alias )
import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ),
                         fixSubPaths, working_repo_dir,
                        list_files, allow_problematic_filenames, umask_option,
                      )
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.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, super_name )
import qualified System.FilePath.Windows as WindowsFilePath

import Darcs.Gorsvet( invalidateIndex )
#include "impossible.h"

move_description :: String
move_description = "Move or rename files."

move_help :: String
move_help =
 "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').\n" ++
 "\n" ++
 -- Note that this paragraph is very similar to one in ./Add.lhs.
 "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 {command_name = "move",
                   command_help = move_help,
                   command_description = move_description,
                   command_extra_args = -1,
                   command_extra_arg_help = ["<SOURCE> ... <DESTINATION>"],
                   command_command = move_cmd,
                   command_prereq = amInRepository,
                   command_get_arg_possibilities = list_files,
                   command_argdefaults = nodefaults,
                   command_advanced_options = [umask_option],
                   command_basic_options = [allow_problematic_filenames, working_repo_dir]}
move_cmd :: [DarcsFlag] -> [String] -> IO ()
move_cmd _ [] = fail "The `darcs move' command requires at least two arguments."
move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments."

move_cmd 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 move_cmd: " ++ 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 move_to_dir 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)
    invalidateIndex repository
    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)
      move_file_or_dir work old_fp new_fp

move_cmd opts args =
   withRepoLock opts $- \repository -> do
     relpaths <- map toFilePath `fmap` fixSubPaths opts args
     let moved = init relpaths
         finaldir = last relpaths
     move_to_dir repository opts moved finaldir

move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()
move_to_dir 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
    invalidateIndex repository
    withSignalsBlocked $ do
      add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches
      zipWithM_ (move_file_or_dir 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 (AllowWindowsReserved `elem` 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 -- We need to move the object
     then do unless (slurp_hasdir (super_name $ fp2fn new) work) $
                    fail $ "The target directory " ++
                             (fn2fp $ super_name $ 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 (super_name $ fp2fn new) cur) $
                    fail $ "The target directory " ++
                             (fn2fp $ super_name $ 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 AllowCaseOnly `elem` opts 
                          then slurp_has f s2
                          else slurp_has_anycase f s2
          already_exists what_slurpy =
              if AllowCaseOnly `elem` 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 ++ "."

move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO ()
move_file_or_dir work old new =
    if slurp_hasfile (fp2fn old) work
       then do debugMessage $ unwords ["renameFile",old,new]
               renameFile old new
       else if slurp_hasdir (fp2fn old) work
            then do debugMessage $ unwords ["renameDirectory",old,new]
                    renameDirectory old new
            else return ()

mv :: DarcsCommand
mv = command_alias "mv" move
\end{code}