source: cl-darcs/trunk/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 ((p2 named-patch) (p1 patch))
  "Commute a named patch and another patch."
  (destructuring-bind (&optional p1-new p2-new)
      (commute (named-patch-patch p2) p1)
    (if p1-new
        (list p1-new
              (make-instance 'named-patch
                             :patchinfo (named-patch-patchinfo p2)
                             :dependencies (named-patch-dependencies p2)
                             :patch p2-new))
        (call-next-method))))

(defmethod commute ((p2 patch) (p1 named-patch))
  "Commute a patch with a named patch."
  (destructuring-bind (&optional p1-new p2-new)
      (commute p2 (named-patch-patch p1))
    (if p1-new
        (list (make-instance 'named-patch
                             :patchinfo (named-patch-patchinfo p1)
                             :dependencies (named-patch-dependencies p1)
                             :patch p1-new)
              p2-new)
        (call-next-method))))

(defmethod commute ((p2 move-patch) (p1 file-patch))
  "Commute a move patch with a file patch."
  (let ((patched-file (patch-filename p1))
        (moved-from (patch-move-from p2))
        (moved-to (patch-move-to p2)))
    (cond
      ;; File was patched and then moved
      ((equal patched-file moved-from)
       (let ((p1-new (copy-patch p1)))
         (setf (patch-filename p1-new) moved-to)
         (list p1-new p2)))
      ;; Another file moved on top of original file
      ((equal patched-file moved-to)
       (warn "Collision when commuting ~A and ~A." p2 p1)
       nil)
      ;; Patches touch different files
      (t
       (list p1 p2)))))

(defmethod commute ((p2 file-patch) (p1 move-patch))
  "Commute a file patch with a move patch."
  (let ((moved-from (patch-move-from p1))
        (moved-to (patch-move-to p1))
        (patched-file (patch-filename p2)))
    (cond
      ;; File was moved and then patched
      ((equal moved-to patched-file)
       (let ((p2-new (copy-patch p2)))
         (setf (patch-filename p2-new) moved-from)
         (list p1 p2-new)))
      ;; File was moved before being patched
      ((equal moved-from patched-file)
       (warn "Collision when commuting ~A and ~A." p2 p1)
       nil)
      ;; Patches touch different files
      (t
       (list p1 p2)))))

(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 :around ((p2 file-patch) (p1 merger-patch))
  "If P1 touches only one file, and P2 touches another, commutation is trivial."
  (let ((p1-first (merger-first p1))
        (p1-second (merger-second p1))
        (p2-file (patch-filename p2)))
    (if (and (typep p1-first 'file-patch)
             (typep p1-second 'file-patch)
             (equal (patch-filename p1-first) (patch-filename p1-second))
             (not (equal (patch-filename p1-first) p2-file)))
        (list p1 p2)
        (call-next-method))))

(defmethod commute :around ((p2 merger-patch) (p1 file-patch))
  "If P2 touches only one file, and P1 touches another, commutation is trivial."
  (let ((p1-file (patch-filename p1))
        (p2-first (merger-first p2))
        (p2-second (merger-second p2)))
    (if (and (typep p2-first 'file-patch)
             (typep p2-second 'file-patch)
             (equal (patch-filename p2-first) (patch-filename p2-second))
             (not (equal (patch-filename p2-first) p1-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)))))