[Cl-darcs-cvs] r6 - cl-darcs/trunk

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Sat Jun 10 11:50:26 2006
New Revision: 6

Added:
   cl-darcs/trunk/commute.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Start hacking commutation.


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Sat Jun 10 11:50:26 2006
@@ -37,6 +37,7 @@
    (:file "apply-patch" :depends-on ("patch-core"))
    (:file "invert-patch" :depends-on ("patch-core"))
    (:file "touching" :depends-on ("patch-core"))
+   (:file "commute" :depends-on ("patch-core"))
 
    ;; Franz' inflate implementation
    #-allegro (:file "ifstar")

Added: cl-darcs/trunk/commute.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/commute.lisp	Sat Jun 10 11:50:26 2006
@@ -0,0 +1,58 @@
+(in-package :darcs)
+
+(defgeneric commute-patches (p2 p1)
+  (:documentation "Attempt to commute the patches P2 and P1.
+Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then
+P1-NEW has the same effect as applying P1 and then P2.
+If commutations fails, return nil."))
+
+(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch))
+  "If P1 and P2 change different files, commutation is trivial."
+  (let ((p1-file (patch-filename p1))
+	(p2-file (patch-filename p2)))
+    (if (not (equal p1-file p2-file))
+	(list p1 p2)
+	(call-next-method))))
+
+(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch))
+  "Attempt to commute the two hunk patches P1 and P2."
+  (assert (equal (patch-filename p1) (patch-filename p2)))
+  (with-accessors ((line1 hunk-line-number)
+		   (old1 hunk-old-lines)
+		   (new1 hunk-new-lines)) p1
+    (with-accessors ((line2 hunk-line-number)
+		      (old2 hunk-old-lines)
+		      (new2 hunk-new-lines)) p2
+      (cond
+	((< (+ line1 (length new1)) line2)
+	 ;; The first patch changes text before the second patch.
+	 (list p1
+	       (make-instance 'hunk-patch :filename (patch-filename p2)
+			      :line-number (+ line2 (- (length new1)) (length old1))
+			      :old old2 :new new2)))
+	((< (+ line2 (length old2) line1))
+	 ;; The second patch changes text before the first patch.
+	 (list (make-instance 'hunk-patch :filename (patch-filename p1)
+			      :line-number (+ line1 (length new2) (- (length old2)))
+			      :old old1 :new new1)
+	       p2))
+	((and (= (+ line1 (length new1)) line2)
+	      (notany #'zerop
+		      (mapcar #'length (list old1 old2 new1 new2))))
+	 ;; The first patch goes exactly until the beginning of the second patch.
+	 (list p1
+	       (make-instance 'hunk-patch :filename (patch-filename p2)
+			      :line-number (+ line2 (- (length new1)) (length old1))
+			      :old old2 :new new2)))
+	((and (= (+ line2 (length old2)) line1)
+	      (notany #'zerop
+		      (mapcar #'length (list old1 old2 new1 new2))))
+	 ;; The second patch goes exactly until the beginning of the first patch.
+	 (list (make-instance 'hunk-patch :filename (patch-filename p1)
+			      :line-number (+ line1 (length new2) (- (length old2)))
+			      :old old1 :new new1)
+	       p2))
+	(t
+	 ;; In other cases, there is no failsafe way to commute the
+	 ;; patches, so we give up.
+	 nil)))))