Author: mhenoch Date: Sun Jun 11 11:32:20 2006 New Revision: 8 Added: cl-darcs/trunk/equal.lisp Log: Forgot to add equal.lisp. Added: cl-darcs/trunk/equal.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/equal.lisp Sun Jun 11 11:32:20 2006 @@ -0,0 +1,68 @@ +(in-package :darcs) + +(defun equal-list (predicate a b) + "Return true if lists A and B are equal according to PREDICATE. +That is, they have the same length, and for each corresponding +pair of elements PREDICATE returns true." + (and (= (length a) (length b)) + (catch 'not-equal + (mapc (lambda (x y) + (unless (funcall predicate x y) + (throw 'not-equal nil))) + a b) + t))) + +(defgeneric equal-patch (a b &optional really) + (:documentation "Return true if patches A and B are equal. +If REALLY is false, consider named patches with the same name +to be equal, regardless of content.") + (:method-combination and :most-specific-last)) + +(defmethod equal-patch :around ((a patch) (b patch) &optional really) + "If there are no methods for comparing A and B, they are not equal." + (declare (ignore really)) + (if (next-method-p) + (call-next-method) + nil)) + +(defmethod equal-patch and ((a file-patch) (b file-patch) &optional really) + "Compare two file patches. +Two file patches can be equal only if they are of the same type and +patch the same file." + (declare (ignore really)) + (and (eq (class-of a) (class-of b)) + (equal (patch-filename a) (patch-filename b)))) + +(defmethod equal-patch and ((a hunk-patch) (b hunk-patch) &optional really) + "Compare two hunk patches." + (declare (ignore really)) + (flet ((compare (accessor) + ;; We use equalp, to make it descend into the vaguely + ;; string-like arrays. + (equalp (funcall accessor a) (funcall accessor b)))) + (and (compare #'hunk-line-number) + (compare #'hunk-old-lines) + (compare #'hunk-new-lines)))) + +(defmethod equal-patch and ((a binary-patch) (b binary-patch) &optional really) + "Compare two binary patches." + (declare (ignore really)) + (and (equalp (binary-oldhex a) (binary-oldhex b)) + (equalp (binary-newhex a) (binary-newhex b)))) + +(defmethod equal-patch and ((a token-replace-patch) (b token-replace-patch) &optional really) + "Compare two token replacing patches." + (declare (ignore really)) + (flet ((compare (accessor) + ;; Here we use string=. + (string= (funcall accessor a) (funcall accessor b)))) + (and (compare #'token-regexp) + (compare #'old-token) + (compare #'new-token)))) + +(defmethod equal-patch and ((a merger-patch) (b merger-patch) &optional really) + "Compare two merger patches." + (and (string= (merger-version a) (merger-version b)) + (eql (merger-inverted a) (merger-inverted b)) + (equal-patch (merger-first a) (merger-first b) really) + (equal-patch (merger-second a) (merger-second b) really)))