source: cl-darcs/tags/0.1.0/commute.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(defgeneric commute (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 ((p2 patch) (p1 patch))
  "Default method prints a warning and returns nil."
  (warn "No method defined for commuting ~A and ~A." p2 p1)
  nil)

(defmethod commute :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 ((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)))))

(defmethod commute ((p2 composite-patch) (p1 patch))
  (cond
    ;; Simple case first...
    ((null (patches p2))
     (list p1 p2))
    (t
     ;; Now, p1 was committed before all the patches in p2, and we
     ;; want it to come after.
     (let ((p2s (patches p2))
           p2s-new)
       (loop for p in p2s
          do (destructuring-bind (&optional p1-new p-new)
                 (commute p p1)
               (cond
                 ((null p1-new)
                  (return-from commute (call-next-method)))
                 (t
                  (setf p1 p1-new)
                  (push p-new p2s-new)))))
       (list p1 (make-instance 'composite-patch :patches (nreverse p2s-new)))))))
(defmethod commute ((p2 patch) (p1 composite-patch))
  (cond
    ((null (patches p1))
     (list p1 p2))
    (t
     ;; p2 was committed after all the patches in p1.  Thus we start
     ;; backwards in p1, commuting p2 with each of the patches.
     (let ((p1s (reverse (patches p1)))
           p1s-new)
       (loop for p in p1s
          do (destructuring-bind (&optional p-new p2-new)
                 (commute p2 p)
               (cond
                 ((null p-new)
                  (return-from commute (call-next-method)))
                 (t
                  (setf p2 p2-new)
                  (push p-new p1s-new)))))
       (list (make-instance 'composite-patch :patches p1s-new)
             p2)))))