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

(defclass unreadable-stream
    (trivial-gray-streams:trivial-gray-stream-mixin
     trivial-gray-streams:fundamental-binary-input-stream)
  ((stream
    :initarg :base-stream
    :documentation "The stream wrapped by this unreadable-stream.")
   (haskellish-lines
    :initarg :haskellish-lines :initform nil
    :documentation "If true, read lines as Haskell would read them.
That is, a line is a (possibly empty) list of characters delimited
by either newlines or end-of-file.  In particular, if the file ends
with a newline, it has an extra empty last line in Haskell mode.

This flag affects only `read-binary-line'.")
   
   (buffer :initform nil)
   (at-end-of-file :initform nil))
  (:documentation "A wrapper for a binary input stream.
Unlimited \"unreading\" is allowed through UNREAD-BYTE and
UNREAD-SEQUENCE."))

(defmethod trivial-gray-streams:stream-read-byte
    ((stream unreadable-stream))
  (with-slots ((base-stream stream) buffer) stream
    (let ((from-buffer (car buffer)))
      ;; Has something been unread?
      (cond
	;; No, nothing.
	((null from-buffer)
	 (read-byte base-stream nil :eof))
	;; A single byte.
	((numberp from-buffer)
	 (pop buffer)
	 from-buffer)
	;; A sequence.
	((listp from-buffer)
	 ;; Get the byte from the indicated start index.
	 (prog1
	     (elt (third from-buffer) (first from-buffer))
	   (incf (first from-buffer))
	   ;; If the sequence is exhausted, drop it.
	   (when (= (first from-buffer) (second from-buffer))
	     ;; Wait - is there a terminating newline?
	     (if (eql (fourth from-buffer) :line)
		 ;; Preserve it.
		 (setf (car buffer) 10)
		 (pop buffer)))))
	;; Something else.
	(t
	 (error "Invalid buffer entry ~S." from-buffer))))))

(defmethod trivial-gray-streams:stream-read-sequence
    ((stream unreadable-stream)
     sequence start end &key)
  (with-slots ((base-stream stream) buffer) stream
    (unless start (setf start 0))
    (unless end (setf end (length sequence)))
    
    ;; First, see if we can use the buffer.
    (loop while (and (< start end) buffer)
       do (let ((from-buffer (car buffer)))
	    ;; What do we find in the buffer?
	    (cond
	      ;; A single byte.
	      ((numberp from-buffer)
	       (setf (elt sequence start) from-buffer)
	       (incf start)
	       (pop buffer))
	      ;; A sequence.
	      ((listp from-buffer)
	       (let* ((has-newline (eql (fourth from-buffer) :line))
		      (len (min (- end start) 
				(- (second from-buffer) (first from-buffer)))))
		 (setf (subseq sequence start (+ start len))
		       (subseq (third from-buffer) (+ (first from-buffer) len)))
		 (incf start len)
		 (incf (first from-buffer) len)
		 ;; If the sequence is exhausted, drop it.
		 (when (= (first from-buffer) (second from-buffer))
		   (if (not has-newline)
		       (pop buffer)
		       ;; Is there space for the newline?
		       (if (< start end)
			   ;; Yes - line is entirely consumed.
			   (progn
			     (setf (elt sequence start) 10)
			     (incf start)
			     (pop buffer))
			   ;; No - preserve the newline.
			   (setf (car buffer) 10)))))))))

    ;; If we need more data, get it from the base stream.
    (if (< start end)
	(read-sequence sequence base-stream :start start :end end)
	;; Otherwise, report that the sequence is full.
	end)))

(defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
  "If stream is in \"Haskell mode\", treat newlines at end of file accordingly."
  (if (not (slot-value stream 'haskellish-lines))
      (call-next-method)
      ;; The delimiter between lines is a newline or end-of-file.
      ;; Thus, if we have just returned the last newline-terminated
      ;; line and stand before EOF, we can't just return EOF since
      ;; there is an zero-length line between the last newline and the
      ;; EOF.
      (if (null (slot-value stream 'at-end-of-file))
	  ;; So we haven't read EOF yet.  That means that we can
	  ;; return at least one more line (though it may be
	  ;; zero-length).
	  (multiple-value-bind (line delim)
	      (read-until 10 stream nil :eof)
	    ;; If EOF follows after that line, note it.
	    (when (eql delim :eof)
	      (setf (slot-value stream 'at-end-of-file) t))
	    line)
	  ;; If we have already set the EOF flag, act accordingly.
	  (if eof-error-p
	      (error 'end-of-file :stream stream)
	      eof-value))))

;; This method is meant as an optimization, but it actually makes
;; things slower.  Need to investigate why...
#+nil 
(defmethod read-binary-line :around ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
  "If possible, return a recently unread line."
  ;; If a line has been unread, we just return it.
  (with-slots (buffer) stream
    (let ((buffer-entry (car buffer)))
      (if (and (listp buffer-entry) (eql (fourth buffer-entry) :line))
	  ;; Yes!
	  (let ((start (first buffer-entry))
		(end (second buffer-entry))
		(sequence (third buffer-entry)))
	    (pop buffer)
	    ;; Simple case: it's a vector, and we haven't begun nibbling at it.
	    (if (and (vectorp sequence) (= start 0))
		sequence
		;; Otherwise, make a new vector.
		(make-array (- end start) :element-type '(unsigned-byte 8)
			    :initial-contents (subseq sequence start))))
	  ;; Oh well...
	  (call-next-method)))))

(defmethod close ((stream unreadable-stream) &key abort)
  "Close the underlying stream of STREAM."
  (close (slot-value stream 'stream) :abort abort)
  (call-next-method))

(defmethod unread-byte ((stream unreadable-stream) byte)
  "Store BYTE at the head of the unread buffer."
  (setf (slot-value stream 'at-end-of-file) nil)
  (push byte (slot-value stream 'buffer)))

(defmethod unread-sequence ((stream unreadable-stream) sequence)
  "Store SEQUENCE at the head of the unread buffer.
It is assumed that SEQUENCE will not be modified."
  (setf (slot-value stream 'at-end-of-file) nil)
  (with-slots (buffer) stream
    ;; Empty sequences must not be stored in the buffer.
    (unless (zerop (length sequence))
      (push (list 0 (length sequence) sequence) buffer))))

(defmethod unread-line ((stream unreadable-stream) line)
  "Store LINE with an appended newline at the head of the unread buffer.
It is assumed that SEQUENCE will not be modified."
  (setf (slot-value stream 'at-end-of-file) nil)
  (with-slots (buffer) stream
    ;; If the line is empty, just store a newline.
    (if (zerop (length line))
	(push 10 buffer)
	(push (list 0 (length line) line :line) buffer))))

(defmethod print-object ((object unreadable-stream) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~A ~A" (slot-value object 'buffer) (slot-value object 'stream))))