% 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, 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" ++
     -- 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 {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 -- We need to move the object
         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" Nothing move

\end{code}