1-- Copyright (C) 2002-2004,2007-2008 David Roundy
2-- Copyright (C) 2005 Juliusz Chroboczek
3-- Copyright (C) 2009 Petr Rockai
4--
5-- This program is free software; you can redistribute it and/or modify
6-- it under the terms of the GNU General Public License as published by
7-- the Free Software Foundation; either version 2, or (at your option)
8-- any later version.
9--
10-- This program is distributed in the hope that it will be useful,
11-- but WITHOUT ANY WARRANTY; without even the implied warranty of
12-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13-- GNU General Public License for more details.
14--
15-- You should have received a copy of the GNU General Public License
16-- along with this program; see the file COPYING.  If not, write to
17-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18-- Boston, MA 02110-1301, USA.
19
20
21module Darcs.Repository.Merge
22    ( tentativelyMergePatches
23    , considerMergeToWorking
24    ) where
25
26import Darcs.Prelude
27
28import Control.Monad ( when, unless )
29import System.Exit ( exitSuccess )
30import System.IO.Error
31    ( catchIOError
32    , ioeGetErrorType
33    , isIllegalOperationErrorType
34    )
35
36import Darcs.Util.Tree( Tree )
37import Darcs.Util.External ( backupByCopying )
38
39import Darcs.Patch
40    ( RepoPatch, IsRepoType, PrimOf, merge
41    , effect
42    , listConflictedFiles )
43import Darcs.Patch.Apply ( ApplyState )
44import Darcs.Patch.Ident ( merge2FL )
45import Darcs.Patch.Named ( patchcontents, anonymous )
46import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
47import Darcs.Patch.Progress( progressFL )
48import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL )
49import Darcs.Patch.Witnesses.Ordered
50    ( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)
51    , mapFL_FL, concatFL, reverseFL )
52import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )
53
54import Darcs.Repository.Flags
55    ( UseIndex
56    , ScanKnown
57    , AllowConflicts (..)
58    , Reorder (..)
59    , UpdatePending (..)
60    , ExternalMerge (..)
61    , Verbosity (..)
62    , Compression (..)
63    , WantGuiPause (..)
64    , DiffAlgorithm (..)
65    , LookForMoves(..)
66    , LookForReplaces(..)
67    )
68import Darcs.Repository.Hashed
69    ( tentativelyAddPatches_
70    , tentativelyRemovePatches_
71    , UpdatePristine(..)
72    )
73import Darcs.Repository.Pristine
74    ( applyToTentativePristine
75    , ApplyDir(..)
76    )
77import Darcs.Repository.InternalTypes ( Repository, repoLocation )
78import Darcs.Repository.Pending ( setTentativePending )
79import Darcs.Repository.Resolution
80    ( externalResolution
81    , standardResolution
82    , StandardResolution(..)
83    , announceConflicts
84    )
85import Darcs.Repository.State ( unrecordedChanges, readUnrecorded )
86
87import Darcs.Util.Prompt ( promptYorn )
88import Darcs.Util.Path ( anchorPath, displayPath )
89import Darcs.Util.Progress( debugMessage )
90import Darcs.Util.Printer.Color ( ePutDocLn )
91import Darcs.Util.Printer ( redText, vcat )
92
93data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )
94
95{- 'tentativelyMergePatches' is not easy to understand by just staring at
96the code. So here is an in-depth explanation.
97
98We start out at the state X at which our repo and the their repo deviate,
99assuming any patches common to both repos have first been commuted to the
100common part before X. So X is the intermediate state that is existentially
101hiddden inside the Fork we get passed as argument. R is our recorded state
102and Y is the recorded state of their repo.
103
104 Y       R
105  \     /
106 them  us
107    \ /
108     X
109     |
110   common
111     |
112     O
113
114We will elide the common part from now on. It doesn't change and we only
115pass it unmodified to standardResolution, see below.
116
117The easy part is to merge the local patches (us) with the remote ones
118(them), giving us them' and us'.
119
120     T
121    / \
122  us'  them'
123  /     \
124 Y       R
125  \     /
126 them  us
127    \ /
128     X
129
130
131We can ignore us' and just add them' on top of us (which are already in our
132repo), unless --reorder-patches is in effect, in which case we remove us and
133then first add them and afterwards us'. The new state on top is T which
134stands for the new /tentative/ state i.e. what will become the recorded
135state after we finalize our changes.
136
137But we're not done yet: we must also adapt the pending patch and the working
138tree. Note that changing the working tree is not done in this procedure, we
139merely return a list of prims to apply to working. Let us add the difference
140between pristine and working, which we call pw, to the picture.
141
142     T       U
143    / \     /
144 us' them' pw
145  /     \ /
146 Y       R
147  \     /
148 them  us
149    \ /
150     X
151
152It is easy to see now that we must merge pw with them', as both start at the
153(old) recorded state. This gives us pw' and them''.
154
155         U'
156        / \
157      pw' them''
158      /     \
159     T       U
160    / \     /
161 us' them' pw
162  /     \ /
163 Y       R
164  \     /
165 them  us
166    \ /
167     X
168
169Since U is our unrecorded state, them'' leads us from our old unrecorded
170state to the new one, so this is what we will return (if there are no
171conflicts; if there are, see below).
172
173What about the pending patch? It starts at R and goes half-way toward U
174since it is a prefix of pw. The new pending should start at T and go
175half-way toward the new working state U'. Instead of adapting the old
176pending patch, we set the new pending patch to pw', ignoring the old one.
177This relies on sifting to commute out and drop the parts that need not be in
178the pending patch, which is done when we finalize the tentative changes.
179
180Up to now we did not consider conflicts. Any new conflicts arising from the
181merges we made so far must be "resolved", that is, marked for manual
182resolution, if possible, or at least reported o the user. We made two
183merges, one with us and one with pw. It is important now to realize that our
184existing repo, and in particular the sequence us, could already be
185conflicted. Our job is to resolve only /new/ conflicts and not any
186unresolved conflicts that were already in our repo. So, from the rightmost
187branch of our double merge us+>+pw+>+them'', we should /not/ resolve us. And
188since the original pw cannot be conflicted (it consists of prim patches
189only) we can disregard it. This leaves only them'' which is what we pass to
190standardResolution to generate the markup, along with its full context,
191consisting of (common +>+ us +>+ pw).
192
193The resulting "resolution" goes on top, leading to our final unrecorded
194state U'':
195
196         U''
197         |
198        res
199         |
200         U'
201        / \
202    pw'  them''
203      /     \
204     T       U
205    / \     /
206 us' them' pw
207  /     \ /
208 Y       R
209  \     /
210 them  us
211    \ /
212     X
213
214In case the patches we pull are in conflict with local /unrecorded/ changes
215(i.e. pw), we want to warn the user about that and allow them to cancel the
216operation. The reason is that it is hard to reconstruct the original
217unrecorded changes when they are messed up with conflict resolution markup.
218To see if this is the case we check whether pw' has conflicts. As an extra
219precaution we backup any conflicted files, so the user can refer to them to
220restore things or compare in a diff viewer.
221
222The patches we return are what we need to update U to U'' i.e. them''+>+res.
223The new pending patch starts out at the new tentative state, so as explained
224above, we set it to pw'+>+res, and again rely on sifting to commute out and
225drop anything we don't need.
226
227TODO: We should return a properly coerced @Repository rt p wR wU wT@.
228-}
229
230tentativelyMergePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
231                         => MakeChanges
232                         -> Repository rt p wR wU wR -> String
233                         -> AllowConflicts
234                         -> ExternalMerge -> WantGuiPause
235                         -> Compression -> Verbosity -> Reorder
236                         -> ( UseIndex, ScanKnown, DiffAlgorithm )
237                         -> Fork (PatchSet rt p)
238                                 (FL (PatchInfoAnd rt p))
239                                 (FL (PatchInfoAnd rt p)) Origin wR wY
240                         -> IO (Sealed (FL (PrimOf p) wU))
241tentativelyMergePatches_ mc _repo cmd allowConflicts externalMerge wantGuiPause
242  compression verbosity reorder diffingOpts@(useidx, _, dflag) (Fork context us them) = do
243    (them' :/\: us')
244         <- return $ merge2FL (progressFL "Merging us" us)
245                              (progressFL "Merging them" them)
246    pw <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces _repo Nothing
247    -- Note: we use anonymous here to wrap the unrecorded changes.
248    -- This is benign because we only retain the effect of the results
249    -- of the merge (pw' and them'').
250    anonpw <- n2pia `fmap` anonymous pw
251    pw' :/\: them'' <- return $ merge (them' :\/: anonpw :>: NilFL)
252    let them''content = concatFL $ progressFL "Examining patches for conflicts" $
253                                mapFL_FL (patchcontents . hopefully) them''
254    let conflicts =
255          standardResolution
256            (patchSet2RL context +<<+ us :<: anonpw)
257            (reverseFL them'')
258    let standard_resolution = mangled conflicts
259
260    debugMessage "Checking for conflicts..."
261    when (allowConflicts == YesAllowConflictsAndMark) $
262        mapM_ backupByCopying $
263        map (anchorPath (repoLocation _repo)) $
264        conflictedPaths conflicts
265
266    debugMessage "Announcing conflicts..."
267    have_conflicts <-
268        announceConflicts cmd allowConflicts externalMerge conflicts
269
270    debugMessage "Checking for unrecorded conflicts..."
271    let pw'content = concatFL $ progressFL "Examining patches for conflicts" $
272                                mapFL_FL (patchcontents . hopefully) pw'
273    case listConflictedFiles pw'content of
274        [] -> return ()
275        fs -> do
276          ePutDocLn $ vcat $ map redText $
277            "You have conflicting unrecorded changes to:" : map displayPath fs
278          -- we catch "hIsTerminalDevice: illegal operation (handle is closed)"
279          -- which can be thrown when we apply patches remotely (i.e. during push)
280          confirmed <- promptYorn "Proceed?" `catchIOError` (\e ->
281            if isIllegalOperationErrorType (ioeGetErrorType e)
282              then return True
283              else ioError e)
284          unless confirmed $ do
285            putStrLn "Cancelled."
286            exitSuccess
287
288    debugMessage "Reading working tree..."
289    working <- readUnrecorded _repo useidx Nothing
290
291    debugMessage "Working out conflict markup..."
292    Sealed resolution <-
293        case (externalMerge , have_conflicts) of
294            (NoExternalMerge, _)       -> return $ if allowConflicts == YesAllowConflicts
295                                                     then seal NilFL
296                                                     else standard_resolution
297            (_, False)                 -> return $ standard_resolution
298            (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause
299                                             (effect us +>+ pw) (effect them) them''content
300
301    debugMessage "Adding patches to the inventory and writing new pending..."
302    when (mc == MakeChanges) $ do
303        applyToTentativePristine _repo ApplyNormal verbosity them'
304        -- these two cases result in the same trees (that's the idea of
305        -- merging), so we only operate on the set of patches and do the
306        -- adaption of pristine and pending in the common code below
307        _repo <- case reorder of
308            NoReorder -> do
309                tentativelyAddPatches_ DontUpdatePristine _repo
310                    compression verbosity NoUpdatePending them'
311            Reorder -> do
312                -- we do not actually remove any effect in the end, so
313                -- it would be wrong to update the unrevert bundle or
314                -- the working tree or pending
315                r1 <- tentativelyRemovePatches_ DontUpdatePristineNorRevert _repo
316                          compression NoUpdatePending us
317                r2 <- tentativelyAddPatches_ DontUpdatePristine r1
318                          compression verbosity NoUpdatePending them
319                tentativelyAddPatches_ DontUpdatePristine r2
320                    compression verbosity NoUpdatePending us'
321        setTentativePending _repo (effect pw' +>+ resolution)
322    return $ seal (effect them''content +>+ resolution)
323
324tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
325                        => Repository rt p wR wU wR -> String
326                        -> AllowConflicts
327                        -> ExternalMerge -> WantGuiPause
328                        -> Compression -> Verbosity -> Reorder
329                        -> ( UseIndex, ScanKnown, DiffAlgorithm )
330                        -> Fork (PatchSet rt p)
331                                (FL (PatchInfoAnd rt p))
332                                (FL (PatchInfoAnd rt p)) Origin wR wY
333                        -> IO (Sealed (FL (PrimOf p) wU))
334tentativelyMergePatches = tentativelyMergePatches_ MakeChanges
335
336
337considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
338                       => Repository rt p wR wU wR -> String
339                       -> AllowConflicts
340                       -> ExternalMerge -> WantGuiPause
341                       -> Compression -> Verbosity -> Reorder
342                       -> ( UseIndex, ScanKnown, DiffAlgorithm )
343                       -> Fork (PatchSet rt p)
344                               (FL (PatchInfoAnd rt p))
345                               (FL (PatchInfoAnd rt p)) Origin wR wY
346                       -> IO (Sealed (FL (PrimOf p) wU))
347considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges
348