--  Copyright (C) 2002-2003 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.

{-# LANGUAGE OverloadedStrings #-}

module Darcs.UI.Commands.Record
    ( record
    , commit
    , recordConfig, RecordConfig(..) -- needed for darcsden
    ) where

import Prelude ()
import Darcs.Prelude
import Data.Foldable ( traverse_ )

import Control.Exception ( handleJust )
import Control.Monad ( when, unless, void )
import Data.List ( sort )
import Data.Char ( ord )
import System.Exit ( exitFailure, exitSuccess, ExitCode(..) )
import System.Directory ( removeFile )

import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Repository
    ( Repository
    , withRepoLock
    , RepoJob(..)
    , tentativelyAddPatch
    , finalizeRepositoryChanges
    , invalidateIndex
    , unrecordedChanges
    , readRecorded
    )
import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, fromPrims )
import Darcs.Patch.Named.Wrapped ( namepatch, adddeps )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:>)(..), nullFL )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Split ( primSplitter )
import Darcs.UI.SelectChanges
    (  WhichChanges(..)
    , selectionContextPrim
    , runSelection
    , askAboutDepends
    )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )
import Darcs.Util.Path ( SubPath, toFilePath, AbsolutePath )
import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts
    , nodefaults
    , commandAlias
    , setEnvDarcsFiles
    , setEnvDarcsPatches
    , amInHashedRepository
    )
import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths,
                                testTentativeAndMaybeExit )
import Darcs.UI.Completion ( modifiedFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , fileHelpAuthor
    , getAuthor
    , getDate
    , diffOpts
    , scanKnown
    , fixSubPaths
    )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags )
import Darcs.UI.PatchHeader ( getLog )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun), ScanKnown(..) )
import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Global ( darcsLastMessage )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Util.Printer ( putDocLn, text, (<+>) )
import Darcs.Util.Text ( pathlist )
import Darcs.Util.Tree( Tree )

recordDescription :: String
recordDescription = "Create a patch from unrecorded changes."

recordHelp :: String
recordHelp =
 "The `darcs record` command is used to create a patch from changes in\n" ++
 "the working tree.  If you specify a set of files and directories,\n" ++
 "changes to other files will be skipped.\n" ++
 "\n" ++ recordHelp' ++
 "\n" ++ recordHelp''

recordBasicOpts :: DarcsOption a
                   (Maybe String
                    -> Maybe String
                    -> O.TestChanges
                    -> Maybe Bool
                    -> Bool
                    -> Bool
                    -> Maybe O.AskLongComment
                    -> O.LookFor
                    -> Maybe String
                    -> O.WithContext
                    -> O.DiffAlgorithm
                    -> a)
recordBasicOpts
    = O.patchname
    ^ O.author
    ^ O.testChanges
    ^ O.interactive
    ^ O.pipe
    ^ O.askDeps
    ^ O.askLongComment
    ^ O.lookfor
    ^ O.repoDir
    ^ O.withContext
    ^ O.diffAlgorithm

recordAdvancedOpts :: DarcsOption a
                      (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.IncludeBoring -> a)
recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable ^ O.includeBoring

data RecordConfig = RecordConfig
    { patchname :: Maybe String
    , author :: Maybe String
    , testChanges :: O.TestChanges
    , interactive :: Maybe Bool
    , pipe :: Bool
    , askDeps :: Bool
    , askLongComment :: Maybe O.AskLongComment
    , lookfor :: O.LookFor
    , _workingRepoDir :: Maybe String
    , withContext :: O.WithContext
    , diffAlgorithm :: O.DiffAlgorithm
    , verbosity :: O.Verbosity
    , logfile :: O.Logfile
    , compress :: O.Compression
    , useIndex :: O.UseIndex
    , umask :: O.UMask
    , sse :: O.SetScriptsExecutable
    , includeBoring :: O.IncludeBoring
    , useCache :: O.UseCache
    }

recordConfig :: [DarcsFlag] -> RecordConfig
recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig

record :: DarcsCommand RecordConfig
record = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "record"
    , commandHelp = recordHelp
    , commandDescription = recordDescription
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
    , commandCommand = recordCmd
    , commandPrereq = amInHashedRepository
    , commandCompleteArgs = modifiedFileArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc recordAdvancedOpts
    , commandBasicOptions = odesc recordBasicOpts
    , commandDefaults = defaultFlags recordOpts
    , commandCheckOptions = ocheck recordOpts
    , commandParseOptions = recordConfig
    }
  where
    recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts

-- | commit is an alias for record
commit :: DarcsCommand RecordConfig
commit = commandAlias "commit" Nothing record

reportNonExisting :: ScanKnown -> ([SubPath], [SubPath]) -> IO ()
reportNonExisting scan (paths_only_in_working, _) = do
  unless (scan /= ScanKnown || null paths_only_in_working) $  putDocLn $
    "These paths are not yet in the repository and will be added:" <+>
    pathlist (map toFilePath paths_only_in_working)

recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO ()
recordCmd fps cfg args = do
    checkNameIsNotOption (patchname cfg) (isInteractive cfg)
    withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do
      let scan = scanKnown (O.adds (lookfor cfg)) (includeBoring cfg)
      existing_files <- do
        files <- if null args then return Nothing
                 else Just . sort <$> fixSubPaths fps args
        when (files == Just []) $ fail "No valid arguments were given."
        files' <-
          traverse
            (filterExistingPaths
              repository (verbosity cfg) (useIndex cfg) scan (O.moves (lookfor cfg)))
            files
        when (verbosity cfg /= O.Quiet) $
            traverse_ (reportNonExisting scan) files'
        let files'' = fmap snd files'
        when (files'' == Just []) $
            fail "None of the files you specified exist."
        return files''
      announceFiles (verbosity cfg) existing_files "Recording changes in"
      debugMessage "About to get the unrecorded changes."
      changes <- unrecordedChanges (diffingOpts cfg)
                   (O.moves (lookfor cfg)) (O.replaces (lookfor cfg))
                   repository existing_files
      debugMessage "I've got unrecorded changes."
      case changes of
          NilFL | not (askDeps cfg) -> do
              -- We need to grab any input waiting for us, since we
              -- might break scripts expecting to send it to us; we
              -- don't care what that input is, though.
              void (getDate (pipe cfg))
              putStrLn "No changes!"
              exitFailure
          _ -> doRecord repository cfg existing_files changes

-- | Check user specified patch name is not accidentally a command line flag
checkNameIsNotOption :: Maybe String -> Bool -> IO ()
checkNameIsNotOption Nothing     _      = return ()
checkNameIsNotOption _           False  = return ()
checkNameIsNotOption (Just name) True   =
    when (length name == 1 || (length name == 2 && head name == '-')) $ do
        confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"
        unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure

doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
         => Repository rt p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO ()
doRecord repository cfg files ps = do
    date <- getDate (pipe cfg)
    my_author <- getAuthor (author cfg) (pipe cfg)
    debugMessage "I'm slurping the repository."
    pristine <- readRecorded repository
    debugMessage "About to select changes..."
    (chs :> _ ) <- runSelection ps $
                  selectionContextPrim First "record" (patchSelOpts cfg)
                                       (Just (primSplitter (diffAlgorithm cfg)))
                                       (map toFilePath <$> files)
                                       (Just pristine)
    when (not (askDeps cfg) && nullFL chs) $
              do putStrLn "Ok, if you don't want to record anything, that's fine!"
                 exitSuccess
    handleJust onlySuccessfulExits (\_ -> return ()) $
             do deps <- if askDeps cfg
                        then askAboutDepends repository chs (patchSelOpts cfg) []
                        else return []
                when (askDeps cfg) $ debugMessage "I've asked about dependencies."
                if nullFL chs && null deps
                  then putStrLn "Ok, if you don't want to record anything, that's fine!"
                  else do setEnvDarcsFiles chs
                          (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs
                          debugMessage ("Patch name as received from getLog: " ++ show (map ord name))
                          doActualRecord repository cfg name date my_author my_log logf deps chs

doActualRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
               => Repository rt p wR wU wR
               -> RecordConfig
               -> String -> String -> String
               -> [String] -> Maybe String
               -> [PatchInfo] -> FL (PrimOf p) wR wX -> IO ()
doActualRecord repository cfg name date my_author my_log logf deps chs =
              do debugMessage "Writing the patch file..."
                 mypatch <- namepatch date name my_author my_log $
                            fromPrims $ progressFL "Writing changes:" chs
                 let pia = n2pia $ adddeps mypatch deps
                 -- We don't care about the returned updated repository
                 _ <- tentativelyAddPatch repository (compress cfg) (verbosity cfg) YesUpdateWorking
                           $ pia
                 invalidateIndex repository
                 debugMessage "Applying to pristine..."
                 testTentativeAndMaybeExit repository
                      (verbosity cfg)
                      (testChanges cfg)
                      (sse cfg)
                      (isInteractive cfg)
                      ("you have a bad patch: '" ++ name ++ "'")
                      "record it" (Just failuremessage)
                 finalizeRepositoryChanges repository YesUpdateWorking (compress cfg)
                                    `clarifyErrors` failuremessage
                 debugMessage "Syncing timestamps..."
                 removeLogFile logf
                 unless (verbosity cfg == O.Quiet) $
                     putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"
                 setEnvDarcsPatches (pia :>: NilFL)
    where
        removeLogFile :: Maybe String -> IO ()
        removeLogFile Nothing = return ()
        removeLogFile (Just lf) | lf == darcsLastMessage = return ()
                                | otherwise              = removeFile lf
        failuremessage = "Failed to record patch '"++name++"'" ++
                           case logf of Just lf -> "\nLogfile left in "++lf++"."
                                        Nothing -> ""

recordHelp' :: String
recordHelp' = unlines
 [ "Every patch has a name, an optional description, an author and a date."
 , ""
 , "Darcs will launch a text editor (see `darcs help environment`) after the"
 , "interactive selection, to let you enter the patch name (first line) and"
 , "the patch description (subsequent lines)."
 , ""
 , "You can supply the patch name in advance with the `-m` option, in which"
 , "case no text editor is launched, unless you use `--edit-long-comment`."
 , ""
 , "The patch description is an optional block of free-form text.  It is"
 , "used to supply additional information that doesn't fit in the patch"
 , "name.  For example, it might include a rationale of WHY the change was"
 , "necessary."
 , ""
 , "A technical difference between patch name and patch description, is"
 , "that matching with the flag `-p` is only done on patch names."
 , ""
 , "Finally, the `--logfile` option allows you to supply a file that already"
 , "contains the patch name and description.  This is useful if a previous"
 , "record failed and left a `_darcs/patch_description.txt` file."
 , ""
 , unlines fileHelpAuthor
 , "If you want to manually define any explicit dependencies for your patch,"
 , "you can use the `--ask-deps` flag. Some dependencies may be automatically"
 , "inferred from the patch's content and cannot be removed. A patch with"
 , "specific dependencies can be empty."
 , ""
 , "The patch date is generated automatically.  It can only be spoofed by"
 , "using the `--pipe` option."
 , ""
 , "If you run record with the `--pipe` option, you will be prompted for"
 , "the patch date, author, and the long comment. The long comment will extend"
 , "until the end of file or stdin is reached. This interface is intended for"
 , "scripting darcs, in particular for writing repository conversion scripts."
 , "The prompts are intended mostly as a useful guide (since scripts won't"
 , "need them), to help you understand the input format. Here's an example of"
 , "what the `--pipe` prompts look like:"
 , ""
 , "    What is the date? Mon Nov 15 13:38:01 EST 2004"
 , "    Who is the author? David Roundy"
 , "    What is the log? One or more comment lines"
 ]

onlySuccessfulExits :: ExitCode -> Maybe ()
onlySuccessfulExits ExitSuccess = Just ()
onlySuccessfulExits _ = Nothing

recordHelp'' :: String
recordHelp'' =
 "If a test command has been defined with `darcs setpref`, attempting to\n" ++
 "record a patch will cause the test command to be run in a clean copy\n" ++
 "of the working tree (that is, including only recorded changes).  If\n" ++
 "the test fails, you will be offered to abort the record operation.\n" ++
 "\n" ++
 "The `--set-scripts-executable` option causes scripts to be made\n" ++
 "executable in the clean copy of the working tree, prior to running the\n" ++
 "test.  See `darcs clone` for an explanation of the script heuristic.\n" ++
 "\n" ++
 "If your test command is tediously slow (e.g. `make all`) and you are\n" ++
 "recording several patches in a row, you may wish to use `--no-test` to\n" ++
 "skip all but the final test.\n" ++
 "\n" ++
 "To see some context (unchanged lines) around each change, use the\n" ++
 "`--unified` option.\n"

patchSelOpts :: RecordConfig -> S.PatchSelectionOptions
patchSelOpts cfg = S.PatchSelectionOptions
    { S.verbosity = verbosity cfg
    , S.matchFlags = []
    , S.interactive = isInteractive cfg
    , S.selectDeps = O.PromptDeps -- option not supported, use default
    , S.summary = O.NoSummary -- option not supported, use default
    , S.withContext = withContext cfg
    }

diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)
diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg)

isInteractive :: RecordConfig -> Bool
isInteractive = maybe True id . interactive
