Initial check-in
[darcs-mirror-ipatch.git] / Apply.hs
1 {-# LANGUAGE Rank2Types #-}
2 module Apply where
3
4 import Control.Monad ( when )
5 import System.Exit ( exitWith, ExitCode(ExitSuccess) )
6
7 import Darcs.Commands
8     ( DarcsCommand(DarcsCommand, commandAdvancedOptions,
9                    commandArgdefaults, commandBasicOptions, commandCommand,
10                    commandDescription, commandExtraArgHelp, commandExtraArgs,
11                    commandGetArgPossibilities, commandHelp, commandName,
12                    commandPrereq) )
13 import Darcs.Arguments ( DarcsFlag, fixFilePathOrStd, listFiles )
14 import Darcs.Repository
15     ( amNotInRepository, applyToWorking, withRepoLock )
16 import Darcs.RepoPath ( FilePathLike(..) )
17 import Darcs.External ( clonePaths )
18 import Darcs.Patch ( Effect(effect) )
19 import Workaround ( getCurrentDirectory )
20 import Darcs.Global ( debugMessage )
21 import Darcs.Utils ( promptYorn )
22 import Darcs.SelectChanges
23     ( WhichChanges(First),
24       runSelection,
25       selectChanges,
26       selectionContextPrim )
27 import Darcs.Patch.Split ( primSplitter )
28 import Darcs.Witnesses.Ordered ( (:>)(..), nullFL )
29
30 import Common
31     ( diffToPrims,
32       initializeBaseState,
33       withTempRepository,
34       stdindefault )
35 import DiffFile ( filesTouchedByDiff, readDiffFile )
36
37 applyHelp :: String
38 applyHelp = "apply help"
39
40 applyDescription :: String
41 applyDescription = "Apply a diff file interactively."
42
43 apply :: DarcsCommand
44 apply = DarcsCommand {commandName = "apply",
45                       commandHelp = applyHelp,
46                       commandDescription = applyDescription,
47                       commandExtraArgs = 1,
48                       commandExtraArgHelp = ["<PATCHFILE>"],
49                       commandCommand = applyCmd,
50                       commandPrereq = amNotInRepository,
51                       commandGetArgPossibilities = listFiles,
52                       commandArgdefaults = const stdindefault,
53                       commandAdvancedOptions = [],
54                       commandBasicOptions = []}
55
56 applyCmd :: [DarcsFlag] -> [String] -> IO ()
57 applyCmd _ [""] = fail "Empty filename argument given to apply!"
58 applyCmd opts [unfixed_patchesfile] = do
59     maindir <- getCurrentDirectory
60     patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
61     diffPS <- readDiffFile patchesfile
62     files <- filesTouchedByDiff diffPS
63     if null files
64       then putStrLn "Patch seems to be empty"
65       else withTempRepository "work" $ \rdir -> do
66         initializeBaseState rdir maindir files
67
68         patch_ps <- diffToPrims diffPS
69
70         -- Ask the user which parts of the patch to apply
71         let context = selectionContextPrim "apply" [] (Just primSplitter) []
72         let selector = selectChanges First patch_ps
73         (wanted_ps :> _) <- runSelection selector context
74
75         when (nullFL patch_ps) $ do
76             putStrLn "You selected nothing, so I'm exiting!"
77             exitWith ExitSuccess
78         debugMessage $ "Applying selected patches"
79         withRepoLock [] $ \repo -> do
80             {- wanted_patch <- namepatch "NODATE" "Chosen Patch" "NOAUTHOR" [] (fromPrims wanted_ps)
81             tentativelyAddPatch repo [] $ n2pia wanted_patch
82             invalidateIndex repo
83             withGutsOf repo (finalizeRepositoryChanges repo)
84                         `clarifyErrors` "Failed to apply inital patch"
85             -}
86             applyToWorking repo opts (effect wanted_ps) `catch` \e ->
87                     fail ("Error applying patch to working dir:\n" ++ show e)
88       
89             yorn <- promptYorn "Really apply the selected changes?"
90             when (yorn == 'y') $ do
91                 clonePaths (toFilePath rdir) maindir files
92
93         {-
94         debugMessage $ "Printing selected parts"
95         withTempDir "ipatch-repo-old" $ \opath -> do
96           withTempDir "ipatch-repo-new" $ \npath -> do
97             setCurrentDirectory (toFilePath rdir)
98
99             debugMessage $ "Write out patched state"
100             withRepoLock (testByDefault []) $ \repo -> do
101                 n <- slurp_recorded repo
102                 withCurrentDirectory npath $ writeSlurpy n "."
103
104             withRepoLock (testByDefault []) $ \repo -> do
105                 debugMessage $ "Return to unpatched state"
106                 withGutsOf repo $ do
107                     -- How to wrap wanted_patch in FL wanted_patch?
108                     (_ :> top_patch) <- splitAtFL 1 . patchSetToPatches  <$> read_repo repo
109                     tentativelyRemovePatches repo [] top_patch
110                     tentativelyAddToPending repo [] $ invert $ effect top_patch
111                     finalizeRepositoryChanges repo
112                     applyToWorking repo [] (invert wanted_ps) `catch`
113                         \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e)
114
115             debugMessage $ "Write out unpatched state"
116             withRepoLock (testByDefault []) $ \repo -> do
117                 o <- slurp_recorded repo
118                 withCurrentDirectory opath $ writeSlurpy o "."
119
120             output <- execPipeIgnoreError "diff" ["-u","-r",toFilePath opath,toFilePath npath] empty
121             putDoc output
122         -}
123
124         return ()