module Darcs.UI.Commands.Add ( add ) where
import Prelude ()
import Darcs.Prelude
import Control.Exception ( catch, IOException )
import Control.Monad ( when, unless )
import Data.List ( (\\), nub )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( isNothing, maybeToList )
import Darcs.Util.Printer ( text )
import Darcs.Util.Tree ( Tree, findTree, expand )
import Darcs.Util.Path
( floatPath, anchorPath, parents
, SubPath, toFilePath, AbsolutePath
)
import System.FilePath.Posix ( takeDirectory )
import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )
import System.Directory ( getPermissions, readable )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning
, nodefaults, amInHashedRepository)
import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase )
import Darcs.UI.Commands.Util ( expandDirs, doesDirectoryReallyExist )
import Darcs.UI.Completion ( unknownFileArgs )
import Darcs.UI.Flags
( DarcsFlag
, includeBoring, allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask
, fixSubPaths, quiet )
import Darcs.UI.Options
( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking(..) )
import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Repository.State ( readRecordedAndPending, updateIndex )
import Darcs.Repository
( withRepoLock
, RepoJob(..)
, addToPending
)
import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )
import Darcs.Util.File ( getFileStatus )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )
addDescription :: String
addDescription :: String
addDescription = "Add new files to version control."
addHelp :: String
addHelp :: String
addHelp =
"Generally the working tree contains both files that should be version\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"controlled (such as source code) and files that Darcs should ignore\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"(such as executables compiled from the source code). The `darcs add`\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"command is used to tell Darcs which files to version control.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"When an existing project is first imported into a Darcs repository, it\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"is common to run `darcs add -r *` or `darcs record -l` to add all\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"initial source files into darcs.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Adding symbolic links (symlinks) is not supported.\n\n"
addHelp' :: String
addHelp' :: String
addHelp' =
"Darcs will ignore all files and folders that look \"boring\". The\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"`--boring` option overrides this behaviour.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Darcs will not add file if another file in the same folder has the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"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\n"
add :: DarcsCommand [DarcsFlag]
add :: DarcsCommand [DarcsFlag]
add = 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 = "add"
, commandHelp :: String
commandHelp = String
addHelp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
addHelp'
, commandDescription :: String
commandDescription = String
addDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [ "<FILE or DIRECTORY> ..." ]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
addCmd
, 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]
unknownFileArgs
, 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
addAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
DarcsFlag
Any
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> Any)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> 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]
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
addOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> 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
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
addOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> 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]
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
addOpts
}
where
addBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts
= PrimOptSpec
DarcsOptDescr
DarcsFlag
(Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
IncludeBoring
PrimDarcsOption IncludeBoring
O.includeBoring
PrimOptSpec
DarcsOptDescr
DarcsFlag
(Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
IncludeBoring
-> OptSpec
DarcsOptDescr
DarcsFlag
(Bool -> Maybe String -> DryRun -> a)
(Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Bool -> Maybe String -> DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> 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
(Bool -> Maybe String -> DryRun -> a)
(Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
forall a. DarcsOption a (Bool -> Bool -> a)
O.allowProblematicFilenames
OptSpec
DarcsOptDescr
DarcsFlag
(Bool -> Maybe String -> DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DryRun -> a)
(Bool -> Maybe String -> DryRun -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> 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
(Maybe String -> DryRun -> a)
(Bool -> Maybe String -> DryRun -> a)
PrimDarcsOption Bool
O.recursive
OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
-> OptSpec
DarcsOptDescr DarcsFlag (DryRun -> a) (Maybe String -> DryRun -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> 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 (DryRun -> a) (Maybe String -> DryRun -> a)
PrimDarcsOption (Maybe String)
O.repoDir
OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> a)
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DryRun -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> 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 (DryRun -> a)
PrimDarcsOption DryRun
O.dryRun
addAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
addAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
addOpts :: DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
addOpts = DarcsOption
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> 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
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
addAdvancedOpts
addCmd :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO ()
addCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
addCmd paths :: (AbsolutePath, AbsolutePath)
paths opts :: [DarcsFlag]
opts args :: [String]
args
| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Nothing specified, nothing added." String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Maybe you wanted to say `darcs add --recursive .'?"
| Bool
otherwise = do
[SubPath]
fs <- (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
paths [String]
args
case [SubPath]
fs of
[] -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No valid arguments were given"
_ -> [DarcsFlag] -> [SubPath] -> IO ()
addFiles [DarcsFlag]
opts [SubPath]
fs
addFiles :: [DarcsFlag]
-> [SubPath]
-> IO ()
addFiles :: [DarcsFlag] -> [SubPath] -> IO ()
addFiles opts :: [DarcsFlag]
opts origfiles :: [SubPath]
origfiles =
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
$ \repository :: Repository rt p wR wU wR
repository -> do
Tree IO
cur <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
repository
let parlist :: [String]
parlist = Tree IO -> [String] -> [String]
getParents Tree IO
cur ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath [SubPath]
origfiles)
[SubPath]
flist' <- if PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.recursive [DarcsFlag]
opts
then Bool -> [SubPath] -> IO [SubPath]
expandDirs ([DarcsFlag] -> Bool
includeBoring [DarcsFlag]
opts) [SubPath]
origfiles
else [SubPath] -> IO [SubPath]
forall (m :: * -> *) a. Monad m => a -> m a
return [SubPath]
origfiles
let flist :: [String]
flist = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort ([String]
parlist [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath (SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
`map` [SubPath]
flist')
[String] -> [String]
nboring <- if [DarcsFlag] -> Bool
includeBoring [DarcsFlag]
opts
then ([String] -> [String]) -> IO ([String] -> [String])
forall (m :: * -> *) a. Monad m => a -> m a
return [String] -> [String]
darcsdirFilter
else IO ([String] -> [String])
boringFileFilter
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AddMessages -> String
msgSkipping AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " boring file ")String -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
[String]
flist [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
nboring [String]
flist
Sealed ps :: FL (PrimOf p) wU wX
ps <- (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wU))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wU))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wU)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wU)))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wU))
forall a b. (a -> b) -> a -> b
$ AddMessages
-> [DarcsFlag]
-> Tree IO
-> [String]
-> IO (FreeLeft (FL (PrimOf p)))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AddMessages
-> [DarcsFlag] -> Tree IO -> [String] -> IO (FreeLeft (FL prim))
addp AddMessages
msgs [DarcsFlag]
opts Tree IO
cur ([String] -> IO (FreeLeft (FL (PrimOf p))))
-> [String] -> IO (FreeLeft (FL (PrimOf p)))
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
nboring [String]
flist
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FL (PrimOf p) wU wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wU wX
ps Bool -> Bool -> Bool
&& Bool -> Bool
not ([SubPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubPath]
origfiles) Bool -> Bool -> Bool
&& Bool -> Bool
not ([DarcsFlag] -> Bool
quiet [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No files were added"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gotDryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking FL (PrimOf p) wU wX
ps
Repository rt p wR wU wR -> 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 wR
repository
where
gotDryRun :: Bool
gotDryRun = PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts DryRun -> DryRun -> Bool
forall a. Eq a => a -> a -> Bool
== DryRun
O.YesDryRun
msgs :: AddMessages
msgs | Bool
gotDryRun = AddMessages
dryRunMessages
| Bool
otherwise = AddMessages
normalMessages
addp :: forall prim . (PrimPatch prim, ApplyState prim ~ Tree)
=> AddMessages
-> [DarcsFlag]
-> Tree IO
-> [FilePath]
-> IO (FreeLeft (FL prim))
addp :: AddMessages
-> [DarcsFlag] -> Tree IO -> [String] -> IO (FreeLeft (FL prim))
addp msgs :: AddMessages
msgs opts :: [DarcsFlag]
opts cur0 :: Tree IO
cur0 files :: [String]
files = do
(ps :: [FreeLeft (FL prim)]
ps, dups :: [String]
dups) <-
(String
-> (Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String]))
-> Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String]))
-> (Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String]))
-> [String]
-> Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\f :: String
f rest :: Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String])
rest cur :: Tree IO
cur accPS :: [FreeLeft (FL prim)]
accPS accDups :: [String]
accDups -> do
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
addResult <- Tree IO
-> String -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
addp' Tree IO
cur String
f
case (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
addResult of
(_, Nothing, Nothing) -> ([FreeLeft (FL prim)], [String])
-> IO ([FreeLeft (FL prim)], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
(cur' :: Tree IO
cur', mp :: Maybe (FreeLeft (FL prim))
mp, mdup :: Maybe String
mdup) -> Tree IO
-> [FreeLeft (FL prim)]
-> [String]
-> IO ([FreeLeft (FL prim)], [String])
rest Tree IO
cur' (Maybe (FreeLeft (FL prim)) -> [FreeLeft (FL prim)]
forall a. Maybe a -> [a]
maybeToList Maybe (FreeLeft (FL prim))
mp [FreeLeft (FL prim)]
-> [FreeLeft (FL prim)] -> [FreeLeft (FL prim)]
forall a. [a] -> [a] -> [a]
++ [FreeLeft (FL prim)]
accPS) (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
mdup [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
accDups))
(\_ ps :: [FreeLeft (FL prim)]
ps dups :: [String]
dups -> ([FreeLeft (FL prim)], [String])
-> IO ([FreeLeft (FL prim)], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FreeLeft (FL prim)] -> [FreeLeft (FL prim)]
forall a. [a] -> [a]
reverse [FreeLeft (FL prim)]
ps, [String]
dups))
[String]
files
Tree IO
cur0 [] []
let uniq_dups :: [String]
uniq_dups = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
dups
caseMsg :: String
caseMsg =
if Bool
gotAllowCaseOnly then ":"
else ";\nnote that to ensure portability we don't allow\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"files that differ only in case. Use --case-ok to override this:"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
dups) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String
dupMsg <-
case [String]
uniq_dups of
[f :: String
f] -> do
Bool
isDir <- String -> IO Bool
doesDirectoryReallyExist String
f
if Bool
isDir
then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"The following directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgIs AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already in the repository"
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"The following file " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgIs AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already in the repository"
fs :: [String]
fs -> do
[Bool]
areDirs <- (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Bool
doesDirectoryReallyExist [String]
fs
if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
areDirs
then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"The following directories " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already in the repository"
else
(if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
areDirs
then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"The following files and directories " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already in the repository"
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"The following files " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already in the repository")
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "WARNING: Some files were not added because they are already in the repository."
[DarcsFlag] -> Doc -> IO ()
putVerboseWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dupMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
caseMsg
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([DarcsFlag] -> Doc -> IO ()
putVerboseWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) [String]
uniq_dups
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
$ (FreeLeft (FL prim) -> FreeLeft (FL prim) -> FreeLeft (FL prim))
-> FreeLeft (FL prim) -> [FreeLeft (FL prim)] -> FreeLeft (FL prim)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((forall wX wY wZ. FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ)
-> FreeLeft (FL prim) -> FreeLeft (FL prim) -> FreeLeft (FL prim)
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 prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+)) ((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) [FreeLeft (FL prim)]
ps
where
addp' :: Tree IO
-> FilePath
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)
addp' :: Tree IO
-> String -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
addp' cur :: Tree IO
cur f :: String
f = do
Bool
already_has <- (if Bool
gotAllowCaseOnly 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) Tree IO
cur String
f
Maybe FileStatus
mstatus <- String -> IO (Maybe FileStatus)
getFileStatus String
f
case (Bool
already_has, Bool
is_badfilename, Maybe FileStatus
mstatus) of
(True, _, _) -> (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing, String -> Maybe String
forall a. a -> Maybe a
Just String
f)
(_, True, _) -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is invalid under Windows.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Use --reserved-ok to allow it."
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall a a. (Tree IO, Maybe a, Maybe a)
add_failure
(_, _, Just s :: FileStatus
s)
| FileStatus -> Bool
isDirectory FileStatus
s -> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
trypatch (FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String))
-> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
adddir String
f prim wX wY -> FL prim wY wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
| FileStatus -> Bool
isRegularFile FileStatus
s -> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
trypatch (FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String))
-> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> prim wX wY
addfile String
f prim wX wY -> FL prim wY wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
| FileStatus -> Bool
isSymbolicLink FileStatus
s -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Sorry, file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++
" is a symbolic link, which is unsupported by darcs."
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall a a. (Tree IO, Maybe a, Maybe a)
add_failure
_ -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "File "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++" does not exist!"
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall a a. (Tree IO, Maybe a, Maybe a)
add_failure
where
is_badfilename :: Bool
is_badfilename = Bool -> Bool
not (Bool
gotAllowWindowsReserved Bool -> Bool -> Bool
|| String -> Bool
WindowsFilePath.isValid String
f)
add_failure :: (Tree IO, Maybe a, Maybe a)
add_failure = (Tree IO
cur, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
trypatch :: FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)
trypatch :: FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
trypatch p :: FreeLeft (FL prim)
p = do
Permissions
perms <- String -> IO Permissions
getPermissions String
f
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Permissions -> Bool
readable Permissions
perms
then do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "': permission denied "
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
else FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe String)
forall (p :: * -> * -> *) a.
(Apply p, ApplyState p ~ Tree) =>
FreeLeft p -> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
trypatch' FreeLeft (FL prim)
p
trypatch' :: FreeLeft p -> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
trypatch' p :: FreeLeft p
p = do
Sealed p' :: p Any wX
p' <- Sealed (p Any) -> IO (Sealed (p Any))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (p Any) -> IO (Sealed (p Any)))
-> Sealed (p Any) -> IO (Sealed (p Any))
forall a b. (a -> b) -> a -> b
$ FreeLeft p -> Sealed (p Any)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft p
p
Bool
ok <- Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
cur String
parentdir
if Bool
ok
then do
Tree IO
tree <- p Any wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree p Any wX
p' Tree IO
cur
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgAdding AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
(Tree IO, Maybe (FreeLeft p), Maybe a)
-> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
tree, FreeLeft p -> Maybe (FreeLeft p)
forall a. a -> Maybe a
Just FreeLeft p
p, Maybe a
forall a. Maybe a
Nothing)
else do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++
"' ... couldn't add parent directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
parentdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' to repository"
(Tree IO, Maybe (FreeLeft p), Maybe a)
-> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft p)
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
IO (Tree IO, Maybe (FreeLeft p), Maybe a)
-> (IOException -> IO (Tree IO, Maybe (FreeLeft p), Maybe a))
-> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> (String -> Doc) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' ... " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
(Tree IO, Maybe (FreeLeft p), Maybe a)
-> IO (Tree IO, Maybe (FreeLeft p), Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft p)
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
parentdir :: String
parentdir = String -> String
takeDirectory String
f
gotAllowCaseOnly :: Bool
gotAllowCaseOnly = PrimDarcsOption Bool
allowCaseDifferingFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
gotAllowWindowsReserved :: Bool
gotAllowWindowsReserved = PrimDarcsOption Bool
allowWindowsReservedFilenames PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
data AddMessages = AddMessages
{
AddMessages -> String
msgSkipping :: String
, AddMessages -> String
msgAdding :: String
, AddMessages -> String
msgIs :: String
, AddMessages -> String
msgAre :: String
}
normalMessages :: AddMessages
normalMessages :: AddMessages
normalMessages = AddMessages :: String -> String -> String -> String -> AddMessages
AddMessages
{
msgSkipping :: String
msgSkipping = "Skipping"
, msgAdding :: String
msgAdding = "Adding"
, msgIs :: String
msgIs = "is"
, msgAre :: String
msgAre = "are"
}
dryRunMessages :: AddMessages
dryRunMessages :: AddMessages
dryRunMessages = AddMessages :: String -> String -> String -> String -> AddMessages
AddMessages
{
msgSkipping :: String
msgSkipping = "Would skip"
, msgAdding :: String
msgAdding = "Would add"
, msgIs :: String
msgIs = "would be"
, msgAre :: String
msgAre = "would be"
}
getParents :: Tree IO
-> [FilePath]
-> [FilePath]
getParents :: Tree IO -> [String] -> [String]
getParents cur :: Tree IO
cur = (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath "") ([AnchoredPath] -> [String])
-> ([String] -> [AnchoredPath]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *).
Foldable t =>
t AnchoredPath -> [AnchoredPath]
go ([AnchoredPath] -> [AnchoredPath])
-> ([String] -> [AnchoredPath]) -> [String] -> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> AnchoredPath) -> [String] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> AnchoredPath
floatPath
where
go :: t AnchoredPath -> [AnchoredPath]
go fs :: t AnchoredPath
fs = (AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Tree IO) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Tree IO) -> Bool)
-> (AnchoredPath -> Maybe (Tree IO)) -> AnchoredPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> AnchoredPath -> Maybe (Tree IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
cur) ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> [AnchoredPath])
-> t AnchoredPath -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredPath -> [AnchoredPath]
parents t AnchoredPath
fs