src/Darcs/Commands/Unrevert.lhs

   1 %  Copyright (C) 2003-2005 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \subsection{darcs unrevert}\label{unrevert}
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 #include "gadts.h"
  24
  25 module Darcs.Commands.Unrevert ( unrevert, write_unrevert ) where
  26 import System.Exit ( ExitCode(..), exitWith )
  27
  28 import Darcs.Commands ( DarcsCommand(..), nodefaults )
  29 import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ),
  30                          ignoretimes, working_repo_dir,
  31                         all_interactive, umask_option,
  32                       )
  33 import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-),
  34                           unrevertUrl, considerMergeToWorking,
  35                           tentativelyAddToPending, finalizeRepositoryChanges,
  36                           sync_repo, get_unrecorded,
  37                           read_repo, amInRepository,
  38                           slurp_recorded_and_unrecorded,
  39                           applyToWorking )
  40 import Darcs.Patch ( RepoPatch, Prim, commutex, namepatch, fromPrims )
  41 import Darcs.Ordered ( RL(..), FL(..), (:<)(..), (:>)(..), (:\/:)(..), reverseRL,
  42                        (+>+) )
  43 import Darcs.SelectChanges ( with_selected_changes_to_files' )
  44 import Darcs.SlurpDirectory ( Slurpy )
  45 import qualified Data.ByteString as B
  46 import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist )
  47 import Darcs.Patch.Depends ( get_common_and_uncommon )
  48 import Darcs.Utils ( askUser, catchall )
  49 import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
  50 import IsoDate ( getIsoDateTime )
  51 import Darcs.SignalHandler ( withSignalsBlocked )
  52 import Darcs.Progress ( debugMessage )
  53 import Darcs.Sealed ( Sealed(Sealed) )
  54 #include "impossible.h"
  55 \end{code}
  56 \begin{code}
  57 unrevert_description :: String
  58 unrevert_description =
  59  "Undo the last revert (may fail if changes after the revert)."
  60 \end{code}
  61
  62 \options{unrevert}
  63
  64 \haskell{unrevert_help}
  65 \begin{code}
  66 unrevert_help :: String
  67 unrevert_help =
  68  "Unrevert is used to undo the results of a revert command. It is only\n"++
  69  "guaranteed to work properly if you haven't made any changes since the\n"++
  70  "revert was performed.\n"
  71 \end{code}
  72 The command makes a best effort to merge the unreversion with any changes
  73 you have since made.  In fact, unrevert should even work if you've recorded
  74 changes since reverting.
  75 \begin{code}
  76 unrevert :: DarcsCommand
  77 unrevert = DarcsCommand {command_name = "unrevert",
  78                          command_help = unrevert_help,
  79                          command_description = unrevert_description,
  80                          command_extra_args = 0,
  81                          command_extra_arg_help = [],
  82                          command_command = unrevert_cmd,
  83                          command_prereq = amInRepository,
  84                          command_get_arg_possibilities = return [],
  85                          command_argdefaults = nodefaults,
  86                          command_advanced_options = [umask_option],
  87                          command_basic_options = [ignoretimes,
  88                                                   all_interactive,
  89                                                   working_repo_dir]}
  90 \end{code}
  91 \begin{code}
  92 unrevert_cmd :: [DarcsFlag] -> [String] -> IO ()
  93 unrevert_cmd opts [] = withRepoLock opts $- \repository -> do
  94   us <- read_repo repository
  95   Sealed them <- unrevert_patch_bundle repository
  96   (rec, working) <- slurp_recorded_and_unrecorded repository
  97   unrec <- get_unrecorded repository
  98   case get_common_and_uncommon (us, them) of
  99     (_, (h_us:<:NilRL) :\/: (h_them:<:NilRL)) -> do
 100       Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts)
 101                    (reverseRL h_us) (reverseRL h_them)
 102       with_selected_changes_to_files' "unrevert" opts working [] pw $
 103                             \ (p :> skipped) -> do
 104         tentativelyAddToPending repository opts p
 105         withSignalsBlocked $
 106           do finalizeRepositoryChanges repository
 107              applyToWorking repository opts p `catch` \e ->
 108                  fail ("Error applying unrevert to working directory...\n"
 109                        ++ show e)
 110              debugMessage "I'm about to write_unrevert."
 111              write_unrevert repository skipped rec (unrec+>+p)
 112         sync_repo repository
 113         debugMessage "Finished unreverting."
 114     _ -> impossible
 115 unrevert_cmd _ _ = impossible
 116 \end{code}
 117
 118 \begin{code}
 119 write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO ()
 120 write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository
 121 write_unrevert repository ps rec pend = do
 122   case commutex (ps :< pend) of
 123     Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "
 124                   case really of ('y':_) -> return ()
 125                                  _ -> exitWith $ ExitSuccess
 126                   write_unrevert repository NilFL rec pend
 127     Just (_ :< p') -> do
 128         rep <- read_repo repository
 129         case get_common_and_uncommon (rep,rep) of
 130             (common,_ :\/: _) -> do
 131                 date <- getIsoDateTime
 132                 np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')
 133                 writeDocBinFile (unrevertUrl repository) $
 134                              make_bundle [Unified] rec common (np :>: NilFL)
 135                 where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y)
 136                       fromRepoPrims _ xs = fromPrims xs
 137 \end{code}
 138
 139 \begin{code}
 140 unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p)
 141 unrevert_patch_bundle repository = do
 142   pf <- B.readFile (unrevertUrl repository)
 143         `catchall` fail "There's nothing to unrevert!"
 144   case scan_bundle pf of
 145       Right ps -> return ps
 146       Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
 147 \end{code}