--  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 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, pathsFromArgs
    )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( UpdatePending (..), DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.Directory ( renameDirectory, renameFile )
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.Ordered ( nubSort )
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
    ( AbsolutePath
    , AnchoredPath
    , displayPath
    , isRoot
    , parent
    , realPath
    , replaceParent
    )
import Darcs.Util.Printer ( Doc, text, hsep )

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

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

move :: DarcsCommand
move :: DarcsCommand
move = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"move"
    , commandHelp :: Doc
commandHelp = Doc
moveHelp
    , commandDescription :: String
commandDescription = String
moveDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
moveOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
moveOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Bool
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Bool
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
moveAdvancedOpts

moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [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
< Int
2 =
      String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The `darcs move' command requires at least two arguments."
  | Bool
otherwise = do
      [AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([AnchoredPath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnchoredPath]
paths Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Note enough valid path arguments remaining."
      case [AnchoredPath]
paths of
        [AnchoredPath
from, AnchoredPath
to] -> 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.
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
from AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
to) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath -> Bool
isRoot AnchoredPath
from) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
          [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()
moveFile [DarcsFlag]
opts AnchoredPath
from AnchoredPath
to
        [AnchoredPath]
_ -> do
          let froms :: [AnchoredPath]
froms = [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a]
init [AnchoredPath]
paths
              to :: AnchoredPath
to = [AnchoredPath] -> AnchoredPath
forall a. [a] -> a
last [AnchoredPath]
paths
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnchoredPath
to AnchoredPath -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
froms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot rename a file or directory onto itself."
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredPath -> Bool
isRoot [AnchoredPath]
froms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot move the root of the repository."
          [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir [DarcsFlag]
opts ([AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort [AnchoredPath]
froms) AnchoredPath
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 tree
  | 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
           -> AnchoredPath
           -> IO FileStatus
fileStatus :: Tree IO -> Tree IO -> Tree IO -> AnchoredPath -> IO FileStatus
fileStatus Tree IO
work Tree IO
cur Tree IO
recorded AnchoredPath
fp = do
  Bool
existsInCur <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur AnchoredPath
fp
  Bool
existsInRec <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
recorded AnchoredPath
fp
  Bool
existsInWork <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
work AnchoredPath
fp
  case (Bool
existsInRec, Bool
existsInCur, Bool
existsInWork) of
    (Bool
_, Bool
True, Bool
True) -> do
      Bool
isDirCur <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
fp
      Bool
isDirWork <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
fp
      -- TODO is this an impossible case? else improve the error message!
      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
$ String
"don't know what to do with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
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

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

moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()
moveFilesToDir [DarcsFlag]
opts [AnchoredPath]
froms AnchoredPath
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
$ \(Repository rt p wR wU wR
repo, Tree IO
work, Tree IO
cur, Tree IO
_) -> do
    Bool
froms_exist <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AnchoredPath] -> (AnchoredPath -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
froms (Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
cur)
    if Bool
froms_exist then
      Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repo [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath]
froms AnchoredPath
to
    else
      String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Some of the paths you want to move aren't know to darcs. Use `darcs add` to add them first."

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 [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 ()
f =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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
$ \Repository rt p wR wU wR
repo -> do
        Tree IO
work <- String -> IO (Tree IO)
readPlainTree String
"."
        Tree IO
cur <- Repository rt p wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> 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 wR
           -> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath
           -> IO ()
simpleMove :: Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> AnchoredPath
-> AnchoredPath
-> IO ()
simpleMove Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work AnchoredPath
old AnchoredPath
new = do
    Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath
old, AnchoredPath
new)]
    [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
"Finished moving:", AnchoredPath -> String
displayPath AnchoredPath
old, String
"to:", AnchoredPath -> String
displayPath AnchoredPath
new]

moveToDir :: (RepoPatch p, ApplyState p ~ Tree)
          => Repository rt p wR wU wR
          -> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath
          -> IO ()
moveToDir :: Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [AnchoredPath]
-> AnchoredPath
-> IO ()
moveToDir Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [AnchoredPath]
moved AnchoredPath
finaldir = do
    -- note: we already checked that @moved@ is not the root,
    -- so we know that replaceParentPath can't fail
    let replaceParentPath :: AnchoredPath -> AnchoredPath -> AnchoredPath
replaceParentPath AnchoredPath
a1 AnchoredPath
a2 =
          AnchoredPath -> Maybe AnchoredPath -> AnchoredPath
forall a. a -> Maybe a -> a
fromMaybe (String -> AnchoredPath
forall a. HasCallStack => String -> a
error String
"cannot replace parent of root path") (Maybe AnchoredPath -> AnchoredPath)
-> Maybe AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> AnchoredPath -> Maybe AnchoredPath
replaceParent AnchoredPath
a1 AnchoredPath
a2
    let moves :: [(AnchoredPath, AnchoredPath)]
moves = [AnchoredPath] -> [AnchoredPath] -> [(AnchoredPath, AnchoredPath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [AnchoredPath]
moved ([AnchoredPath] -> [(AnchoredPath, AnchoredPath)])
-> [AnchoredPath] -> [(AnchoredPath, AnchoredPath)]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> AnchoredPath) -> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath
replaceParentPath AnchoredPath
finaldir) [AnchoredPath]
moved
    Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
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
$ [String
"Finished moving:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
moved [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"to:", AnchoredPath -> String
displayPath AnchoredPath
finaldir]

doMoves :: (RepoPatch p, ApplyState p ~ Tree)
          => Repository rt p wR wU wR
          -> [DarcsFlag] -> Tree IO -> Tree IO
          -> [(AnchoredPath, AnchoredPath)] -> IO ()
doMoves :: Repository rt p wR wU wR
-> [DarcsFlag]
-> Tree IO
-> Tree IO
-> [(AnchoredPath, AnchoredPath)]
-> IO ()
doMoves Repository rt p wR wU wR
repository [DarcsFlag]
opts Tree IO
cur Tree IO
work [(AnchoredPath, AnchoredPath)]
moves = do
  [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches <- [(AnchoredPath, AnchoredPath)]
-> ((AnchoredPath, AnchoredPath)
    -> IO
         (Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
-> IO
     [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(AnchoredPath, AnchoredPath)]
moves (((AnchoredPath, AnchoredPath)
  -> IO
       (Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
 -> IO
      [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)])
-> ((AnchoredPath, AnchoredPath)
    -> IO
         (Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath))
-> IO
     [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
forall a b. (a -> b) -> a -> b
$ \(AnchoredPath
old, AnchoredPath
new) -> do
        Maybe (FreeLeft (FL (PrimOf p)))
prePatch <- [DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL (PrimOf p))))
forall (prim :: * -> * -> *).
PrimPatch prim =>
[DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (AnchoredPath
old,AnchoredPath
new)
        (Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
-> IO
     (Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FreeLeft (FL (PrimOf p)))
prePatch, AnchoredPath
old, AnchoredPath
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))), AnchoredPath, AnchoredPath)]
-> ((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)]
patches (((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
  -> IO ())
 -> IO ())
-> ((Maybe (FreeLeft (FL (PrimOf p))), AnchoredPath, AnchoredPath)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe (FreeLeft (FL (PrimOf p)))
prePatch, AnchoredPath
old, AnchoredPath
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
$ AnchoredPath -> AnchoredPath -> PrimOf p wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
Darcs.Patch.move AnchoredPath
old AnchoredPath
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 wR -> FreeLeft (FL (PrimOf p)) -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending Repository rt p wR wU wR
repository FreeLeft (FL (PrimOf p))
pendingDiff
      Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir Tree IO
work AnchoredPath
old AnchoredPath
new
    Repository rt p wR wU wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ()
updateIndex Repository rt p wR wU wR
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
                       -> (AnchoredPath, AnchoredPath)
                       -> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches :: [DarcsFlag]
-> Tree IO
-> Tree IO
-> (AnchoredPath, AnchoredPath)
-> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches [DarcsFlag]
opts Tree IO
cur Tree IO
work (AnchoredPath
old,AnchoredPath
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 :: AnchoredPath
dirPath =
          AnchoredPath -> Maybe AnchoredPath -> AnchoredPath
forall a. a -> Maybe a -> a
fromMaybe (String -> AnchoredPath
forall a. HasCallStack => String -> a
error String
"unexpected root path in generatePreMovePatches") (Maybe AnchoredPath -> AnchoredPath)
-> Maybe AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
new
    Bool
haveNewParent <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
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
$ String
"The target directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
dirPath
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas Tree IO
work AnchoredPath
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 String
"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 String
"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
$ String
"Cannot determine post-hoc move target, "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"no file/dir named:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
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 (AnchoredPath -> String
realPath AnchoredPath
new)

    newNotOkWindowsPathMsg :: String
newNotOkWindowsPathMsg =
        String
"The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not valid under Windows.\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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
$
          String
"Existing recorded contents of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 AnchoredPath
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 Tree IO
s = Tree IO -> AnchoredPath -> 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 AnchoredPath
old Maybe (TreeItem IO)
forall a. Maybe a
Nothing) AnchoredPath
new
    treeHas_case :: Tree IO -> AnchoredPath -> 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 -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas else Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasAnycase

    alreadyExists :: String -> String
alreadyExists 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 String
"A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" already exists in "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
            else String
"A file or dir named "String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
displayPath AnchoredPath
newString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" (or perhaps differing "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"only in case)\nalready exists in "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inWhat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".\n"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Use --case-ok to allow files differing only in case."

moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO ()
moveFileOrDir Tree IO
work AnchoredPath
old AnchoredPath
new = do
  Bool
has_file <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasFile Tree IO
work AnchoredPath
old
  Bool
has_dir <- Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
work AnchoredPath
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 [String
"renameFile", AnchoredPath -> String
displayPath AnchoredPath
old, AnchoredPath -> String
displayPath AnchoredPath
new]
    String -> String -> IO ()
renameFile (AnchoredPath -> String
realPath AnchoredPath
old) (AnchoredPath -> String
realPath AnchoredPath
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 [String
"renameDirectory", AnchoredPath -> String
displayPath AnchoredPath
old, AnchoredPath -> String
displayPath AnchoredPath
new]
    String -> String -> IO ()
renameDirectory (AnchoredPath -> String
realPath AnchoredPath
old) (AnchoredPath -> String
realPath AnchoredPath
new)

mv :: DarcsCommand
mv :: DarcsCommand
mv = String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias String
"mv" Maybe DarcsCommand
forall a. Maybe a
Nothing DarcsCommand
move