Use commandProgramName
[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 ( DarcsCommand(..) )
26 import Darcs.Arguments ( DarcsFlag, fixFilePathOrStd, listFiles )
27 import Darcs.Repository
28     ( amNotInRepository, applyToWorking, withRepoLock )
29 import Darcs.RepoPath ( FilePathLike(..) )
30 import Darcs.Patch ( Effect(effect) )
31 import Workaround ( getCurrentDirectory )
32 import Darcs.Global ( debugMessage )
33 import Darcs.Utils ( promptYorn )
34 import Darcs.SelectChanges
35     ( WhichChanges(First),
36       runSelection,
37       selectChanges,
38       selectionContextPrim )
39 import Darcs.Patch.Split ( primSplitter )
40 import Darcs.Witnesses.Ordered ( (:>)(..), nullFL )
41
42 import IPatch.Common
43     ( diffToPrims,
44       initializeBaseState,
45       withTempRepository,
46       stdindefault,
47       clonePathsWithDeletion )
48 import IPatch.DiffFile ( filesTouchedByDiff, readDiffFile )
49
50 applyHelp :: String
51 applyHelp =
52     "The `ipatch apply file.patch' command works similar to a `patch file.patch' command.\n" ++
53     "It will, however, prompt the user about each part of the patch, whether it should\n" ++
54     "be applied or not. Using the integrated hunk editor, the user has full control over\n" ++
55     "the chosen changes.\n"++
56     "\n"++
57     "No files are touched until the end, when the user is asked for a final confirmation.\n"
58
59 applyDescription :: String
60 applyDescription = "Apply a diff file interactively."
61
62 apply :: DarcsCommand
63 apply = DarcsCommand {commandProgramName = "ipatch",
64                       commandName = "apply",
65                       commandHelp = applyHelp,
66                       commandDescription = applyDescription,
67                       commandExtraArgs = 1,
68                       commandExtraArgHelp = ["<PATCHFILE>"],
69                       commandCommand = applyCmd,
70                       commandPrereq = amNotInRepository,
71                       commandGetArgPossibilities = listFiles,
72                       commandArgdefaults = const stdindefault,
73                       commandAdvancedOptions = [],
74                       commandBasicOptions = []}
75
76 applyCmd :: [DarcsFlag] -> [String] -> IO ()
77 applyCmd _ [""] = fail "Empty filename argument given to apply!"
78 applyCmd opts [unfixed_patchesfile] = do
79     maindir <- getCurrentDirectory
80     patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
81     diffPS <- readDiffFile patchesfile
82     files <- filesTouchedByDiff diffPS
83     if null files
84       then putStrLn "Patch seems to be empty"
85       else withTempRepository "work" $ \rdir -> do
86         initializeBaseState rdir maindir files
87
88         patch_ps <- diffToPrims diffPS
89
90         -- Ask the user which parts of the patch to apply
91         let context = selectionContextPrim "apply" [] (Just primSplitter) []
92         let selector = selectChanges First patch_ps
93         (wanted_ps :> _) <- runSelection selector context
94
95         when (nullFL patch_ps) $ do
96             putStrLn "You selected nothing, so I'm exiting!"
97             exitWith ExitSuccess
98         debugMessage $ "Applying selected patches"
99         withRepoLock [] $ \repo -> do
100             {- wanted_patch <- namepatch "NODATE" "Chosen Patch" "NOAUTHOR" [] (fromPrims wanted_ps)
101             tentativelyAddPatch repo [] $ n2pia wanted_patch
102             invalidateIndex repo
103             withGutsOf repo (finalizeRepositoryChanges repo)
104                         `clarifyErrors` "Failed to apply inital patch"
105             -}
106             applyToWorking repo opts (effect wanted_ps) `catch` \e ->
107                     fail ("Error applying patch to working dir:\n" ++ show e)
108       
109             yorn <- promptYorn "Really apply the selected changes?"
110             when (yorn == 'y') $ do
111                 clonePathsWithDeletion (toFilePath rdir) maindir files
112
113         {-
114         debugMessage $ "Printing selected parts"
115         withTempDir "ipatch-repo-old" $ \opath -> do
116           withTempDir "ipatch-repo-new" $ \npath -> do
117             setCurrentDirectory (toFilePath rdir)
118
119             debugMessage $ "Write out patched state"
120             withRepoLock (testByDefault []) $ \repo -> do
121                 n <- slurp_recorded repo
122                 withCurrentDirectory npath $ writeSlurpy n "."
123
124             withRepoLock (testByDefault []) $ \repo -> do
125                 debugMessage $ "Return to unpatched state"
126                 withGutsOf repo $ do
127                     -- How to wrap wanted_patch in FL wanted_patch?
128                     (_ :> top_patch) <- splitAtFL 1 . patchSetToPatches  <$> read_repo repo
129                     tentativelyRemovePatches repo [] top_patch
130                     tentativelyAddToPending repo [] $ invert $ effect top_patch
131                     finalizeRepositoryChanges repo
132                     applyToWorking repo [] (invert wanted_ps) `catch`
133                         \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e)
134
135             debugMessage $ "Write out unpatched state"
136             withRepoLock (testByDefault []) $ \repo -> do
137                 o <- slurp_recorded repo
138                 withCurrentDirectory opath $ writeSlurpy o "."
139
140             output <- execPipeIgnoreError "diff" ["-u","-r",toFilePath opath,toFilePath npath] empty
141             putDoc output
142         -}
143
144         return ()