;; Copyright (c) Tony Sidaway <tonysidaway@gmail.com>
;; 
;; Permission is hereby granted, free of charge, to any person obtaining a copy of this
;; software and associated documentation files (the "Software"), to deal in the Software
;; without restriction, including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to the following
;; conditions:
;; 
;; The above copyright notice and this permission notice shall be included in all copies
;; or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
;; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
;; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;

(module patch
	
	(make-patch apply-patch reverse-patch)

	(import scheme chicken) 
	(require-library regex)
	 (import extras posix regex)

;; 
;;@function (make-patch)
;;
;; Reads a GNU diffutils diff file on (current-input-port) and turns it
;; into a patch definition on (current-output-port).


(define (make-patch)
  (let* ((match-string
	 (regexp "^([1-9][0-9]*)(,?)([1-9][0-9]*)?([dca])([1-9][0-9]*)(,?)([1-9][0-9]*)?"))
	(lookahead-buffer '())
	(lookahead-line (lambda ()
	    (if (null? lookahead-buffer)
		(read-line)
		(let ((ln (car lookahead-buffer)))
		  (set! lookahead-buffer (cdr lookahead-buffer))
		  ln))))
	(putback-line (lambda (ln)
	    (set! lookahead-buffer (append lookahead-buffer (list ln))))))
    (reverse
     (let command-loop ((ln (lookahead-line)) (patch '()))
       (if (eof-object? ln)
	   patch
	   (begin
	     (let ((match (string-match match-string ln)))
	       (or match (error format "No match to a diff command on this line: ~S" ln))
	       (set! match (cdr match))
	       (let ((start-line (list-ref match 0))
		     (finish-line (list-ref match 2))
		     (action (string->symbol (list-ref match 3)))
		     (new-start-line (list-ref match 4))
		     (new-finish-line (list-ref match 6))
		     (lines-to-delete '())
		     (lines-to-insert '()))
		 (if (or (eq? action 'c) (eq? action 'd))
		     (begin
		       (set! lines-to-delete
			     (reverse
			      (let delete-loop ((ln (lookahead-line)) (lst '()))
				(cond
				 ((eof-object? ln) lst)
				 ((string=? (substring ln 0 1) "<")
				  (delete-loop (lookahead-line) (cons (substring ln 2) lst)))
				 (else
				  (if (eq? action 'd)
				      (putback-line ln))
				  lst)))))))
		 (if (or (eq? action 'c) (eq? action 'a))
		     (begin
		       (set! lines-to-insert
			     (reverse
			      (let insert-loop ((ln (lookahead-line)) (lst '()))
				(cond
				 ((eof-object? ln) lst)
				 ((string=? (substring ln 0 1) ">")
				  (insert-loop (lookahead-line) (cons (substring ln 2) lst)))
				 (else
				  (putback-line ln)
				  lst)))))))
		 (command-loop (lookahead-line)
			       (cons (list
				      action
				      (and start-line (string->number start-line))
				      (and finish-line (string->number finish-line))
				      (and new-start-line (string->number new-start-line))
				      (and new-finish-line (string->number new-finish-line))
				      lines-to-delete
				      lines-to-insert)
				     patch))))))))))
;; 
;;@function (apply-patch patch-definition)
;;
;; Applies a patch to a text stream on current-input-port and writes it to
;; current-output-port.
(define (apply-patch patch-definition)
  (let ((line 0))
    (for-each
     (lambda (x)
       (let ((action (list-ref x 0))
	     (start-line (list-ref x 1))
	     (finish-line (list-ref x 2))
	     (new-start-line (list-ref x 3))
	     (new-finish-line (list-ref x 4))
	     (lines-to-delete (list-ref x 5))
	     (lines-to-insert (list-ref x 6)))
	 (case action
	   ((a)
	    (let read-loop ((ln (read-line)))
	      (set! line (+ line 1))
	      (if (= (+ 1 start-line) line)
		  (begin
		    (let append-loop ((ins lines-to-insert))
		      (if (not (null? ins))
			  (begin
			    (write-line (car ins))
			    (append-loop (cdr ins)))))
		    (write-line ln))
		  (begin (write-line ln)
			 (read-loop (read-line))))))
	   ((d)
	    (let read-loop ((ln (read-line)))
	      (set! line (+ line 1))
	      (if (= start-line line)
		  (let delete-loop ((del lines-to-delete) (ln ln))
		    (if (not (null? del))
			(begin
			  (if (not (equal? (car del) ln))
			      (error
			       (format
				"Patch(d) failed, line ~S (line to be deleted does not match), to be deleted ~S, actually there: ~S"
				line (car del) ln)))
			  (set! line (+ line 1))
			  (delete-loop (cdr del) (read-line)))
			(begin
			  (write-line ln))))
		  (begin
		    (write-line ln)
		    (read-loop (read-line))))))
	   ((c)
	    (let read-loop ((ln (read-line)))
	      (set! line (+ line 1))
	      (if (= start-line line)
		  (begin
		    (let append-loop ((ins lines-to-insert))
		      (if (not (null? ins))
			  (begin
			    (write-line (car ins))
			    (append-loop (cdr ins)))))
		    (let delete-loop ((del lines-to-delete) (ln ln))
		      (if (not (null? del))
			  (begin
			    (if (not (equal? (car del) ln))
				(error
				 (format
				  "Patch(c) failed line ~S (line to be deleted does not match)"
				  line)))
			    (set! line (+ line 1))
			    (delete-loop (cdr del) (read-line)))
			  (if (not (eof-object? ln))
			      (write-line ln)))))
		  (begin
		    (write-line ln)
		    (read-loop (read-line)))))))))
     patch-definition))
  (let loop ((ln (read-line)))
    (if (not (eof-object? ln))
	(begin
	  (write-line ln)
	  (loop (read-line))))))
;; 
;;@function (reverse-patch patch-definition)
;;
;; Reverses a patch definition, producing a new patch that, when applied to
;; the result of applying the original patch, will reproduce the original
;; input file.
(define (reverse-patch patch-definition)
  (map
   (lambda (x)
     (let ((action (list-ref x 0))
	   (start-line (list-ref x 1))
	   (finish-line (list-ref x 2))
	   (new-start-line (list-ref x 3))
	   (new-finish-line (list-ref x 4))
	   (lines-to-delete (list-ref x 5))
	   (lines-to-insert (list-ref x 6)))
       (case action
	 ((a)
	  (list 'd new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete))
	 ((c)
	  (list 'c new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete))
	 ((d)
	  (list 'a new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete)))))
   patch-definition))

)