1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376
|
{-# LANGUAGE RankNTypes #-}
-- 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.
{-# LANGUAGE CPP #-}
module Darcs.UI.Commands.Move ( move, mv ) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when, unless, forM_, forM )
import Data.Maybe ( fromMaybe )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository )
import Darcs.UI.Flags ( DarcsFlag(Quiet)
, doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask
, maybeFixSubPaths, fixSubPaths )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex )
import Darcs.Repository
( Repository
, withRepoLock
, RepoJob(..)
, addPendingDiffToPending
, listFiles
)
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft )
import Darcs.Util.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf )
import Darcs.Patch.Apply( ApplyState )
import Data.List ( nub, sort )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile )
import Darcs.Util.Tree( Tree, modifyTree )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Path
( floatPath
, fp2fn
, fn2fp
, superName
, SubPath()
, toFilePath
, AbsolutePath
)
import Darcs.Util.Workaround ( renameFile )
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"
moveBasicOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts = O.allowProblematicFilenames ^ O.workingRepoDir
moveAdvancedOpts :: DarcsOption a (O.UMask -> a)
moveAdvancedOpts = O.umask
moveOpts :: DarcsOption a
(Bool
-> Bool
-> Maybe String
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.UMask
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts
move :: DarcsCommand [DarcsFlag]
move = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "move"
, commandHelp = moveHelp
, commandDescription = moveDescription
, commandExtraArgs = -1
, commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]
, commandCommand = moveCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = listFiles False
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc moveAdvancedOpts
, commandBasicOptions = odesc moveBasicOpts
, commandDefaults = defaultFlags moveOpts
, commandCheckOptions = ocheck moveOpts
, commandParseOptions = onormalise moveOpts
}
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd fps opts args
| length args < 2 =
fail "The `darcs move' command requires at least two arguments."
| length args == 2 = do
-- NOTE: The extra case for two arguments is necessary because
-- in this case we allow file -> file moves. Whereas with 3 or
-- more arguments the last one (i.e. the target) must be a directory.
xs <- maybeFixSubPaths fps 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 fps [to]
case x of
Nothing -> fail "Invalid destination directory."
Just to' -> do
xs <- nub . sort <$> fixSubPaths fps froms
if to' `elem` xs
then fail "Cannot rename a file or directory onto itself."
else case xs of
[] -> fail "Nothing to move."
froms' ->
if or (map (null . toFilePath) froms') then
fail "Cannot move the root of the repository."
else
moveFilesToDir opts froms' to'
data FileKind = Dir | File
deriving (Show, Eq)
data FileStatus =
Nonexistant
| Unadded FileKind
| Shadow FileKind -- ^ known to darcs, but absent in working copy
| Known FileKind
deriving Show
fileStatus :: Tree IO -- ^ tree of the working directory
-> Tree IO -- ^ tree of recorded and pending changes
-> Tree IO -- ^ tree of recorded changes
-> FilePath
-> IO FileStatus
fileStatus work cur recorded fp = do
existsInCur <- treeHas cur fp
existsInRec <- treeHas recorded fp
existsInWork <- treeHas work fp
case (existsInRec, existsInCur, existsInWork) 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
-- | Takes two filenames (as 'Subpath'), and tries to move the first
-- into/onto the second. Needs to guess what that means: renaming or moving
-- into a directory, and whether it is a post-hoc move.
moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile opts old new = withRepoAndState opts $ \(repo, work, cur, recorded) -> do
let old_fp = toFilePath old
new_fp = toFilePath new
new_fs <- fileStatus work cur recorded new_fp
old_fs <- fileStatus work cur recorded old_fp
let doSimpleMove = simpleMove repo opts cur work old_fp new_fp
case (old_fs, new_fs) of
(Nonexistant, _) -> fail $ old_fp ++ " does not exist."
(Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."
(Known _, Nonexistant) -> doSimpleMove
(Known _, Shadow _) -> doSimpleMove
(_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."
(Known _, Known Dir) -> moveToDir repo opts cur work [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' -> doSimpleMove
(Shadow File, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp
(Shadow Dir, Known Dir) -> doSimpleMove
(Shadow File, Known File) -> doSimpleMove
(Shadow k, _) -> fail $
"cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp
++ " : " ++ "did you already move it elsewhere?"
moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir opts froms to = withRepoAndState opts $ \(repo, work, cur, _) ->
moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to
withRepoAndState :: [DarcsFlag]
-> (forall rt p wR wU .
(ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO)
-> IO ())
-> IO ()
withRepoAndState opts f =
withRepoLock dr uc YesUpdateWorking um $ RepoJob $ \repo -> do
work <- readPlainTree "."
cur <- readRecordedAndPending repo
recorded <- readRecorded repo
f (repo, work, cur, recorded)
where
dr = dryRun opts
uc = useCache opts
um = umask opts
simpleMove :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath
-> IO ()
simpleMove repository opts cur work old_fp new_fp = do
doMoves repository opts cur work [(old_fp, new_fp)]
unless (Quiet `elem` opts) $
putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp]
moveToDir :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath
-> IO ()
moveToDir repository opts cur work moved finaldir = do
let movetargets = map ((finaldir </>) . takeFileName) moved
moves = zip moved movetargets
doMoves repository opts cur work moves
unless (Quiet `elem` opts) $
putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir]
doMoves :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO
-> [(FilePath, FilePath)] -> IO ()
doMoves repository opts cur work moves = do
patches <- forM moves $ \(old, new) -> do
prePatch <- generatePreMovePatches opts cur work (old,new)
return (prePatch, old, new)
withSignalsBlocked $ do
forM_ patches $ \(prePatch, old, new) -> do
let -- Add any pre patches before the move patch
pendingDiff = joinGap (+>+)
(fromMaybe (emptyGap NilFL) prePatch)
(freeGap $ Darcs.Patch.move old new :>: NilFL)
addPendingDiffToPending repository YesUpdateWorking pendingDiff
moveFileOrDir work old new
updateIndex repository
-- Take the recorded/ working trees and the old and intended new filenames;
-- check if the new path is safe on windows. We potentially need to create
-- extra patches that are required to keep the repository consistent, in order
-- to allow the move patch to be applied.
generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO
-> (FilePath, FilePath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches opts cur work (old,new) = do
-- Only allow Windows-invalid paths if we've been told to do so
unless newIsOkWindowsPath $ fail newNotOkWindowsPathMsg
-- Check if the first directory above the new path is in the repo (this
-- is the new path if itself is a directory), handling the case where
-- a user moves a file into a directory not known by darcs.
let dirPath = fn2fp $ superName $ fp2fn new
haveNewParent <- treeHasDir cur dirPath
unless haveNewParent $
fail $ "The target directory " ++ dirPath
++ " isn't known in the repository, did you forget to add it?"
newInRecorded <- hasNew cur
newInWorking <- hasNew work
oldInWorking <- treeHas work old
if oldInWorking -- We need to move the object
then do
-- We can't move if the target already exists in working
when newInWorking $ fail $ alreadyExists "working directory"
if newInRecorded
then Just <$> deleteNewFromRepoPatches
else return Nothing
else do
unless (Quiet `elem` opts) $
putStrLn "Detected post-hoc move."
-- Post-hoc move - user has moved/deleted the file in working, so
-- we can hopefully make a move patch to make the repository
-- consistent.
-- If we don't have the old or new in working, we're stuck
unless newInWorking $
fail $ "Cannot determine post-hoc move target, "
++ "no file/dir named:\n" ++ new
Just <$> if newInRecorded
then deleteNewFromRepoPatches
else return $ emptyGap NilFL
where
newIsOkWindowsPath =
doAllowWindowsReserved opts || WindowsFilePath.isValid new
newNotOkWindowsPathMsg =
"The filename " ++ new ++ " is not valid under Windows.\n"
++ "Use --reserved-ok to allow such filenames."
-- If we're moving to a file/dir that was recorded, but has been deleted,
-- we need to add patches to pending that remove the original.
deleteNewFromRepoPatches = do
unless (Quiet `elem` opts) $
putStrLn $ "Existing recorded contents of " ++ new
++ " will be overwritten."
ftf <- filetypeFunction
let curNoNew = modifyTree cur (floatPath new) Nothing
-- Return patches to remove new, so that the move patch
-- can move onto new
treeDiff MyersDiff ftf cur curNoNew
-- Check if the passed tree has the new filepath. The old path is removed
-- from the tree before checking if the new path is present.
hasNew s = treeHas_case (modifyTree s (floatPath old) Nothing) new
treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase
alreadyExists inWhat =
if doAllowCaseOnly opts
then "A file or dir named "++new++" already exists in "
++ inWhat ++ "."
else "A file or dir named "++new++" (or perhaps differing "
++ "only in case)\nalready exists in "++ inWhat ++ ".\n"
++ "Use --case-ok to allow files differing only in case."
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 [DarcsFlag]
mv = commandAlias "mv" Nothing move
|