;;; 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)))))