module Darcs.UI.Commands.Add ( add ) where
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 ( fromMaybe, isNothing, maybeToList )
import Darcs.Util.Printer ( Doc, text, vcat )
import Darcs.Util.Tree ( Tree, findTree, expand, explodePaths )
import qualified Darcs.Util.Tree as Tree
import Darcs.Util.Path
( AbsolutePath
, AnchoredPath
, displayPath
, filterPaths
, parent
, parents
, realPath
)
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 ( doesDirectoryReallyExist )
import Darcs.UI.Completion ( unknownFileArgs )
import Darcs.UI.Flags
( DarcsFlag
, includeBoring, allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask
, pathsFromArgs )
import Darcs.UI.Options
( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdatePending(..) )
import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Repository.State
( TreeFilter(..)
, readRecordedAndPending
, readWorking
, updateIndex
)
import Darcs.Repository
( withRepoLock
, RepoJob(..)
, addToPending
)
import Darcs.Repository.Prefs ( isBoring )
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 = String
"Add new files to version control."
addHelp :: Doc
addHelp :: Doc
addHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Generally the working tree contains both files that should be version\n" forall a. [a] -> [a] -> [a]
++
String
"controlled (such as source code) and files that Darcs should ignore\n" forall a. [a] -> [a] -> [a]
++
String
"(such as executables compiled from the source code). The `darcs add`\n" forall a. [a] -> [a] -> [a]
++
String
"command is used to tell Darcs which files to version control.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"When an existing project is first imported into a Darcs repository, it\n" forall a. [a] -> [a] -> [a]
++
String
"is common to run `darcs add -r *` or `darcs record -l` to add all\n" forall a. [a] -> [a] -> [a]
++
String
"initial source files into darcs.\n"forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Adding symbolic links (symlinks) is not supported.\n\n"
addHelp' :: Doc
addHelp' :: Doc
addHelp' = String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Darcs will ignore all files and folders that look \"boring\". The\n" forall a. [a] -> [a] -> [a]
++
String
"`--boring` option overrides this behaviour.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Darcs will not add file if another file in the same folder has the\n" forall a. [a] -> [a] -> [a]
++
String
"same name, except for case. The `--case-ok` option overrides this\n" forall a. [a] -> [a] -> [a]
++
String
"behaviour. Windows and OS X usually use filesystems that do not allow\n" forall a. [a] -> [a] -> [a]
++
String
"files a folder to have the same name except for case (for example,\n" forall a. [a] -> [a] -> [a]
++
String
"`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" forall a. [a] -> [a] -> [a]
++
String
"unusable on those systems!\n\n"
add :: DarcsCommand
add :: DarcsCommand
add = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"add"
, commandHelp :: Doc
commandHelp = Doc
addHelp forall a. Semigroup a => a -> a -> a
<> Doc
addHelp'
, commandDescription :: String
commandDescription = String
addDescription
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [ String
"<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 = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
addAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
addOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
addOpts
}
where
addBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts
= PrimDarcsOption IncludeBoring
O.includeBoring
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall a. DarcsOption a (Bool -> Bool -> a)
O.allowProblematicFilenames
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.recursive
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption DryRun
O.dryRun
addAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
addAdvancedOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
addOpts :: DarcsOption
a
(IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> DryRun
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
addOpts = forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
withStdOpts forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(IncludeBoring
-> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
addAdvancedOpts
addCmd :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO ()
addCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
addCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args = String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Nothing specified, nothing added." forall a. [a] -> [a] -> [a]
++
String
"Maybe you wanted to say `darcs add --recursive .'?"
| Bool
otherwise = do
[AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
case [AnchoredPath]
paths of
[] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No valid repository paths were given"
[AnchoredPath]
_ -> [DarcsFlag] -> [AnchoredPath] -> IO ()
addFiles [DarcsFlag]
opts [AnchoredPath]
paths
addFiles :: [DarcsFlag] -> [AnchoredPath] -> IO ()
addFiles :: [DarcsFlag] -> [AnchoredPath] -> IO ()
addFiles [DarcsFlag]
opts [AnchoredPath]
paths =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
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 (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
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 a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
Tree IO
cur <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
repository
let parent_paths :: [AnchoredPath]
parent_paths = Tree IO -> [AnchoredPath] -> [AnchoredPath]
notInTreeParents Tree IO
cur [AnchoredPath]
paths
Tree IO
working <- TreeFilter IO -> IO (Tree IO)
readWorking (forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter (forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter (forall t. [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
paths)))
let all_paths :: [AnchoredPath]
all_paths = forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ [AnchoredPath]
parent_paths forall a. [a] -> [a] -> [a]
++
(if forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.recursive [DarcsFlag]
opts
then Tree IO -> [AnchoredPath] -> [AnchoredPath]
explodePaths Tree IO
working
else forall a. a -> a
id) [AnchoredPath]
paths
all_orig_paths :: [String]
all_orig_paths = forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
all_paths
String -> Bool
boring <- IO (String -> Bool)
isBoring
let nboring :: (a -> String) -> [a] -> [a]
nboring a -> String
s = if [DarcsFlag] -> Bool
includeBoring [DarcsFlag]
opts then forall a. a -> a
id else forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
boring forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
s)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AddMessages -> String
msgSkipping AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" boring file ")forall a. [a] -> [a] -> [a]
++)) forall a b. (a -> b) -> a -> b
$
[String]
all_orig_paths forall a. Eq a => [a] -> [a] -> [a]
\\ forall {a}. (a -> String) -> [a] -> [a]
nboring forall a. a -> a
id [String]
all_orig_paths
Sealed FL (PrimOf p) wU wX
ps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AddMessages
-> [DarcsFlag]
-> Tree IO
-> [AnchoredPath]
-> IO (FreeLeft (FL prim))
addp AddMessages
msgs [DarcsFlag]
opts Tree IO
cur forall a b. (a -> b) -> a -> b
$ forall {a}. (a -> String) -> [a] -> [a]
nboring AnchoredPath -> String
realPath [AnchoredPath]
all_paths
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wU wX
ps Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No files were added"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gotDryRun forall a b. (a -> b) -> a -> b
$
do forall (p :: * -> * -> *) (rt :: RepoType) wR wU wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository (PrimDarcsOption UseIndex
O.useIndex forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
ps
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
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text forall a b. (a -> b) -> a -> b
$ [String
"Finished adding:"] forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath (forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimOf p) wU wX
ps)
where
gotDryRun :: Bool
gotDryRun = PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts 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
-> [AnchoredPath]
-> IO (FreeLeft (FL prim))
addp :: forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AddMessages
-> [DarcsFlag]
-> Tree IO
-> [AnchoredPath]
-> IO (FreeLeft (FL prim))
addp AddMessages
msgs [DarcsFlag]
opts Tree IO
cur0 [AnchoredPath]
files = do
([FreeLeft (FL prim)]
ps, [AnchoredPath]
dups) <-
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\AnchoredPath
f Tree IO
-> [FreeLeft (FL prim)]
-> [AnchoredPath]
-> IO ([FreeLeft (FL prim)], [AnchoredPath])
rest Tree IO
cur [FreeLeft (FL prim)]
accPS [AnchoredPath]
accDups -> do
(Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
addResult <- Tree IO
-> AnchoredPath
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
addp' Tree IO
cur AnchoredPath
f
case (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
addResult of
(Tree IO
_, Maybe (FreeLeft (FL prim))
Nothing, Maybe AnchoredPath
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
(Tree IO
cur', Maybe (FreeLeft (FL prim))
mp, Maybe AnchoredPath
mdup) -> Tree IO
-> [FreeLeft (FL prim)]
-> [AnchoredPath]
-> IO ([FreeLeft (FL prim)], [AnchoredPath])
rest Tree IO
cur' (forall a. Maybe a -> [a]
maybeToList Maybe (FreeLeft (FL prim))
mp forall a. [a] -> [a] -> [a]
++ [FreeLeft (FL prim)]
accPS) (forall a. Maybe a -> [a]
maybeToList Maybe AnchoredPath
mdup forall a. [a] -> [a] -> [a]
++ [AnchoredPath]
accDups))
(\Tree IO
_ [FreeLeft (FL prim)]
ps [AnchoredPath]
dups -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [FreeLeft (FL prim)]
ps, [AnchoredPath]
dups))
[AnchoredPath]
files
Tree IO
cur0 [] []
let uniq_dups :: [AnchoredPath]
uniq_dups = forall a. Eq a => [a] -> [a]
nub [AnchoredPath]
dups
caseMsg :: String
caseMsg =
if Bool
gotAllowCaseOnly then String
":"
else String
";\nnote that to ensure portability we don't allow\n" forall a. [a] -> [a] -> [a]
++
String
"files that differ only in case. Use --case-ok to override this:"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
dups) forall a b. (a -> b) -> a -> b
$ do
String
dupMsg <-
case [AnchoredPath]
uniq_dups of
[AnchoredPath
f] -> do
Bool
isDir <- String -> IO Bool
doesDirectoryReallyExist (AnchoredPath -> String
realPath AnchoredPath
f)
if Bool
isDir
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"The following directory " forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgIs AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" already in the repository"
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"The following file " forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgIs AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" already in the repository"
[AnchoredPath]
fs -> do
[Bool]
areDirs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO Bool
doesDirectoryReallyExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
realPath) [AnchoredPath]
fs
if forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
areDirs
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"The following directories " forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" already in the repository"
else
(if forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
areDirs
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"The following files and directories " forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" already in the repository"
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"The following files " forall a. [a] -> [a] -> [a]
++
AddMessages -> String
msgAre AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" already in the repository")
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
"WARNING: Some files were not added because they are already in the repository."
[DarcsFlag] -> Doc -> IO ()
putVerboseWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
dupMsg forall a. [a] -> [a] -> [a]
++ String
caseMsg
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([DarcsFlag] -> Doc -> IO ()
putVerboseWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
displayPath) [AnchoredPath]
uniq_dups
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (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 (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+)) (forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) [FreeLeft (FL prim)]
ps
where
addp' :: Tree IO
-> AnchoredPath
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
addp' :: Tree IO
-> AnchoredPath
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
addp' Tree IO
cur AnchoredPath
f = do
Bool
already_has <- (if Bool
gotAllowCaseOnly then forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHas else forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasAnycase) Tree IO
cur AnchoredPath
f
Maybe FileStatus
mstatus <- String -> IO (Maybe FileStatus)
getFileStatus (AnchoredPath -> String
realPath AnchoredPath
f)
case (Bool
already_has, Bool
is_badfilename, Maybe FileStatus
mstatus) of
(Bool
True, Bool
_, Maybe FileStatus
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just AnchoredPath
f)
(Bool
_, Bool
True, Maybe FileStatus
_) -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"The filename " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++ String
" is invalid on Windows.\n" forall a. [a] -> [a] -> [a]
++
String
"Use --reserved-ok to allow it."
forall (m :: * -> *) a. Monad m => a -> m a
return forall {a} {a}. (Tree IO, Maybe a, Maybe a)
add_failure
(Bool
_, Bool
_, Just FileStatus
s)
| FileStatus -> Bool
isDirectory FileStatus
s -> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
trypatch forall a b. (a -> b) -> a -> b
$ forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
adddir AnchoredPath
f forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
| FileStatus -> Bool
isRegularFile FileStatus
s -> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
trypatch forall a b. (a -> b) -> a -> b
$ forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap (forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
addfile AnchoredPath
f forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
| FileStatus -> Bool
isSymbolicLink FileStatus
s -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Sorry, file " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++
String
" is a symbolic link, which is unsupported by darcs."
forall (m :: * -> *) a. Monad m => a -> m a
return forall {a} {a}. (Tree IO, Maybe a, Maybe a)
add_failure
(Bool, Bool, Maybe FileStatus)
_ -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
"File "forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++String
" does not exist!"
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (AnchoredPath -> String
realPath AnchoredPath
f))
add_failure :: (Tree IO, Maybe a, Maybe a)
add_failure = (Tree IO
cur, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
trypatch :: FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
trypatch :: FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
trypatch FreeLeft (FL prim)
p = do
Permissions
perms <- String -> IO Permissions
getPermissions (AnchoredPath -> String
realPath AnchoredPath
f)
if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Permissions -> Bool
readable Permissions
perms
then do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" '" forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++ String
"': permission denied "
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
else forall {p :: * -> * -> *} {a}.
(ApplyState p ~ Tree, Apply p) =>
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' FreeLeft p
p = do
Sealed p Any wX
p' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft p
p
Bool
ok <- forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
parentdir
if Bool
ok
then do
Tree IO
tree <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgAdding AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" '" forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++ String
"'"
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
tree, forall a. a -> Maybe a
Just FreeLeft p
p, forall a. Maybe a
Nothing)
else do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" '" forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++
String
"' ... couldn't add parent directory '" forall a. [a] -> [a] -> [a]
++
AnchoredPath -> String
displayPath AnchoredPath
parentdir forall a. [a] -> [a] -> [a]
++ String
"' to repository"
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
[DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
AddMessages -> String
msgSkipping AddMessages
msgs forall a. [a] -> [a] -> [a]
++ String
" '" forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f forall a. [a] -> [a] -> [a]
++ String
"' ... " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
parentdir :: AnchoredPath
parentdir = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"cannot take parent of root path") forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
f
gotAllowCaseOnly :: Bool
gotAllowCaseOnly = PrimDarcsOption Bool
allowCaseDifferingFilenames forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
gotAllowWindowsReserved :: Bool
gotAllowWindowsReserved = PrimDarcsOption Bool
allowWindowsReservedFilenames 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
{
msgSkipping :: String
msgSkipping = String
"Skipping"
, msgAdding :: String
msgAdding = String
"Adding"
, msgIs :: String
msgIs = String
"is"
, msgAre :: String
msgAre = String
"are"
}
dryRunMessages :: AddMessages
dryRunMessages :: AddMessages
dryRunMessages = AddMessages
{
msgSkipping :: String
msgSkipping = String
"Would skip"
, msgAdding :: String
msgAdding = String
"Would add"
, msgIs :: String
msgIs = String
"would be"
, msgAre :: String
msgAre = String
"would be"
}
notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]
notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]
notInTreeParents Tree IO
cur = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
cur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredPath -> [AnchoredPath]
parents