source: cl-darcs/trunk/commute.lisp

Last change on this file was 114, checked in by Magnus Henoch, 15 years ago

Add COMMUTE methods for trivial commutations of FILE-PATCH and MERGER-PATCH.

File size: 7.3 KB
Line 
1;;; Copyright (C) 2006 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) 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 GNU
11;;; 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; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defgeneric commute (p2 p1)
20  (:documentation "Attempt to commute the patches P2 and P1.
21Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then
22P1-NEW has the same effect as applying P1 and then P2.
23If commutations fails, return nil."))
24
25(defmethod commute ((p2 patch) (p1 patch))
26  "Default method prints a warning and returns nil."
27  (warn "No method defined for commuting ~A and ~A." p2 p1)
28  nil)
29
30(defmethod commute ((p2 named-patch) (p1 patch))
31  "Commute a named patch and another patch."
32  (destructuring-bind (&optional p1-new p2-new)
33      (commute (named-patch-patch p2) p1)
34    (if p1-new
35        (list p1-new
36              (make-instance 'named-patch
37                             :patchinfo (named-patch-patchinfo p2)
38                             :dependencies (named-patch-dependencies p2)
39                             :patch p2-new))
40        (call-next-method))))
41
42(defmethod commute ((p2 patch) (p1 named-patch))
43  "Commute a patch with a named patch."
44  (destructuring-bind (&optional p1-new p2-new)
45      (commute p2 (named-patch-patch p1))
46    (if p1-new
47        (list (make-instance 'named-patch
48                             :patchinfo (named-patch-patchinfo p1)
49                             :dependencies (named-patch-dependencies p1)
50                             :patch p1-new)
51              p2-new)
52        (call-next-method))))
53
54(defmethod commute ((p2 move-patch) (p1 file-patch))
55  "Commute a move patch with a file patch."
56  (let ((patched-file (patch-filename p1))
57        (moved-from (patch-move-from p2))
58        (moved-to (patch-move-to p2)))
59    (cond
60      ;; File was patched and then moved
61      ((equal patched-file moved-from)
62       (let ((p1-new (copy-patch p1)))
63         (setf (patch-filename p1-new) moved-to)
64         (list p1-new p2)))
65      ;; Another file moved on top of original file
66      ((equal patched-file moved-to)
67       (warn "Collision when commuting ~A and ~A." p2 p1)
68       nil)
69      ;; Patches touch different files
70      (t
71       (list p1 p2)))))
72
73(defmethod commute ((p2 file-patch) (p1 move-patch))
74  "Commute a file patch with a move patch."
75  (let ((moved-from (patch-move-from p1))
76        (moved-to (patch-move-to p1))
77        (patched-file (patch-filename p2)))
78    (cond
79      ;; File was moved and then patched
80      ((equal moved-to patched-file)
81       (let ((p2-new (copy-patch p2)))
82         (setf (patch-filename p2-new) moved-from)
83         (list p1 p2-new)))
84      ;; File was moved before being patched
85      ((equal moved-from patched-file)
86       (warn "Collision when commuting ~A and ~A." p2 p1)
87       nil)
88      ;; Patches touch different files
89      (t
90       (list p1 p2)))))
91
92(defmethod commute :around ((p2 file-patch) (p1 file-patch))
93  "If P1 and P2 change different files, commutation is trivial."
94  (let ((p1-file (patch-filename p1))
95        (p2-file (patch-filename p2)))
96    (if (not (equal p1-file p2-file))
97        (list p1 p2)
98        (call-next-method))))
99
100(defmethod commute :around ((p2 file-patch) (p1 merger-patch))
101  "If P1 touches only one file, and P2 touches another, commutation is trivial."
102  (let ((p1-first (merger-first p1))
103        (p1-second (merger-second p1))
104        (p2-file (patch-filename p2)))
105    (if (and (typep p1-first 'file-patch)
106             (typep p1-second 'file-patch)
107             (equal (patch-filename p1-first) (patch-filename p1-second))
108             (not (equal (patch-filename p1-first) p2-file)))
109        (list p1 p2)
110        (call-next-method))))
111
112(defmethod commute :around ((p2 merger-patch) (p1 file-patch))
113  "If P2 touches only one file, and P1 touches another, commutation is trivial."
114  (let ((p1-file (patch-filename p1))
115        (p2-first (merger-first p2))
116        (p2-second (merger-second p2)))
117    (if (and (typep p2-first 'file-patch)
118             (typep p2-second 'file-patch)
119             (equal (patch-filename p2-first) (patch-filename p2-second))
120             (not (equal (patch-filename p2-first) p1-file)))
121        (list p1 p2)
122        (call-next-method))))
123
124(defmethod commute ((p2 hunk-patch) (p1 hunk-patch))
125  "Attempt to commute the two hunk patches P1 and P2."
126  (assert (equal (patch-filename p1) (patch-filename p2)))
127  (with-accessors ((line1 hunk-line-number)
128                   (old1 hunk-old-lines)
129                   (new1 hunk-new-lines)) p1
130    (with-accessors ((line2 hunk-line-number)
131                      (old2 hunk-old-lines)
132                      (new2 hunk-new-lines)) p2
133      (cond
134        ((< (+ line1 (length new1)) line2)
135         ;; The first patch changes text before the second patch.
136         (list p1
137               (make-instance 'hunk-patch :filename (patch-filename p2)
138                              :line-number (+ line2 (- (length new1)) (length old1))
139                              :old old2 :new new2)))
140        ((< (+ line2 (length old2)) line1)
141         ;; The second patch changes text before the first patch.
142         (list (make-instance 'hunk-patch :filename (patch-filename p1)
143                              :line-number (+ line1 (length new2) (- (length old2)))
144                              :old old1 :new new1)
145               p2))
146        ((and (= (+ line1 (length new1)) line2)
147              (notany #'zerop
148                      (mapcar #'length (list old1 old2 new1 new2))))
149         ;; The first patch goes exactly until the beginning of the second patch.
150         (list p1
151               (make-instance 'hunk-patch :filename (patch-filename p2)
152                              :line-number (+ line2 (- (length new1)) (length old1))
153                              :old old2 :new new2)))
154        ((and (= (+ line2 (length old2)) line1)
155              (notany #'zerop
156                      (mapcar #'length (list old1 old2 new1 new2))))
157         ;; The second patch goes exactly until the beginning of the first patch.
158         (list (make-instance 'hunk-patch :filename (patch-filename p1)
159                              :line-number (+ line1 (length new2) (- (length old2)))
160                              :old old1 :new new1)
161               p2))
162        (t
163         ;; In other cases, there is no failsafe way to commute the
164         ;; patches, so we give up.
165         nil)))))
166
167(defmethod commute ((p2 composite-patch) (p1 patch))
168  (cond
169    ;; Simple case first...
170    ((null (patches p2))
171     (list p1 p2))
172    (t
173     ;; Now, p1 was committed before all the patches in p2, and we
174     ;; want it to come after.
175     (let ((p2s (patches p2))
176           p2s-new)
177       (loop for p in p2s
178          do (destructuring-bind (&optional p1-new p-new)
179                 (commute p p1)
180               (cond
181                 ((null p1-new)
182                  (return-from commute (call-next-method)))
183                 (t
184                  (setf p1 p1-new)
185                  (push p-new p2s-new)))))
186       (list p1 (make-instance 'composite-patch :patches (nreverse p2s-new)))))))
187(defmethod commute ((p2 patch) (p1 composite-patch))
188  (cond
189    ((null (patches p1))
190     (list p1 p2))
191    (t
192     ;; p2 was committed after all the patches in p1.  Thus we start
193     ;; backwards in p1, commuting p2 with each of the patches.
194     (let ((p1s (reverse (patches p1)))
195           p1s-new)
196       (loop for p in p1s
197          do (destructuring-bind (&optional p-new p2-new)
198                 (commute p2 p)
199               (cond
200                 ((null p-new)
201                  (return-from commute (call-next-method)))
202                 (t
203                  (setf p2 p2-new)
204                  (push p-new p1s-new)))))
205       (list (make-instance 'composite-patch :patches p1s-new)
206             p2)))))
Note: See TracBrowser for help on using the repository browser.