--  Copyright (C) 2002-2004,2007 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 CPP #-}

module Darcs.Commands.Rollback ( rollback ) where

import Prelude hiding ( catch )

import Control.Applicative ( (<$>) )
import Control.Exception ( catch, IOException )
import Control.Monad ( when )
import System.Exit ( exitWith, ExitCode(..) )
import Data.List ( sort )
import Data.Maybe ( isJust )
import System.Directory ( removeFile )

import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor,
                         setEnvDarcsPatches,
                         workingRepoDir, nocompress,
                         author, patchnameOption, askLongComment,
                         leaveTestDir, notest, listRegisteredFiles,
                         matchSeveralOrLast, allInteractive, umaskOption,
                         recordRollback
                       )
import Darcs.RepoPath ( toFilePath )
import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),
                          applyToWorking,
                          readRepo,
                          tentativelyMergePatches, withGutsOf,
                          testTentative,
                          finalizeRepositoryChanges, invalidateIndex,
                          tentativelyAddToPending, considerMergeToWorking
                        )
import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims,
                     sortCoalesceFL, canonize, anonymous, PrimOf )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Flags ( isInteractive, rollbackInWorkingDir )
import Darcs.Patch.Set ( PatchSet(..), newset2FL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Witnesses.Ordered
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Lock ( worldReadableTemp )
import Darcs.Match ( firstMatch )
import Darcs.SelectChanges ( selectChanges,
                             WhichChanges(..),
                             selectionContext, selectionContextPrim,
                             runSelection
                           )
import Darcs.Commands.Record ( getLog )
import Darcs.Commands.Unrecord ( getLastPatches )
import Darcs.Commands.Util ( announceFiles, filterExistingFiles )
import Darcs.Utils ( clarifyErrors, PromptConfig(..), promptChar )
import Printer ( renderString )
import Progress ( debugMessage )
import Darcs.Witnesses.Sealed ( Sealed(..) )
import IsoDate ( getIsoDateTime )
import Storage.Hashed.Tree( Tree )
#include "impossible.h"
#include "gadts.h"

rollbackDescription :: String
rollbackDescription =
 "Record a new patch reversing some recorded changes."

rollbackHelp :: String
rollbackHelp =
 "Rollback is used to undo the effects of one or more patches without actually\n"++
 "deleting them.  Instead, it creates a new patch reversing selected portions.\n"++
 "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++
 "goal) rollback is perfectly safe, since it leaves in the repository a record\n"++
 "of its changes.\n"

rollback :: DarcsCommand
rollback = DarcsCommand {commandProgramName = "darcs",
                         commandName = "rollback",
                         commandHelp = rollbackHelp,
                         commandDescription = rollbackDescription,
                         commandExtraArgs = -1,
                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],
                         commandCommand = rollbackCmd,
                         commandPrereq = amInHashedRepository,
                         commandGetArgPossibilities = listRegisteredFiles,
                         commandArgdefaults = nodefaults,
                         commandAdvancedOptions = [nocompress,umaskOption],
                         commandBasicOptions = [matchSeveralOrLast,
                                                  allInteractive,
                                                  author, patchnameOption, askLongComment,
                                                  notest, leaveTestDir,
                                                  workingRepoDir, recordRollback]}

rollbackCmd :: [DarcsFlag] -> [String] -> IO ()
rollbackCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do
  files <- if null args then return Nothing
    else Just . sort <$> fixSubPaths opts args
  when (files == Just []) $ fail "No valid arguments were given."
  let files_fp = map toFilePath <$> files
  announceFiles files "Recording changes in"
  existing_files <- maybe (return Nothing)
    (fmap Just . filterExistingFiles repository) files
  when (existing_files == Just []) $
       fail "None of the files you specified exist!"
  allpatches <- readRepo repository
  (_ :> patches) <- return $ if firstMatch opts
                             then getLastPatches opts allpatches
                             else (PatchSet NilRL NilRL):> (newset2FL allpatches)
  let patches_context = selectionContext "rollback" opts Nothing files_fp
  (_ :> ps) <- runSelection (selectChanges LastReversed patches) patches_context
  when (nullFL ps) $ do putStrLn "No patches selected!"
                        exitWith ExitSuccess
  setEnvDarcsPatches ps
  let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp Nothing
      hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)
  runSelection (selectChanges Last hunks) hunks_context >>=
               if (rollbackInWorkingDir opts)
               then (undoItNow opts repository)
               else (rollItBackNow opts repository ps)

rollItBackNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) =>
                [DarcsFlag] -> Repository p C(r u t) ->  FL (PatchInfoAnd p) C(x y)
                            -> (q :> FL (PrimOf p)) C(a t) -> IO ()
rollItBackNow opts repository  ps (_ :> ps'') =
         do when (nullFL ps'') $ do putStrLn "No changes selected!"
                                    exitWith ExitSuccess
            let make_log = worldReadableTemp "darcs-rollback"
                newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))
            --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)
            (name, my_log, logf) <- getLog opts newlog make_log $ invert ps''
            date <- getIsoDateTime
            my_author <- getAuthor opts
            rbp <- n2pia `fmap` namepatch date name my_author my_log
                                          (fromPrims $ invert ps'')
            debugMessage "Adding rollback patch to repository."
            Sealed pw <-
                tentativelyMergePatches repository "rollback"
                                            (MarkConflicts : opts) NilFL
                                            (rbp :>: NilFL)
            debugMessage "Finalizing rollback changes..."
            invalidateIndex repository
            rc <- testTentative repository
            when (rc /= ExitSuccess) $ do
                when (not $ isInteractive opts) $ exitWith rc
                putStrLn $ "Looks like you have a bad patch: '"++name++"'"
                let prompt = "Shall I rollback anyway?"
                yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])
                case yn of
                  'y' -> return ()
                  _ -> exitWith rc
            withGutsOf repository $ do
              finalizeRepositoryChanges repository
              debugMessage "About to apply rolled-back changes to working directory."
              _ <- revertable $ applyToWorking repository opts pw
              return ()
            when (isJust logf) $ removeFile (fromJust logf)
            putStrLn "Finished rolling back."
          where revertable x = x `clarifyErrors` unlines
                  ["Error applying patch to the working directory.","",
                   "This may have left your working directory an inconsistent",
                   "but recoverable state. If you had no un-recorded changes",
                   "by using 'darcs revert' you should be able to make your",
                   "working directory consistent again."]

undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
          => [DarcsFlag] -> Repository p C(r u t)
          -> (q :> FL (PrimOf p)) C(a t) -> IO ()
undoItNow opts repo (_ :> prims) =
    do
      rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)
      Sealed pw <- considerMergeToWorking repo "rollback" (MarkConflicts: opts)
                                                     NilFL (rbp :>: NilFL)
      tentativelyAddToPending repo opts pw
      withGutsOf repo $ do
        finalizeRepositoryChanges repo
        _ <- applyToWorking repo opts pw `catch` \(e :: IOException) ->
            fail ("error applying rolled back patch to working directory\n"
                  ++ show e)
        debugMessage "Finished applying unrecorded rollback patch"

