;;; Copyright (C) 2006, 2007, 2008 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)

(defun diff-file (original modified &key filename)
  "Find changes between ORIGINAL and MODIFIED.
Return a list of HUNK-PATCHes.  Use FILENAME as their filename."
  (when original (setf original (make-upath original)))
  (when modified (setf modified (make-upath modified)))
  (let* ((original-lines
	  (if original
	      (with-open-stream (in (open-upath original :binary t))
		(loop for line = (read-binary-line in nil)
		   while line collect line))
	      :nonexistent))
	 (modified-lines
	  (if modified
	      (with-open-stream (in (open-upath modified :binary t))
		(loop for line = (read-binary-line in nil)
		   while line collect line))
	      :nonexistent))

	 ;; using equalp is safe (i.e. non-case-clobbering), as
	 ;; we use bytes instead of characters
	 (opcodes (when (and (listp original-lines)
			     (listp modified-lines))
		    (difflib:get-opcodes
		     (make-instance 'difflib:sequence-matcher
				    :a original-lines
				    :b modified-lines
				    :test-function #'equalp))))

	 patches)
    (cond
      ((and (eql original-lines :nonexistent)
	    (eql modified-lines :nonexistent))
       (error "Neither ~A nor ~A exist." original modified))
      ((eql original-lines :nonexistent)
       ;; Newly created file
       (list
	(make-instance 'hunk-patch
		       :filename filename
		       :line-number 1
		       :old ()
		       :new modified-lines)))
      ((eql modified-lines :nonexistent)
       ;; Removed file
       (list
	(make-instance 'hunk-patch
		       :filename filename
		       :line-number 1
		       :old original-lines
		       :new ())))
      (t
       ;; Possibly changed file
       (dolist (opcode opcodes)
	 (unless (eql (difflib:opcode-tag opcode) :equal)
	   (push 
	    (make-instance 'hunk-patch
			   :filename filename
			   :line-number (1+ (difflib:opcode-j1 opcode))
			   :old (subseq original-lines
					(difflib:opcode-i1 opcode)
					(difflib:opcode-i2 opcode))
			   :new (subseq modified-lines
					(difflib:opcode-j1 opcode)
					(difflib:opcode-j2 opcode)))
	    patches)))

       (nreverse patches)))))

(defun diff-binary-file (original modified &key filename)
  "Find changes between binary files ORIGINAL and MODIFIED.
ORIGINAL and MODIFIED can be NIL, meaning an empty file.
Use FILENAME as their filename.
Return a list of one BINARY-PATCH, or an empty list if
the files are equal."
  (let ((o-contents
	 (when original
	   (with-open-file (o original
			      :direction :input :if-does-not-exist :error
			      :element-type '(unsigned-byte 8))
	     (let ((data
		    (make-array (file-length o)
				:element-type '(unsigned-byte 8))))
	       (read-sequence data o)))))
	(m-contents
	 (when modified
	   (with-open-file (m modified
			      :direction :input :if-does-not-exist :error
			      :element-type '(unsigned-byte 8))
	     (let ((data 
		    (make-array (file-length m)
				:element-type '(unsigned-byte 8))))
	       (read-sequence data m)))))
	(empty (make-array 0 :element-type '(unsigned-byte 8))))
    (unless (equalp o-contents m-contents)
      (list
       (make-instance 'binary-patch
		      :filename filename
		      :oldhex (or o-contents empty)
		      :newhex (or m-contents empty))))))

(defun diff-repo (repo &optional original modified)
  "Find changes in REPO from pristine tree.
Return a list of patches.
ORIGINAL and MODIFIED specify directories to start from."
  (setf repo (truename (fad:pathname-as-directory repo)))
  (unless (and original modified)
    (setf modified repo)
    (setf original (upath-subdir repo '("_darcs" "pristine"))))

  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
			      :name :wild
			      :type :wild
			      :version :wild))
	 (repo-wild (merge-pathnames wild repo))
	 (pristine (upath-subdir repo '("_darcs" "pristine")))
	 (pristine-wild (merge-pathnames wild pristine))
	 (original-wild (merge-pathnames wild original))
	 (modified-wild (merge-pathnames wild modified))
	 (pending (or 
		   (read-pending repo)
		   (make-instance 'composite-patch :patches ())))
	 patches)
    ;; XXX: check if both directories exist

    ;; With fad:list-directory, we get absolute pathnames.  We make
    ;; them relative to the "root", so they can be compared.
    (flet ((original-to-repo-relative (p)
	     (pathname (enough-namestring p pristine)))
	   (modified-to-repo-relative (p)
	     (pathname (enough-namestring p repo))))
      ;; We list the files in the original tree.
      (let* ((files-in-original 
	      (mapcar #'original-to-repo-relative
		      (fad:list-directory original)))
	     pruned-pending)
	;; Create patch objects for newly added files and directories,
	;; and remember pending patches not creating new files or
	;; directories.
	(dolist (p (patches pending))
	  (typecase p
	    (add-file-patch
	     (let ((pathname-string (pathname-to-string (patch-filename p)))
		   (old-file (merge-pathnames (patch-filename p) pristine))
		   (new-file (merge-pathnames (patch-filename p) repo)))
	       (when (fad:file-exists-p old-file)
		 (error "Pending add of file ~A, but it already exists in the repository." pathname-string))
	       (setf patches 
		     (nconc patches
			    (list* p
				   (if (file-binary-p repo pathname-string)
				       (diff-binary-file nil new-file :filename pathname-string)
				       (diff-file nil new-file :filename pathname-string)))))))
	    (add-dir-patch
	     (let ((pathname-string (pathname-to-string (patch-directory p)))
		   (old-dir (merge-pathnames (patch-directory p) pristine)))
	       (when (fad:directory-exists-p old-dir)
		 (error "Pending add of directory ~A, but it already exists in the repository." pathname-string)))
	     (setf patches (nconc patches (list p))))
	    (t
	     (push p pruned-pending))))
	(setf (patches pending) (nreverse pruned-pending))

	;; Then for each original file, find out its fate.
	(dolist (file files-in-original)
	  ;; Was it touched by some "pending" patch?
	  (multiple-value-bind (touching new-name)
	      (find-touching pending file :forwards)
	    (if touching
		;; If yes, we want to record those patches, and remember the new name.
		(setf patches (nconc patches (patches touching)))
		;; If not, it has the same name as before.
		(setf new-name file))

	    (let ((original-pathname 
		   (merge-pathnames file pristine))
		  (modified-pathname
		   (merge-pathnames new-name repo))
		  (pathname-string
		   (pathname-to-string new-name)))
	      (cond
		((fad:directory-pathname-p file)
		 (setf patches (nconc patches
				      (diff-repo repo original-pathname modified-pathname))))

		((file-binary-p repo pathname-string)
		 (setf patches (nconc patches
				      (diff-binary-file original-pathname
							modified-pathname
							:filename pathname-string))))

		(t
		 (setf patches (nconc patches 
				      (diff-file original-pathname
						 modified-pathname
						 :filename pathname-string))))))))

	patches))))

(defun diff-repo-display (repo)
  "Find changes in REPO and print them to *STANDARD-OUTPUT*."
  (dolist (patch (diff-repo repo))
    (display-patch patch *standard-output*)))