{-# 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.

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
    , putInfo
    )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , allowCaseDifferingFilenames, allowWindowsReservedFilenames
    , useCache, dryRun, umask
    , maybeFixSubPaths, fixSubPaths
    )
import Darcs.UI.Options ( (^), 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
    )
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 )
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.Printer ( text, hsep )
import Darcs.Util.Workaround ( renameFile )

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

moveHelp :: String
moveHelp :: String
moveHelp =
 "Darcs cannot reliably distinguish between a file being deleted and a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "new one added, and a file being moved.  Therefore Darcs always assumes\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "the former, and provides the `darcs mv` command to let Darcs know when\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "you want the latter.  This command will also move the file in the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "working tree (unlike `darcs remove`), unless it has already been moved.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 -- 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" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "the same name, except for case.  The `--case-ok` option overrides this\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "behaviour.  Windows and OS X usually use filesystems that do not allow\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "files a folder to have the same name except for case (for example,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "unusable on those systems!\n"

move :: DarcsCommand [DarcsFlag]
move :: DarcsCommand [DarcsFlag]
move = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "move"
    , commandHelp :: String
commandHelp = String
moveHelp
    , commandDescription :: String
commandDescription = String
moveDescription
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
moveOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
moveOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
moveOpts
    }
  where
    moveBasicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts = DarcsOption (Maybe String -> a) (Bool -> Bool -> Maybe String -> a)
forall a. DarcsOption a (Bool -> Bool -> a)
O.allowProblematicFilenames DarcsOption (Maybe String -> a) (Bool -> Bool -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    moveAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
    moveOpts :: DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
moveOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Bool
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UMask
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts

moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args
  | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 =
      String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "The `darcs move' command requires at least two arguments."
  | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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.
      [Maybe SubPath]
xs <- (AbsolutePath, AbsolutePath) -> [String] -> IO [Maybe SubPath]
maybeFixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args
      case [Maybe SubPath]
xs of
        [Just from :: SubPath
from, Just to :: SubPath
to]
          | SubPath
from SubPath -> SubPath -> Bool
forall a. Eq a => a -> a -> Bool
== SubPath
to -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot rename a file or directory onto itself."
          | SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
from String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot move the root of the repository."
          | Bool
otherwise -> [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile [DarcsFlag]
opts SubPath
from SubPath
to
        _ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Both source and destination must be valid."
  | Bool
otherwise = let (froms :: [String]
froms, to :: String
to) = ([String] -> [String]
forall a. [a] -> [a]
init [String]
args, [String] -> String
forall a. [a] -> a
last [String]
args) in do
      Maybe SubPath
x <- [Maybe SubPath] -> Maybe SubPath
forall a. [a] -> a
head ([Maybe SubPath] -> Maybe SubPath)
-> IO [Maybe SubPath] -> IO (Maybe SubPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [Maybe SubPath]
maybeFixSubPaths (AbsolutePath, AbsolutePath)
fps [String
to]
      case Maybe SubPath
x of
        Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Invalid destination directory."
        Just to' :: SubPath
to' -> do
          [SubPath]
xs <- [SubPath] -> [SubPath]
forall a. Eq a => [a] -> [a]
nub ([SubPath] -> [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
sort ([SubPath] -> [SubPath]) -> IO [SubPath] -> IO [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
froms
          if SubPath
to' SubPath -> [SubPath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SubPath]
xs
            then String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot rename a file or directory onto itself."
            else case [SubPath]
xs of
              [] -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Nothing to move."
              froms' :: [SubPath]
froms' ->
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((SubPath -> Bool) -> [SubPath] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (SubPath -> String) -> SubPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath) [SubPath]
froms') then
                  String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot move the root of the repository."
                else
                  [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir [DarcsFlag]
opts [SubPath]
froms' SubPath
to'

data FileKind = Dir | File
              deriving (Int -> FileKind -> String -> String
[FileKind] -> String -> String
FileKind -> String
(Int -> FileKind -> String -> String)
-> (FileKind -> String)
-> ([FileKind] -> String -> String)
-> Show FileKind
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileKind] -> String -> String
$cshowList :: [FileKind] -> String -> String
show :: FileKind -> String
$cshow :: FileKind -> String
showsPrec :: Int -> FileKind -> String -> String
$cshowsPrec :: Int -> FileKind -> String -> String
Show, FileKind -> FileKind -> Bool
(FileKind -> FileKind -> Bool)
-> (FileKind -> FileKind -> Bool) -> Eq FileKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileKind -> FileKind -> Bool
$c/= :: FileKind -> FileKind -> Bool
== :: FileKind -> FileKind -> Bool
$c== :: FileKind -> FileKind -> Bool
Eq)

data FileStatus =
  Nonexistant
  | Unadded FileKind
  | Shadow FileKind -- ^ known to darcs, but absent in working copy
  | Known FileKind
  deriving Int -> FileStatus -> String -> String
[FileStatus] -> String -> String
FileStatus -> String
(Int -> FileStatus -> String -> String)
-> (FileStatus -> String)
-> ([FileStatus] -> String -> String)
-> Show FileStatus
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileStatus] -> String -> String
$cshowList :: [FileStatus] -> String -> String
show :: FileStatus -> String
$cshow :: FileStatus -> String
showsPrec :: Int -> FileStatus -> String -> String
$cshowsPrec :: Int -> FileStatus -> String -> String
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 :: Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus work :: Tree IO
work cur :: Tree IO
cur recorded :: Tree IO
recorded fp :: String
fp = do
  Bool
existsInCur <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
cur String
fp
  Bool
existsInRec <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
recorded String
fp
  Bool
existsInWork <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
work String
fp
  case (Bool
existsInRec, Bool
existsInCur, Bool
existsInWork) of
    (_, True, True) -> do
      Bool
isDirCur <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
fp
      Bool
isDirWork <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
fp
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isDirCur Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isDirWork) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "don't know what to do with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
      FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus)
-> (FileKind -> FileStatus) -> FileKind -> IO FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileKind -> FileStatus
Known (FileKind -> IO FileStatus) -> FileKind -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ if Bool
isDirCur then FileKind
Dir else FileKind
File

    (_, False, True) -> do
      Bool
isDir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
fp
      if Bool
isDir
        then FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
Dir
        else FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Unadded FileKind
File
    (False, False, False) -> FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
Nonexistant
    (_, _, False) -> do
      Bool
isDir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
fp
      if Bool
isDir
        then FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
Dir
        else FileStatus -> IO FileStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> IO FileStatus) -> FileStatus -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileKind -> FileStatus
Shadow FileKind
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 :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile opts :: [DarcsFlag]
opts old :: SubPath
old new :: SubPath
new = [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (ApplyState p ~ Tree, RepoPatch p) =>
    (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (ApplyState p ~ Tree, RepoPatch p) =>
  (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
 -> IO ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (ApplyState p ~ Tree, RepoPatch p) =>
    (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(repo :: Repository rt p wR wU wR
repo, work :: Tree IO
work, cur :: Tree IO
cur, recorded :: Tree IO
recorded) -> do
  let old_fp :: String
old_fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
old
      new_fp :: String
new_fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
new
  FileStatus
new_fs <- Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded String
new_fp
  FileStatus
old_fs <- Tree IO -> Tree IO -> Tree IO -> String -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded String
old_fp
  let doSimpleMove :: IO ()
doSimpleMove = Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
simpleMove Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work String
old_fp String
new_fp
  case (FileStatus
old_fs, FileStatus
new_fs) of
    (Nonexistant, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " does not exist."
    (Unadded k :: FileKind
k, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ FileKind -> String
forall a. Show a => a -> String
show FileKind
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is unadded."
    (Known _, Nonexistant) -> IO ()
doSimpleMove
    (Known _, Shadow _) -> IO ()
doSimpleMove
    (_, Nonexistant) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not in the repository."
    (Known _, Known Dir) -> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [String
old_fp] String
new_fp
    (Known _, Unadded Dir) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
new_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not known to darcs; please add it to the repository."
    (Known _, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
new_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already exists."
    (Shadow k :: FileKind
k, Unadded k' :: FileKind
k') | FileKind
k FileKind -> FileKind -> Bool
forall a. Eq a => a -> a -> Bool
== FileKind
k' -> IO ()
doSimpleMove
    (Shadow File, Known Dir) -> Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [String
old_fp] String
new_fp
    (Shadow Dir, Known Dir) -> IO ()
doSimpleMove
    (Shadow File, Known File) -> IO ()
doSimpleMove
    (Shadow k :: FileKind
k, _) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "cannot move " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileKind -> String
forall a. Show a => a -> String
show FileKind
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old_fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new_fp
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ " : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "did you already move it elsewhere?"

moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir opts :: [DarcsFlag]
opts froms :: [SubPath]
froms to :: SubPath
to = [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (ApplyState p ~ Tree, RepoPatch p) =>
    (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState [DarcsFlag]
opts ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (ApplyState p ~ Tree, RepoPatch p) =>
  (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
 -> IO ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (ApplyState p ~ Tree, RepoPatch p) =>
    (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(repo :: Repository rt p wR wU wR
repo, work :: Tree IO
work, cur :: Tree IO
cur, _) ->
  Repository rt p wR wU wR
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath [SubPath]
froms) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
to

withRepoAndState :: [DarcsFlag]
                 -> (forall rt p wR wU .
                        (ApplyState p ~ Tree, RepoPatch p) =>
                            (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO)
                                -> IO ())
                 -> IO ()
withRepoAndState :: [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (ApplyState p ~ Tree, RepoPatch p) =>
    (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ())
-> IO ()
withRepoAndState opts :: [DarcsFlag]
opts f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f =
    DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
    (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repo :: Repository rt p wR wU wR
repo -> do
        Tree IO
work <- String -> IO (Tree IO)
readPlainTree "."
        Tree IO
cur <- Repository rt p wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repo
        Tree IO
recorded <- Repository rt p wR wU wR -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
        (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
(Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()
f (Repository rt p wR wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
recorded)

simpleMove :: (RepoPatch p, ApplyState p ~ Tree)
           => Repository rt p wR wU wT
           -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath
           -> IO ()
simpleMove :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> String -> String -> IO ()
simpleMove repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work old_fp :: String
old_fp new_fp :: String
new_fp = do
    Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves Repository rt p wR wU wT
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(String
old_fp, String
new_fp)]
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ["Moved:", String
old_fp, "to:", String
new_fp]

moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
          => Repository rt p wR wU wT
          -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath
          -> IO ()
moveToDir :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [String] -> String -> IO ()
moveToDir repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work moved :: [String]
moved finaldir :: String
finaldir = do
    let movetargets :: [String]
movetargets = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
finaldir String -> String -> String
</>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName) [String]
moved
        moves :: [(String, String)]
moves = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
moved [String]
movetargets
    Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves Repository rt p wR wU wT
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(String, String)]
moves
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ["Moved:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
moved [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["to:", String
finaldir]

doMoves :: (RepoPatch p, ApplyState p ~ Tree)
          => Repository rt p wR wU wT
          -> [DarcsFlag] -> Tree IO -> Tree IO
          -> [(FilePath, FilePath)] -> IO ()
doMoves :: Repository rt p wR wU wT
-> [DarcsFlag] -> Tree IO -> Tree IO -> [(String, String)] -> IO ()
doMoves repository :: Repository rt p wR wU wT
repository opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work moves :: [(String, String)]
moves = do
  [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
patches <- [(String, String)]
-> ((String, String)
    -> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
-> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
moves (((String, String)
  -> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
 -> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)])
-> ((String, String)
    -> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String))
-> IO [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
forall a b. (a -> b) -> a -> b
$ \(old :: String
old, new :: String
new) -> do
        Maybe (FreeLeft (FL (PrimOf p)))
prePatch <- [DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))))
forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (String
old,String
new)
        (Maybe (FreeLeft (FL (PrimOf p))), String, String)
-> IO (Maybe (FreeLeft (FL (PrimOf p))), String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL (PrimOf p)))
prePatch, String
old, String
new)
  IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
-> ((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe (FreeLeft (FL (PrimOf p))), String, String)]
patches (((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
 -> IO ())
-> ((Maybe (FreeLeft (FL (PrimOf p))), String, String) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(prePatch :: Maybe (FreeLeft (FL (PrimOf p)))
prePatch, old :: String
old, new :: String
new) -> do
      let -- Add any pre patches before the move patch
          pendingDiff :: FreeLeft (FL (PrimOf p))
pendingDiff = (forall wX wY wZ.
 FL (PrimOf p) wX wY -> FL (PrimOf p) wY wZ -> FL (PrimOf p) wX wZ)
-> FreeLeft (FL (PrimOf p))
-> FreeLeft (FL (PrimOf p))
-> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *)
       (q :: * -> * -> *) (r :: * -> * -> *).
Gap w =>
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> w p -> w q -> w r
joinGap forall wX wY wZ.
FL (PrimOf p) wX wY -> FL (PrimOf p) wY wZ -> FL (PrimOf p) wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+)
            (FreeLeft (FL (PrimOf p))
-> Maybe (FreeLeft (FL (PrimOf p))) -> FreeLeft (FL (PrimOf p))
forall a. a -> Maybe a -> a
fromMaybe ((forall wX. FL (PrimOf p) wX wX) -> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) Maybe (FreeLeft (FL (PrimOf p)))
prePatch)
            ((forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap ((forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p)))
-> (forall wX wY. FL (PrimOf p) wX wY) -> FreeLeft (FL (PrimOf p))
forall a b. (a -> b) -> a -> b
$ String -> String -> PrimOf p wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> prim wX wY
Darcs.Patch.move String
old String
new PrimOf p wX wY -> FL (PrimOf p) wY wY -> FL (PrimOf p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PrimOf p) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      Repository rt p wR wU wT
-> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending Repository rt p wR wU wT
repository UpdateWorking
YesUpdateWorking FreeLeft (FL (PrimOf p))
pendingDiff
      Tree IO -> String -> String -> IO ()
moveFileOrDir Tree IO
work String
old String
new
    Repository rt p wR wU wT -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
updateIndex Repository rt p wR wU wT
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 :: [DarcsFlag]
-> Tree IO
-> Tree IO
-> (String, String)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches opts :: [DarcsFlag]
opts cur :: Tree IO
cur work :: Tree IO
work (old :: String
old,new :: String
new) = do
    -- Only allow Windows-invalid paths if we've been told to do so
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newIsOkWindowsPath (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
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 :: String
dirPath = FileName -> String
fn2fp (FileName -> String) -> FileName -> String
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
superName (FileName -> FileName) -> FileName -> FileName
forall a b. (a -> b) -> a -> b
$ String -> FileName
fp2fn String
new
    Bool
haveNewParent <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
dirPath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveNewParent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "The target directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dirPath
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ " isn't known in the repository, did you forget to add it?"
    Bool
newInRecorded <- Tree IO -> IO Bool
hasNew Tree IO
cur
    Bool
newInWorking <- Tree IO -> IO Bool
hasNew Tree IO
work
    Bool
oldInWorking <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas Tree IO
work String
old
    if Bool
oldInWorking -- We need to move the object
        then do
            -- We can't move if the target already exists in working
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newInWorking (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
alreadyExists "working directory"
            if Bool
newInRecorded
                then FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> IO (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
                else Maybe (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing
        else do
          [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "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
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
newInWorking (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Cannot determine post-hoc move target, "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "no file/dir named:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new
          FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim))
forall a. a -> Maybe a
Just (FreeLeft (FL prim) -> Maybe (FreeLeft (FL prim)))
-> IO (FreeLeft (FL prim)) -> IO (Maybe (FreeLeft (FL prim)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
newInRecorded
                       then IO (FreeLeft (FL prim))
deleteNewFromRepoPatches
                       else FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX. FL prim wX wX) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
  where
    newIsOkWindowsPath :: Bool
newIsOkWindowsPath =
        PrimDarcsOption Bool
allowWindowsReservedFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Bool -> Bool -> Bool
|| String -> Bool
WindowsFilePath.isValid String
new

    newNotOkWindowsPathMsg :: String
newNotOkWindowsPathMsg =
        "The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not valid under Windows.\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 :: IO (FreeLeft (FL prim))
deleteNewFromRepoPatches = do
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
          "Existing recorded contents of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ " will be overwritten."
        String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
        let curNoNew :: Tree IO
curNoNew = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
cur (String -> AnchoredPath
floatPath String
new) Maybe (TreeItem IO)
forall a. Maybe a
Nothing
        -- Return patches to remove new, so that the move patch
        -- can move onto new
        DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL prim))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
MyersDiff String -> FileType
ftf Tree IO
cur Tree IO
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 :: Tree IO -> IO Bool
hasNew s :: Tree IO
s = Tree IO -> String -> IO Bool
treeHas_case (Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
s (String -> AnchoredPath
floatPath String
old) Maybe (TreeItem IO)
forall a. Maybe a
Nothing) String
new
    treeHas_case :: Tree IO -> String -> IO Bool
treeHas_case = if PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHas else Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasAnycase

    alreadyExists :: String -> String
alreadyExists inWhat :: String
inWhat =
        if PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
            then "A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newString -> String -> String
forall a. [a] -> [a] -> [a]
++" already exists in "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
            else "A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newString -> String -> String
forall a. [a] -> [a] -> [a]
++" (or perhaps differing "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "only in case)\nalready exists in "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Use --case-ok to allow files differing only in case."

moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()
moveFileOrDir :: Tree IO -> String -> String -> IO ()
moveFileOrDir work :: Tree IO
work old :: String
old new :: String
new = do
  Bool
has_file <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasFile Tree IO
work String
old
  Bool
has_dir <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
work String
old
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_file (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ["renameFile",String
old,String
new]
                     String -> String -> IO ()
renameFile String
old String
new
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ["renameDirectory",String
old,String
new]
                    String -> String -> IO ()
renameDirectory String
old String
new

mv :: DarcsCommand [DarcsFlag]
mv :: DarcsCommand [DarcsFlag]
mv = String
-> Maybe (DarcsCommand [DarcsFlag])
-> DarcsCommand [DarcsFlag]
-> DarcsCommand [DarcsFlag]
forall pf.
String
-> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias "mv" Maybe (DarcsCommand [DarcsFlag])
forall a. Maybe a
Nothing DarcsCommand [DarcsFlag]
move