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

(defun diff-file (original modified &key filename)
  "Find changes between ORIGINAL and MODIFIED.
Return a list of HUNK-PATCHes.  Use FILENAME as their filename."
  (setf original (make-upath original))
  (setf modified (make-upath modified))
  (let* ((original-lines
	  (if (fad:file-exists-p 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 (fad:file-exists-p 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
       ;; XXX: should we automatically add such files?
       (list
	(make-instance 'add-file-patch
		       :filename filename)
	(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 ())
	(make-instance 'rm-file-patch
		       :filename filename)))
      (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.
Use FILENAME as their filename.
Return a list of one BINARY-PATCH, or an empty list if
the files are equal."
  (with-open-file (o original
		      :direction :input :if-does-not-exist :error
		      :element-type '(unsigned-byte 8))
    (with-open-file (m modified
		       :direction :input :if-does-not-exist :error
		       :element-type '(unsigned-byte 8))
      (let ((o-contents
	     (make-array (file-length o)
			 :element-type '(unsigned-byte 8)))
	    (m-contents
	     (make-array (file-length m)
			 :element-type '(unsigned-byte 8))))
	(read-sequence o-contents o)
	(read-sequence m-contents m)
	(unless (equalp o-contents m-contents)
	  (list
	   (make-instance 'binary-patch
			  :filename filename
			  :oldhex o-contents
			  :newhex m-contents)))))))

(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 (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))
	 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 current directory, both in the
      ;; original and the modified tree, and get the union.
      (let* ((files-in-original 
	      (mapcar #'original-to-repo-relative
		      (fad:list-directory original)))
	     (files-in-modified 
	      (mapcar #'modified-to-repo-relative
		      (fad:list-directory modified)))
	     (files (nunion files-in-original files-in-modified
			    :test #'equal)))
	;; Then we iterate through the union.
	(dolist (file files)
	  (let ((original-pathname 
		 (merge-pathnames file pristine))
		(modified-pathname
		 (merge-pathnames file repo))
		(pathname-string
		 (pathname-to-string file)))
	    (unless (file-boring-p repo pathname-string)
	      (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*)))