%  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.

\darcsCommand{add}
\begin{code}
module Darcs.Commands.Add ( add ) where

import Data.List ( (\\), nub)

import Darcs.Commands
import Darcs.Arguments (noskip_boring, allow_problematic_filenames,
                       fancy_move_add,
                       recursive, working_repo_dir, dry_run_noxml, umask_option,
                       list_files, list_unregistered_files,
                        DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive,
                                   Verbose, Quiet, FancyMoveAdd, DryRun),
                        fixSubPaths,
                      )
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.Ordered ( FL(..), unsafeFL, concatFL, nullFL )
import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,
                        isFileReallySymlink, doesDirectoryReallyExist, 
                        doesFileReallyExist, slurp_hasdir,
                      )
import Darcs.Patch.FileName ( fp2fn )
import Darcs.RepoPath ( toFilePath )
import Control.Monad ( when, unless )
import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )
import Data.Maybe ( maybeToList )
import System.FilePath.Posix ( takeDirectory, (</>) )
import System.IO ( hPutStrLn, stderr )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.Gorsvet( invalidateIndex )

add_description :: String
add_description = "Add one or more new files or directories."

add_help :: String
add_help =
 "Generally a repository contains both files that should be version\n" ++
 "controlled (such as source code) and files that Darcs should ignore\n" ++
 "(such as executables compiled from the source code).  The `darcs add'\n" ++
 "command is used to tell Darcs which files to version control.\n" ++
 "\n" ++
 "When an existing project is first imported into a Darcs repository, it\n" ++
 "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++
 "initial source files into darcs.\n"++
 "\n" ++
 "Adding symbolic links (symlinks) is not supported.\n\n"

add :: DarcsCommand
add = DarcsCommand {command_name = "add",
                    command_help = add_help ++ add_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_problematic_filenames,
                     recursive "add contents of subdirectories",
                     fancy_move_add,
                     working_repo_dir, dry_run_noxml]}

add_help' :: String
add_help' =
 "Darcs will ignore all files and folders that look `boring'.  The\n" ++
 "--boring option overrides this behaviour.\n" ++
 "\n" ++
 "Darcs will not add file if another file in the same folder has the\n" ++
 "same name, except for case.  The --case-ok option overrides this\n" ++
 "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++
 "files a folder to have the same name except for case (for example,\n" ++
 "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" ++
 "unusable on those systems!\n\n"

add_cmd :: [DarcsFlag] -> [String] -> IO ()
add_cmd opts args = withRepoLock opts $- \repository ->
 do cur <- slurp_pending repository
    origfiles <- map toFilePath `fmap` fixSubPaths opts args
    when (null origfiles) $
       putStrLn "Nothing specified, nothing added." >>
       putStrLn "Maybe you wanted to say `darcs add --recursive .'?"
    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
    mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $
      flist \\ nboring flist
    date <- getIsoDateTime
    invalidateIndex repository
    ps <- addp msgs opts date cur $ nboring flist
    when (nullFL ps && not (null args)) $
        fail "No files were added"
    unless 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:"
    unless (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 already_has
    then return (cur, Nothing, Just f)
    else
    if is_badfilename
       then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."
               return add_failure
       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 add_failure
      where already_has = if gotAllowCaseOnly
                          then slurp_has f cur
                          else slurp_has_anycase f cur
            is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)
            add_failure = (cur, Nothing, Nothing)
            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 = takeDirectory 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
  gotAllowWindowsReserved = AllowWindowsReserved `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"
    }

-- |FIXME: this documentation makes *no* sense to me, and the
-- ramifications of using this option are not clear. --twb, 2008
add_help'' :: String
add_help'' =
 "The --date-trick option allows you to enable an experimental trick to\n" ++
 "make add conflicts, in which two users each add a file or directory\n" ++
 "with the same name, less problematic.  While this trick is completely\n" ++
 "safe, it is not clear to what extent it is beneficial.\n"

expand_dirs :: [FilePath] -> IO [FilePath]
expand_dirs fs = concat `fmap` 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 `fmap` 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 = takeDirectory f
\end{code}