;;; 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 read-patch-from-file (filename &key (compressed t))
  "Read a Darcs-style patch from FILENAME (a upath).
The file is expected to be compressed unless COMPRESSED is NIL."
  (restart-case
      (if compressed
	  ;; It's hard to switch between binary and text mode
	  ;; (element-type (unsigned-byte 8) and character, respectively).
	  ;; So decompress the file to a temporary file, and read it from
	  ;; there.
	  (with-temp-file-name tmp-file
	    (uncompress-file filename tmp-file)
	    (with-open-stream (uncompressed 
			       (make-instance 'unreadable-stream
					      :base-stream (open-upath (pathname tmp-file) :binary t)))
	      (read-patch uncompressed)))
	  ;; Reading an uncompressed file is easier, but they don't appear
	  ;; in the wild.
	  (with-open-stream (uncompressed (make-instance 'unreadable-stream
							 :base-stream (open-upath filename :binary t)))
	    (read-patch uncompressed)))
    (reread-patch ()
	:report (lambda (stream)
		  (format stream "Reread patch from ~A." filename))
	(read-patch-from-file filename :compressed compressed))))
	  
;; from PatchRead.lhs
(defun read-patch (stream)
  "Read a Darcs-style patch from STREAM."
  ;; Read a whitespace-separated token...
  (multiple-value-bind (token original) (read-token stream)
    (dformat "~&Read ~S" token)
    (cond
      ((string= token "{")
       ;; composite patch
       (dformat "~&Reading composite patch")
       (make-instance 
	'composite-patch
	:patches (loop for patch = (read-patch stream)
		    while patch collect patch)))
      ((string= token "}")
       ;; end of composite patch
       nil)

      ((string= token "(")
       ;; split patch
       (make-instance 
	'split-patch
	:patches (loop for patch = (read-patch stream)
		    while patch collect patch)))
      ((string= token ")")
       ;; end of split patch
       nil)

      ((string= token "hunk")
       (read-hunk stream))

      ((string= token "replace")
       (read-token-replace stream))

      ((string= token "binary")
       (read-binary stream))

      ((string= token "addfile")
       (read-add-file stream))

      ((string= token "adddir")
       (read-add-dir stream))

      ((string= token "rmfile")
       (read-rm-file stream))

      ((string= token "rmdir")
       (read-rm-dir stream))

      ((string= token "move")
       (read-move stream))

      ((string= token "changepref")
       (read-change-pref stream))

      ((string= token "merger")
       (read-merger stream nil))

      ((string= token "regrem")
       (read-merger stream t))

      ((string= token "conflict")
       (read-conflict stream))

      ((string= token "tcilfnoc")
       (read-tcilfnoc stream))

      ((char= (aref token 0) #\[)
       ;; named patch.  there is no space after [, so unread the
       ;; token.
       (unread-sequence stream original)
       (read-named stream))

      (t
       (error "Unknown patch token ~S." token)))))

(defun read-hunk (stream)
  "Read a hunk patch from STREAM."
  ;; Read file name and line number...
  (let ((filename (read-token stream))
	(line-number (parse-integer (read-token stream)))
	old new)
    (dformat "~&Reading hunk for ~A" filename)
    ;; Skip context (lines starting with space)
    (loop for line = (read-binary-line stream)
       while (= (elt line 0) 32)
       finally (unread-line stream line))
    ;; Collect 'old' lines (starting with '-')
    (setf old
	  (loop for line = (read-binary-line stream nil)
	     while (and line (= (elt line 0) (char-code #\-)))
	     collect (subseq line 1)
	     do (dformat ".")
	     finally (when line (unread-line stream line))))
    ;; Collect 'new' lines (starting with '+')
    (setf new
	  (loop for line = (read-binary-line stream nil)
	     while (and line (= (elt line 0) (char-code #\+)))
	     collect (subseq line 1)
	     do (dformat ".")
	     finally (when line (unread-line stream line))))
    (make-instance 
     'hunk-patch :filename (sanitize-filename filename)
     :line-number line-number
     :old old :new new)))

(defun read-named (stream)
  "Read a named patch."
  ;; A named patch starts with a patchinfo.
  (let ((patchinfo (read-patchinfo stream))
	dependencies)
    (dformat "~&Reading named patch: ~A" patchinfo)
    ;; If the next token is '<', it has a list of dependencies.
    (multiple-value-bind (next-token maybe-unread-this) (read-token stream)
      (if (string= next-token "<")
	  ;; The list of dependencies ends with '>'.
	  (loop for (next-token original) =
	       (multiple-value-list (read-token stream))
	       until (string= next-token ">")
	       do (unread-sequence stream original)
	       (push (read-patchinfo stream) dependencies)
	       finally (setf dependencies (nreverse dependencies)))
	  ;; It wasn't '<', so unread it.
	  (unread-sequence stream maybe-unread-this)))
    (dformat "~&Got dependencies: ~A" dependencies)

    ;; And then comes the patch itself.
    (let ((patch (read-patch stream)))
      (make-instance 
       'named-patch :patchinfo patchinfo 
       :dependencies dependencies
       :patch patch))))

(defun read-binary (stream)
  "Read a binary patch."
  ;; A binary patch consists of the token "oldhex", the old contents,
  ;; "newhex", and the new contents.  Contents is in lines starting
  ;; with '*', hex-encoded.
  (flet ((read-binary-data ()
	   (let* ((bytes (make-array 1024 :element-type '(unsigned-byte 8)
				     :adjustable t :fill-pointer 0)))
	     (loop for line = (read-binary-line stream nil)
		while (and line (= (elt line 0) (char-code #\*)))
		do (loop for i from 1 below (length line) by 2
		      do (vector-push-extend 
			  (+ (* 16 (hex-to-number (elt line i)))
			     (hex-to-number (elt line (1+ i))))
			  bytes))
		do (dformat ".")
		finally (when line (unread-line stream line)))
	     bytes)))
    (let ((filename (read-token stream)))
      (dformat "~&Reading binary patch for ~A" filename)
      (let ((oldhex (progn 

		      (read-token stream)
		      (read-binary-data)))
	    (newhex (progn (read-token stream) (read-binary-data))))
	(make-instance 'binary-patch
		       :filename (sanitize-filename filename)
		       :oldhex oldhex
		       :newhex newhex)))))
    
(defun read-add-file (stream)
  "Read an 'add file' patch."
  (make-instance 'add-file-patch
		 :filename (sanitize-filename (read-token stream))))

(defun read-rm-file (stream)
  "Read a 'remove file' patch."
  (make-instance 'rm-file-patch 
		 :filename (sanitize-filename (read-token stream))))

(defun read-add-dir (stream)
  "Read an 'add directory' patch."
  (make-instance 'add-dir-patch 
		 :directory (sanitize-filename (read-token stream)
					       :type :directory)))

(defun read-rm-dir (stream)
  "Read a 'remove directory' patch."
  (make-instance 'rm-dir-patch
		 :directory (sanitize-filename (read-token stream)
					       :type :directory)))

(defun read-change-pref (stream)
  "Read a 'change preferences' patch."
  ;; Read the name. (assume that read-token gobbles the newline)
  (let ((name (read-token stream))
	;; Read old value.
	(from (bytes-to-string (read-binary-line stream)))
	;; Read new value.
	(to (bytes-to-string (read-binary-line stream))))
    (make-instance 'change-pref-patch :pref name :from from :to to)))

(defun read-move (stream)
  "Read a 'move file' patch."
  (let ((from (sanitize-filename (read-token stream)))
	(to (sanitize-filename (read-token stream))))
    (make-instance 'move-patch :from from :to to)))

(defun read-merger (stream inverted)
  "Read a merger patch."
  ;; XXX: this needs much more work
  (let ((version (read-token stream)))
    (read-token stream)			; #\(
    (let ((p1 (read-patch stream))
	  (p2 (read-patch stream)))
      (read-token stream)		; #\)
      (let ((merger (make-instance 'merger-patch
				   :version version :first p1 :second p2
				   :inverted inverted)))
	(let* ((is-merger1 (typep p1 'merger-patch))
	       (is-merger2 (typep p2 'merger-patch)))
	  (setf (merger-undo merger)
		(cond
		  ((and is-merger1 is-merger2)
		   (make-instance 'composite-patch
				  :patches (mapcar #'invert-patch
						   (cdr (unwind merger)))))
		  ((and (not is-merger1) (not is-merger2))
		   (invert-patch p1))
		  ((and is-merger1 (not is-merger2))
		   (make-instance 'composite-patch)) ;empty patch
		  ((and (not is-merger1) is-merger2)
		   (make-instance 'composite-patch
				  :patches (list (invert-patch p1)
						 (merger-undo p2)))))))
	merger))))

(defun read-token-replace (stream)
  "Read a token replacing patch."
  (let ((filename (sanitize-filename (read-token stream)))
	(token-regexp (read-token stream))
	(old-token (read-token stream))
	(new-token (read-token stream)))
    (make-instance 'token-replace-patch
		   :filename filename
		   :regexp (subseq token-regexp 1 (1- (length token-regexp)))
		   :old-token old-token
		   :new-token new-token)))