--  Copyright (C) 2002-2004 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.Add
-- Copyright   : 2002-2004 David Roundy
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable

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 (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
    String
"Generally the working tree contains both files that should be version\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"controlled (such as source code) and files that Darcs should ignore\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"(such as executables compiled from the source code).  The `darcs add`\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"command is used to tell Darcs which files to version control.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"When an existing project is first imported into a Darcs repository, it\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"is common to run `darcs add -r *` or `darcs record -l` to add all\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"initial source files into darcs.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"Adding symbolic links (symlinks) is not supported.\n\n"


addHelp' :: Doc
addHelp' :: Doc
addHelp' = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
    String
"Darcs will ignore all files and folders that look \"boring\".  The\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"`--boring` option overrides this behaviour.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"Darcs will not add file if another file in the same folder has the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"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\n"

add :: DarcsCommand
add :: DarcsCommand
add = 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
"add"
    , commandHelp :: Doc
commandHelp                 = Doc
addHelp Doc -> Doc -> Doc
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      = 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
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         = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (IncludeBoring
   -> Bool
   -> Bool
   -> Bool
   -> Maybe String
   -> DryRun
   -> 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
  (IncludeBoring
   -> Bool
   -> Bool
   -> Bool
   -> Maybe String
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
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
      = 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
addOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (IncludeBoring
   -> Bool
   -> Bool
   -> Bool
   -> Maybe String
   -> DryRun
   -> 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
     (IncludeBoring
      -> Bool
      -> Bool
      -> Bool
      -> Maybe String
      -> DryRun
      -> 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
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (IncludeBoring
   -> Bool
   -> Bool
   -> Bool
   -> Maybe String
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (IncludeBoring
   -> Bool -> Bool -> Bool -> Maybe String -> DryRun -> a)
addBasicOpts DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
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
  | [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
$ String
"Nothing specified, nothing added." String -> String -> String
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
        [] -> String -> IO ()
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 =
  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
repository -> do
    -- TODO do not expand here, and use findM/findIO or such later
    -- (needs adding to hashed-storage first though)
    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.
(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
    -- (1) note, readWorking already filters out darcsdir paths
    -- (2) note, filterPaths matches if path is parent /or/ child 
    Tree IO
working <- TreeFilter IO -> IO (Tree IO)
readWorking ((forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO)
-> TreeFilter IO
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter ((AnchoredPath -> TreeItem IO -> Bool) -> tr IO -> tr IO
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter ([AnchoredPath] -> AnchoredPath -> TreeItem IO -> Bool
forall t. [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
paths)))
    -- we first get the boring paths, too, so we can report dropping them
    let all_paths :: [AnchoredPath]
all_paths = [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ [AnchoredPath]
parent_paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a] -> [a]
++
                      (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 Tree IO -> [AnchoredPath] -> [AnchoredPath]
explodePaths Tree IO
working
                        else [AnchoredPath] -> [AnchoredPath]
forall a. a -> a
id) [AnchoredPath]
paths
        all_orig_paths :: [String]
all_orig_paths = (AnchoredPath -> String) -> [AnchoredPath] -> [String]
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 [a] -> [a]
forall a. a -> a
id else (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
boring (String -> Bool) -> (a -> String) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
s)
    (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]
++ String
" boring file ")String -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String]
all_orig_paths [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ (String -> String) -> [String] -> [String]
forall a. (a -> String) -> [a] -> [a]
nboring String -> String
forall a. a -> a
id [String]
all_orig_paths
    Sealed 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
-> [AnchoredPath]
-> IO (FreeLeft (FL (PrimOf p)))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AddMessages
-> [DarcsFlag]
-> Tree IO
-> [AnchoredPath]
-> IO (FreeLeft (FL prim))
addp AddMessages
msgs [DarcsFlag]
opts Tree IO
cur ([AnchoredPath] -> IO (FreeLeft (FL (PrimOf p))))
-> [AnchoredPath] -> IO (FreeLeft (FL (PrimOf p)))
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> String) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> String) -> [a] -> [a]
nboring AnchoredPath -> String
realPath [AnchoredPath]
all_paths
    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 ([AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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
-> UseIndex -> FL (PrimOf p) wU wX -> IO ()
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 PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
ps
         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
         [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([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 adding:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath (FL (PrimOf p) wU wX -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimOf p) wU wX
ps)
  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
     -> [AnchoredPath]
     -> IO (FreeLeft (FL prim))
addp :: 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) <-
        (AnchoredPath
 -> (Tree IO
     -> [FreeLeft (FL prim)]
     -> [AnchoredPath]
     -> IO ([FreeLeft (FL prim)], [AnchoredPath]))
 -> Tree IO
 -> [FreeLeft (FL prim)]
 -> [AnchoredPath]
 -> IO ([FreeLeft (FL prim)], [AnchoredPath]))
-> (Tree IO
    -> [FreeLeft (FL prim)]
    -> [AnchoredPath]
    -> IO ([FreeLeft (FL prim)], [AnchoredPath]))
-> [AnchoredPath]
-> Tree IO
-> [FreeLeft (FL prim)]
-> [AnchoredPath]
-> IO ([FreeLeft (FL prim)], [AnchoredPath])
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
                        -- If a single file fails to add, stop further processing.
                        (Tree IO
_, Maybe (FreeLeft (FL prim))
Nothing, Maybe AnchoredPath
Nothing) -> ([FreeLeft (FL prim)], [AnchoredPath])
-> IO ([FreeLeft (FL prim)], [AnchoredPath])
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' (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 AnchoredPath -> [AnchoredPath]
forall a. Maybe a -> [a]
maybeToList Maybe AnchoredPath
mdup [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a] -> [a]
++ [AnchoredPath]
accDups))
            (\Tree IO
_ [FreeLeft (FL prim)]
ps [AnchoredPath]
dups -> ([FreeLeft (FL prim)], [AnchoredPath])
-> IO ([FreeLeft (FL prim)], [AnchoredPath])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FreeLeft (FL prim)] -> [FreeLeft (FL prim)]
forall a. [a] -> [a]
reverse [FreeLeft (FL prim)]
ps, [AnchoredPath]
dups))
            [AnchoredPath]
files
            Tree IO
cur0 [] []
    let uniq_dups :: [AnchoredPath]
uniq_dups = [AnchoredPath] -> [AnchoredPath]
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
"files that differ only in case. Use --case-ok to override this:"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
dups) (IO () -> IO ()) -> IO () -> IO ()
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 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
$
               String
"The following directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               AddMessages -> String
msgIs AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$
               String
"The following file " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               AddMessages -> String
msgIs AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already in the repository"
         [AnchoredPath]
fs   -> do
           [Bool]
areDirs <- (AnchoredPath -> IO Bool) -> [AnchoredPath] -> 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 -> IO Bool)
-> (AnchoredPath -> String) -> AnchoredPath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
realPath) [AnchoredPath]
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
$
               String
"The following directories " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               AddMessages -> String
msgAre AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$
                    String
"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]
++ String
" 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
$
                    String
"The following files " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    AddMessages -> String
msgAre AddMessages
msgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$ String
"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
       (AnchoredPath -> IO ()) -> [AnchoredPath] -> 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 ()) -> (AnchoredPath -> Doc) -> AnchoredPath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (AnchoredPath -> String) -> AnchoredPath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
displayPath) [AnchoredPath]
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
          -> 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 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) 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
_) -> (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing, AnchoredPath -> Maybe AnchoredPath
forall a. a -> Maybe a
Just AnchoredPath
f)
        (Bool
_, Bool
True, Maybe FileStatus
_) -> 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
$
              String
"The filename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is invalid on Windows.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"Use --reserved-ok to allow it."
            (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
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 (FreeLeft (FL prim)
 -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath))
-> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
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 (AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
adddir AnchoredPath
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 AnchoredPath)
trypatch (FreeLeft (FL prim)
 -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath))
-> FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
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 (AnchoredPath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> prim wX wY
addfile AnchoredPath
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
$
                    String
"Sorry, file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
" is a symbolic link, which is unsupported by darcs."
                (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall a a. (Tree IO, Maybe a, Maybe a)
add_failure
        (Bool, Bool, Maybe FileStatus)
_ -> 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
$ String
"File "String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" does not exist!"
            (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
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, 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 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 (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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': permission denied "
                    (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
cur, Maybe (FreeLeft (FL prim))
forall a. Maybe a
Nothing, Maybe AnchoredPath
forall a. Maybe a
Nothing)
                else FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)
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' FreeLeft p
p = do
              Sealed 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 -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
cur AnchoredPath
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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
                    (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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
"' ... couldn't add parent directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            AnchoredPath -> String
displayPath AnchoredPath
parentdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' 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 -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' ... " 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 :: AnchoredPath
parentdir = AnchoredPath -> Maybe AnchoredPath -> AnchoredPath
forall a. a -> Maybe a -> a
fromMaybe (String -> AnchoredPath
forall a. HasCallStack => String -> a
error String
"cannot take parent of root path") (Maybe AnchoredPath -> AnchoredPath)
-> Maybe AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
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  = String
"Skipping"
    , msgAdding :: String
msgAdding    = String
"Adding"
    , msgIs :: String
msgIs        = String
"is"
    , msgAre :: String
msgAre       = String
"are"
    }


dryRunMessages :: AddMessages
dryRunMessages :: AddMessages
dryRunMessages = AddMessages :: String -> String -> String -> String -> AddMessages
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 = (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])
-> [AnchoredPath]
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredPath -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredPath -> [AnchoredPath]
parents