darcs-cabalized-2.0.2: src/Darcs/Commands/Add.lhs
% 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.
\subsection{darcs add}
\begin{code}
module Darcs.Commands.Add ( add ) where
import Data.List ( (\\), nub)
import Darcs.Commands
import Darcs.Arguments (noskip_boring, allow_caseonly,
fancy_move_add,
recursive, working_repo_dir, dry_run_noxml, umask_option,
list_files, list_unregistered_files,
DarcsFlag (AllowCaseOnly, Boring, Recursive,
Verbose, Quiet, FancyMoveAdd, DryRun),
getRepoPaths,
)
import Darcs.Utils ( withCurrentDirectory, nubsort )
import IsoDate ( getIsoDateTime )
import Darcs.Repository ( amInRepository, withRepoLock, ($-),
slurp_pending, add_to_pending )
import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move )
import Darcs.Patch.Ordered ( FL(..), unsafeFL, concatFL, nullFL )
import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,
isFileReallySymlink, doesDirectoryReallyExist,
doesFileReallyExist, slurp_hasdir,
)
import FileName ( fp2fn )
import Darcs.FilePathUtils ( (///) )
import Darcs.RepoPath ( toFilePath )
import Control.Monad ( liftM, when )
import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )
import Data.Maybe ( maybeToList )
import System.IO ( hPutStrLn, stderr )
\end{code}
\begin{code}
add_description :: String
add_description =
"Add one or more new files or directories."
\end{code}
\options{add}
\haskell{add_help}
\begin{code}
add_help :: String
add_help =
"Add needs to be called whenever you add a new file or directory to your\n"++
"project. Of course, it also needs to be called when you first create the\n"++
"project, to let darcs know which files should be kept track of.\n"
\end{code}
\begin{code}
add :: DarcsCommand
add = DarcsCommand {command_name = "add",
command_help = add_help,
command_description = add_description,
command_extra_args = -1,
command_extra_arg_help = ["<FILE or DIRECTORY> ..."],
command_command = add_cmd,
command_prereq = amInRepository,
command_get_arg_possibilities = list_unregistered_files,
command_argdefaults = nodefaults,
command_advanced_options = [umask_option],
command_basic_options =
[noskip_boring, allow_caseonly,
recursive "add contents of subdirectories",
fancy_move_add,
working_repo_dir, dry_run_noxml]}
\end{code}
Darcs will refuse to add a file or directory that differs from an existing
one only in case. This is because the HFS+ file system used on MacOS
treats such files as being one and the same.
You can not add symbolic links to darcs.
If you try to do that, darcs will refuse and print an error message.
Perhaps you want to make symbolic links \emph{to} the files in darcs instead?
\begin{options}
--boring
\end{options}
By default darcs will ignore all files that match any of the boring patterns.
If you want to add such a file anyway you must use the \verb!--boring! option.
\begin{code}
add_cmd :: [DarcsFlag] -> [String] -> IO ()
add_cmd opts args = withRepoLock opts $- \repository ->
do cur <- slurp_pending repository
origfiles <- map toFilePath `fmap` getRepoPaths opts args
parlist <- get_parents cur origfiles
flist' <- if Recursive `elem` opts
then expand_dirs origfiles
else return origfiles
let flist = nubsort (parlist ++ flist')
-- refuse to add boring files recursively:
nboring <- if Boring `elem` opts
then return $ darcsdir_filter
else boring_file_filter
let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn
sequence_ $ map (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $
flist \\ nboring flist
date <- getIsoDateTime
ps <- addp msgs opts date cur $ nboring flist
when (nullFL ps && not (null args)) $ do
fail "No files were added"
when (not gotDryRun) $ add_to_pending repository ps
where
gotDryRun = DryRun `elem` opts
msgs | gotDryRun = dryRunMessages
| otherwise = normalMessages
addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim)
addp msgs opts date cur0 files = do
(ps, dups) <-
foldr
(\f rest cur accPS accDups -> do
(cur', mp, mdup) <- addp' cur f
rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))
(\_ ps dups -> return (reverse ps, dups))
files
cur0 [] []
let uniq_dups = nub dups
caseMsg =
if gotAllowCaseOnly then ":"
else ";\nnote that to ensure portability we don't allow\n" ++
"files that differ only in case. Use --case-ok to override this:"
when (not (null dups)) $ do
dupMsg <-
case uniq_dups of
[f] ->
do
isDir <- doesDirectoryReallyExist f
if isDir
then return $
"The following directory "++msg_is msgs++" already in the repository"
else return $
"The following file "++msg_is msgs++" already in the repository"
fs ->
do
areDirs <- mapM doesDirectoryReallyExist fs
if and areDirs
then return $
"The following directories "++msg_are msgs++" already in the repository"
else
(if or areDirs
then return $
"The following files and directories " ++
msg_are msgs ++ " already in the repository"
else return $
"The following files " ++ msg_are msgs ++ " already in the repository")
putInfo $ dupMsg ++ caseMsg
mapM_ putInfo uniq_dups
return $ concatFL $ unsafeFL ps
where
addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)
addp' cur f =
if (if gotAllowCaseOnly
then slurp_has f cur
else slurp_has_anycase f cur)
then do return (cur, Nothing, Just f)
else do
isdir <- doesDirectoryReallyExist f
if isdir
then trypatch $ myadddir f
else do isfile <- doesFileReallyExist f
if isfile
then trypatch $ myaddfile f
else do islink <- isFileReallySymlink f
if islink then
putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."
else putInfo $ "File "++ f ++" does not exist!"
return (cur, Nothing, Nothing)
where trypatch p =
case apply_to_slurpy p cur of
Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error
return (cur, Nothing, Nothing)
Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'"
return (s', Just p, Nothing)
parentdir = get_parentdir f
have_parentdir = slurp_hasdir (fp2fn parentdir) cur
parent_error = if have_parentdir
then ""
else "couldn't add parent directory '"++parentdir++
"' to repository."
myadddir d = if gotFancyMoveAdd
then adddir (d++"-"++date) :>:
move (d++"-"++date) d :>: NilFL
else adddir d :>: NilFL
myaddfile d = if gotFancyMoveAdd
then addfile (d++"-"++date) :>:
move (d++"-"++date) d :>: NilFL
else addfile d :>: NilFL
putVerbose = if Verbose `elem` opts || DryRun `elem` opts
then putStrLn
else \_ -> return ()
putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr
gotFancyMoveAdd = FancyMoveAdd `elem` opts
gotAllowCaseOnly = AllowCaseOnly `elem` opts
data AddMessages =
AddMessages
{ msg_skipping :: String
, msg_adding :: String
, msg_is :: String
, msg_are :: String
}
normalMessages, dryRunMessages :: AddMessages
normalMessages =
AddMessages
{ msg_skipping = "Skipping"
, msg_adding = "Adding"
, msg_is = "is"
, msg_are = "are"
}
dryRunMessages =
AddMessages
{ msg_skipping = "Would skip"
, msg_adding = "Would add"
, msg_is = "would be"
, msg_are = "would be"
}
\end{code}
\begin{options}
--date-trick
\end{options}
The \verb!--date-trick! option allows you to enable an experimental trick
to make add conflicts, in which two users each add a file or directory with
the same name, less problematic. While this trick is completely safe, it
is not clear to what extent it is beneficial.
\begin{code}
expand_dirs :: [FilePath] -> IO [FilePath]
expand_dirs fs = concat `liftM` mapM expand_one fs
expand_one :: FilePath -> IO [FilePath]
expand_one "" = list_files
expand_one f = do
isdir <- doesDirectoryReallyExist f
if not isdir then return [f]
else do fs <- withCurrentDirectory f list_files
return $ f: map ((///) f) fs
get_parents :: Slurpy -> [FilePath] -> IO [FilePath]
get_parents cur fs =
concat `liftM` mapM (get_parent cur) fs
get_parent :: Slurpy -> FilePath -> IO [FilePath]
get_parent cur f =
if slurp_hasdir (fp2fn parentdir) cur
then return []
else do grandparents <- get_parent cur parentdir
return (grandparents ++ [parentdir])
where parentdir = get_parentdir f
get_parentdir :: FilePath -> FilePath
get_parentdir f = reverse $ drop 1 $ dropWhile (/='/') $ reverse f
\end{code}