% Copyright (C) 2003-2005 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{unrevert} \begin{code}

    {-# OPTIONS_GHC -cpp #-}
    {-# LANGUAGE CPP, GADTs #-}

    #include "gadts.h"

    module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where
    import System.Exit ( ExitCode(..), exitWith )
    import Storage.Hashed.Tree( Tree )

    import Darcs.Commands ( DarcsCommand(..), nodefaults )
    import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ),
                             ignoretimes, workingRepoDir,
                            allInteractive, umaskOption,
                          )
    import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-),
                              unrevertUrl, considerMergeToWorking,
                              tentativelyAddToPending, finalizeRepositoryChanges,
                              read_repo, amInRepository,
                              readRecorded,
                              applyToWorking, unrecordedChanges )
    import Darcs.Patch ( RepoPatch, Prim, commute, namepatch, fromPrims )
    import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), reverseRL,
                           (+>+) )
    import Darcs.SelectChanges ( with_selected_changes_to_files' )
    import qualified Data.ByteString as B
    import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist )
    import Darcs.Patch.Depends ( get_common_and_uncommon )
    import Darcs.Utils ( askUser, catchall )
    import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
    import IsoDate ( getIsoDateTime )
    import Darcs.SignalHandler ( withSignalsBlocked )
    import Progress ( debugMessage )
    import Darcs.Witnesses.Sealed ( Sealed(Sealed) )
    #include "impossible.h"

    unrevertDescription :: String
    unrevertDescription =
     "Undo the last revert (may fail if changes after the revert)."

    unrevertHelp :: String
    unrevertHelp =
     "Unrevert is a rescue command in case you accidentally reverted\n" ++
     "something you wanted to keep (for example, typing `darcs rev -a'\n" ++
     "instead of `darcs rec -a').\n" ++
     "\n" ++
     "This command may fail if the repository has changed since the revert\n" ++
     "took place.  Darcs will ask for confirmation before executing an\n" ++
     "interactive command that will DEFINITELY prevent unreversion.\n"

    unrevert :: DarcsCommand
    unrevert = DarcsCommand {commandName = "unrevert",
                             commandHelp = unrevertHelp,
                             commandDescription = unrevertDescription,
                             commandExtraArgs = 0,
                             commandExtraArgHelp = [],
                             commandCommand = unrevertCmd,
                             commandPrereq = amInRepository,
                             commandGetArgPossibilities = return [],
                             commandArgdefaults = nodefaults,
                             commandAdvancedOptions = [umaskOption],
                             commandBasicOptions = [ignoretimes,
                                                      allInteractive,
                                                      workingRepoDir]}

    unrevertCmd :: [DarcsFlag] -> [String] -> IO ()
    unrevertCmd opts [] = withRepoLock opts $- \repository -> do
      us <- read_repo repository
      Sealed them <- unrevertPatchBundle repository
      rec <- readRecorded repository
      unrec <- unrecordedChanges opts repository []
      case get_common_and_uncommon (us, them) of
        (_, h_us :\/: h_them) -> do
          Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts)
                       (reverseRL h_us) (reverseRL h_them)
          with_selected_changes_to_files' "unrevert" opts Nothing [] pw $
                                \ (p :> skipped) -> do
            tentativelyAddToPending repository opts p
            withSignalsBlocked $
              do finalizeRepositoryChanges repository
                 applyToWorking repository opts p `catch` \e ->
                     fail ("Error applying unrevert to working directory...\n"
                           ++ show e)
                 debugMessage "I'm about to writeUnrevert."
                 writeUnrevert repository skipped rec (unrec+>+p)
            debugMessage "Finished unreverting."
    unrevertCmd _ _ = impossible

    writeUnrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y)
                   -> Tree IO -> FL Prim C(r x) -> IO ()
    writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository
    writeUnrevert repository ps rec pend = do
      case commute (pend :> ps) of
        Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "
                      case really of ('y':_) -> return ()
                                     _ -> exitWith $ ExitSuccess
                      writeUnrevert repository NilFL rec pend
        Just (p' :> _) -> do
            rep <- read_repo repository
            case get_common_and_uncommon (rep,rep) of
                (common,_ :\/: _) -> do
                    date <- getIsoDateTime
                    np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')
                    bundle <- make_bundle [Unified] rec common (np :>: NilFL)
                    writeDocBinFile (unrevertUrl repository) bundle
                    where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y)
                          fromRepoPrims _ xs = fromPrims xs

    unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p)
    unrevertPatchBundle repository = do
      pf <- B.readFile (unrevertUrl repository)
            `catchall` fail "There's nothing to unrevert!"
      case scan_bundle pf of
          Right ps -> return ps
          Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err

\end{code}