source: cl-darcs/trunk/equal.lisp

Last change on this file was 174, checked in by Magnus Henoch, 14 years ago

EQUAL-PATCH: add method for comparing two DIRECTORY-PATCHes

File size: 3.7 KB
Line 
1;;; Copyright (C) 2006, 2008 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(defun equal-list (predicate a b)
20  "Return true if lists A and B are equal according to PREDICATE.
21That is, they have the same length, and for each corresponding
22pair of elements PREDICATE returns true."
23  (and (= (length a) (length b))
24       (catch 'not-equal
25         (mapc (lambda (x y)
26                 (unless (funcall predicate x y)
27                   (throw 'not-equal nil)))
28               a b)
29         t)))
30
31(defgeneric equal-patch (a b &optional really)
32  (:documentation "Return true if patches A and B are equal.
33If REALLY is false, consider named patches with the same name
34to be equal, regardless of content."))
35
36(defmethod equal-patch ((a patch) (b patch) &optional really)
37  "If there are no methods for comparing A and B, they are not equal."
38  (declare (ignore really))
39  nil)
40
41(defmethod equal-patch :around ((a file-patch) (b file-patch) &optional really)
42  "Compare two file patches.
43Two file patches can be equal only if they are of the same type and
44patch the same file."
45  (declare (ignore really))
46  (when (and (eq (class-of a) (class-of b))
47             (equal (patch-filename a) (patch-filename b)))
48    (call-next-method)))
49
50(defmethod equal-patch ((a file-patch) (b file-patch) &optional really)
51  "Compare two simple file patches.
52If the :around method proceeds to call us, and there is no more specific
53method, then we have two ADD-FILE-PATCHes or RM-FILE-PATCHES, which are
54equal."
55  (declare (ignore really))
56  t)
57
58(defmethod equal-patch ((a hunk-patch) (b hunk-patch) &optional really)
59  "Compare two hunk patches."
60  (declare (ignore really))
61  (flet ((compare (accessor)
62           ;; We use equalp, to make it descend into the vaguely
63           ;; string-like arrays.
64           (equalp (funcall accessor a) (funcall accessor b))))
65    (and (compare #'hunk-line-number)
66         (compare #'hunk-old-lines)
67         (compare #'hunk-new-lines))))
68
69(defmethod equal-patch ((a directory-patch) (b directory-patch) &optional really)
70  "Compare two directory add/remove patches."
71  (declare (ignore really))
72  (and (eq (type-of a) (type-of b))
73       (equal (patch-directory a) (patch-directory b))))
74
75(defmethod equal-patch ((a token-replace-patch) (b token-replace-patch) &optional really)
76  "Compare two token replacing patches."
77  (declare (ignore really))
78  (flet ((compare (accessor)
79           ;; Here we use string=.
80           (string= (funcall accessor a) (funcall accessor b))))
81    (and (compare #'token-regexp) 
82         (compare #'old-token)
83         (compare #'new-token))))
84
85(defmethod equal-patch ((a binary-patch) (b binary-patch) &optional really)
86  "Compare two binary patches."
87  (declare (ignore really))
88  (and (equalp (binary-oldhex a) (binary-oldhex b))
89       (equalp (binary-newhex a) (binary-newhex b))))
90
91(defmethod equal-patch ((a merger-patch) (b merger-patch) &optional really)
92  "Compare two merger patches."
93  (and (string= (merger-version a) (merger-version b))
94       (eql (merger-inverted a) (merger-inverted b))
95       (equal-patch (merger-first a) (merger-first b) really)
96       (equal-patch (merger-second a) (merger-second b) really)))
Note: See TracBrowser for help on using the repository browser.