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. |
---|
21 | That is, they have the same length, and for each corresponding |
---|
22 | pair 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. |
---|
33 | If REALLY is false, consider named patches with the same name |
---|
34 | to 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. |
---|
43 | Two file patches can be equal only if they are of the same type and |
---|
44 | patch 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. |
---|
52 | If the :around method proceeds to call us, and there is no more specific |
---|
53 | method, then we have two ADD-FILE-PATCHes or RM-FILE-PATCHES, which are |
---|
54 | equal." |
---|
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))) |
---|