9913121b40c3dc4f9892582558d3e79f85905732
[darcs-mirror-ipatch.git] / src / IPatch / Apply.hs
1 {-
2  - Copyright (C) 2010 Joachim Breitner
3  - 
4  - This program is free software; you can redistribute it and/or modify
5  - it under the terms of the GNU General Public License as published by
6  - the Free Software Foundation; either version 2, or (at your option)
7  - any later version.
8  - 
9  - This program is distributed in the hope that it will be useful,
10  - but WITHOUT ANY WARRANTY; without even the implied warranty of
11  - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  - GNU General Public License for more details.
13  - 
14  - You should have received a copy of the GNU General Public License
15  - along with this program; see the file COPYING.  If not, write to
16  - the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17  - Boston, MA 02110-1301, USA.
18  -}
19 {-# LANGUAGE Rank2Types #-}
20 module IPatch.Apply where
21
22 import Control.Monad ( when )
23 import System.Exit ( exitWith, ExitCode(ExitSuccess) )
24
25 import Darcs.Commands
26     ( DarcsCommand(DarcsCommand, commandAdvancedOptions,
27                    commandArgdefaults, commandBasicOptions, commandCommand,
28                    commandDescription, commandExtraArgHelp, commandExtraArgs,
29                    commandGetArgPossibilities, commandHelp, commandName,
30                    commandPrereq) )
31 import Darcs.Arguments ( DarcsFlag, fixFilePathOrStd, listFiles )
32 import Darcs.Repository
33     ( amNotInRepository, applyToWorking, withRepoLock )
34 import Darcs.RepoPath ( FilePathLike(..) )
35 import Darcs.Patch ( Effect(effect) )
36 import Workaround ( getCurrentDirectory )
37 import Darcs.Global ( debugMessage )
38 import Darcs.Utils ( promptYorn )
39 import Darcs.SelectChanges
40     ( WhichChanges(First),
41       runSelection,
42       selectChanges,
43       selectionContextPrim )
44 import Darcs.Patch.Split ( primSplitter )
45 import Darcs.Witnesses.Ordered ( (:>)(..), nullFL )
46
47 import IPatch.Common
48     ( diffToPrims,
49       initializeBaseState,
50       withTempRepository,
51       stdindefault,
52       clonePathsWithDeletion )
53 import IPatch.DiffFile ( filesTouchedByDiff, readDiffFile )
54
55 applyHelp :: String
56 applyHelp =
57     "The `ipatch apply file.patch' command works similar to a `patch file.patch' command.\n" ++
58     "It will, however, prompt the user about each part of the patch, whether it should\n" ++
59     "be applied or not. Using the integrated hunk editor, the user has full control over\n" ++
60     "the chosen changes.\n"++
61     "\n"++
62     "No files are touched until the end, when the user is asked for a final confirmation.\n"
63
64 applyDescription :: String
65 applyDescription = "Apply a diff file interactively."
66
67 apply :: DarcsCommand
68 apply = DarcsCommand {commandName = "apply",
69                       commandHelp = applyHelp,
70                       commandDescription = applyDescription,
71                       commandExtraArgs = 1,
72                       commandExtraArgHelp = ["<PATCHFILE>"],
73                       commandCommand = applyCmd,
74                       commandPrereq = amNotInRepository,
75                       commandGetArgPossibilities = listFiles,
76                       commandArgdefaults = const stdindefault,
77                       commandAdvancedOptions = [],
78                       commandBasicOptions = []}
79
80 applyCmd :: [DarcsFlag] -> [String] -> IO ()
81 applyCmd _ [""] = fail "Empty filename argument given to apply!"
82 applyCmd opts [unfixed_patchesfile] = do
83     maindir <- getCurrentDirectory
84     patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
85     diffPS <- readDiffFile patchesfile
86     files <- filesTouchedByDiff diffPS
87     if null files
88       then putStrLn "Patch seems to be empty"
89       else withTempRepository "work" $ \rdir -> do
90         initializeBaseState rdir maindir files
91
92         patch_ps <- diffToPrims diffPS
93
94         -- Ask the user which parts of the patch to apply
95         let context = selectionContextPrim "apply" [] (Just primSplitter) []
96         let selector = selectChanges First patch_ps
97         (wanted_ps :> _) <- runSelection selector context
98
99         when (nullFL patch_ps) $ do
100             putStrLn "You selected nothing, so I'm exiting!"
101             exitWith ExitSuccess
102         debugMessage $ "Applying selected patches"
103         withRepoLock [] $ \repo -> do
104             {- wanted_patch <- namepatch "NODATE" "Chosen Patch" "NOAUTHOR" [] (fromPrims wanted_ps)
105             tentativelyAddPatch repo [] $ n2pia wanted_patch
106             invalidateIndex repo
107             withGutsOf repo (finalizeRepositoryChanges repo)
108                         `clarifyErrors` "Failed to apply inital patch"
109             -}
110             applyToWorking repo opts (effect wanted_ps) `catch` \e ->
111                     fail ("Error applying patch to working dir:\n" ++ show e)
112       
113             yorn <- promptYorn "Really apply the selected changes?"
114             when (yorn == 'y') $ do
115                 clonePathsWithDeletion (toFilePath rdir) maindir files
116
117         {-
118         debugMessage $ "Printing selected parts"
119         withTempDir "ipatch-repo-old" $ \opath -> do
120           withTempDir "ipatch-repo-new" $ \npath -> do
121             setCurrentDirectory (toFilePath rdir)
122
123             debugMessage $ "Write out patched state"
124             withRepoLock (testByDefault []) $ \repo -> do
125                 n <- slurp_recorded repo
126                 withCurrentDirectory npath $ writeSlurpy n "."
127
128             withRepoLock (testByDefault []) $ \repo -> do
129                 debugMessage $ "Return to unpatched state"
130                 withGutsOf repo $ do
131                     -- How to wrap wanted_patch in FL wanted_patch?
132                     (_ :> top_patch) <- splitAtFL 1 . patchSetToPatches  <$> read_repo repo
133                     tentativelyRemovePatches repo [] top_patch
134                     tentativelyAddToPending repo [] $ invert $ effect top_patch
135                     finalizeRepositoryChanges repo
136                     applyToWorking repo [] (invert wanted_ps) `catch`
137                         \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e)
138
139             debugMessage $ "Write out unpatched state"
140             withRepoLock (testByDefault []) $ \repo -> do
141                 o <- slurp_recorded repo
142                 withCurrentDirectory opath $ writeSlurpy o "."
143
144             output <- execPipeIgnoreError "diff" ["-u","-r",toFilePath opath,toFilePath npath] empty
145             putDoc output
146         -}
147
148         return ()