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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Wed Jul 12 14:17:37 2006
New Revision: 27

Modified:
   cl-darcs/trunk/merge.lisp
Log:
Further hack merge.lisp


Modified: cl-darcs/trunk/merge.lisp
==============================================================================
--- cl-darcs/trunk/merge.lisp	(original)
+++ cl-darcs/trunk/merge.lisp	Wed Jul 12 14:17:37 2006
@@ -16,11 +16,44 @@
 
 (in-package :darcs)
 
-(defun merge-patches (p1 p2)
-  "Create variant of P1 that can be applied after P2.
+(defgeneric merge-patches (p1 p2)
+  (:documentation "Create variant of P1 that can be applied after P2.
 P1 and P2 are parallel patches, i.e. they apply to the same tree.
 We now want to apply P2 and then P1 to that tree.  This function
-returns a version of P1 that satisfies that constraint."
+returns a version of P1 that satisfies that constraint."))
+
+;; named patches
+(defmethod merge-patches ((p1 named-patch) (p2 patch))
+  (make-instance 'named-patch
+		 :patchinfo (named-patch-patchinfo p1)
+		 :dependencies (named-patch-dependencies p1)
+		 :patch
+		 (merge-patches (named-patch-patch p1) p2)))
+(defmethod merge-patches ((p1 patch) (p2 named-patch))
+  (merge-patches p1 (named-patch-patch p2)))
+
+;; composite patches
+(defmethod merge-patches ((p1 composite-patch) (p2 composite-patch))
+  (make-instance 
+   'composite-patch
+   :patches
+   (let ((patches1 (patches p1))
+	 (patches2 (patches p2)))
+     (cond
+       ((null patches1)
+	nil)
+       (t
+	(labels ((mc (p1s p2s)
+		   (if (null p2s)
+		       p1s
+		       (mc (merge-patches-after-patch p1s (car p2s)) (cdr p2s)))))
+	  (mc patches1 patches2)))))))
+(defmethod merge-patches ((p1 composite-patch) (p2 patch))
+  (make-instance 'composite-patch :patches (merge-patches-after-patch (patches p1) p2)))
+(defmethod merge-patches ((p1 patch) (p2 composite-patch))
+  (merge-patch-after-patches p1 (patches p2)))
+
+(defmethod merge-patches ((p1 patch) (p2 patch))
   (or (elegant-merge p1 p2)
       (error "Couldn't merge ~A and ~A." p1 p2)))
 
@@ -36,3 +69,15 @@
 	(declare (ignore p2-old))
 	(when (equal-patch p1 p1-old t)
 	  p1-new)))))
+
+(defun merge-patch-after-patches (p1 p2s)
+  "Create a variant of P1 that can be applied after all of P2S.
+P1 is a patch; P2S is a list of patches."
+  (loop for p2s-left on p2s
+     do (setf p1 (merge-patches p1 (car p2s-left))))
+  p1)
+
+(defun merge-patches-after-patch (p1s p2)
+  "Create a variant of P1S that can be applied after P2.
+P1S is a list of patches; P2 is a patch."
+  (error "merge-patches-after-patch not yet implemented."))