;;; -*-lisp-*-
;;;
;;; Additional streams.
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD 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.
;;;
;;; SOD 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 SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod-parser)

;;;--------------------------------------------------------------------------
;;; Compatibility hacking.

;; ECL is different and strange.  In early versions (0.9j and thereabouts)
;; the Gray streams functions are in the SI package; CLOSE and STREAM-
;; ELEMENT-TYPE are not generic, and call the generic functions SI:STREAM-
;; CLOSE and SI:STREAM-ELT-TYPE if they find that they can't handle their
;; argument.  The STREAM-CLOSE generic function doesn't have a method for the
;; built-in streams.  In later versions (9.6.1 and thereabouts) the Gray
;; streams functions are in the GRAY package; CLOSE and STREAM-ELEMENT-TYPE
;; are still not generic, but now they call correspondingly-named generic
;; functions in GRAY, and the generic versions do cover the built-in streams.
;;
;; The right thing to, then, seems to be as follows.
;;
;;   * ECL is the weird system, so we'll hack it to be less weird.  Hacking
;;     non-weird platforms seems wrong-headed.
;;
;;   * Since SI:STREAM-CLOSE is missing a method which works on standard
;;     streams, we should add one if we're running that version of ECL.
;;
;;   * Then we can shadow CLOSE and drop SI:STREAM-CLOSE or GRAY:CLOSE over
;;     the top.  In the latter case, we can just do a SHADOWING-IMPORT; in
;;     the latter, we'll need to mess with FDEFINITION.
;;
;;   * We'll do something similar for STREAM-ELEMENT-TYPE.
;;
;; Note that the following are all separate top-level forms so that later
;; ones will be read with different symbols than earlier ones.  This also
;; means that we can use the *FEATURES* mechanism and avoid lots of the
;; tedious messing about with FIND-SYMBOL.

#+ecl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (if (find-package '#:gray)
    (push :sod-ecl-broken-gray-streams *features*)))

#+(and ecl (not sod-ecl-broken-gray-streams))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadowing-import '(gray:close gray:stream-element-type)))

#+(and ecl sod-ecl-broken-gray-streams)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadow '(close stream-element-type)))
#+(and ecl sod-ecl-broken-gray-streams)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'close) #'si:stream-close
	(fdefinition 'stream-element-type #'si:stream-elt-type)))

;;;--------------------------------------------------------------------------
;;; Proxy streams.

;; Base classes for proxy streams.

(defclass proxy-stream (fundamental-stream)
  ((ustream :initarg :stream :type stream
	    :reader position-aware-stream-underlying-stream))
  (:documentation
   "Base class for proxy streams.

   A proxy stream is one that works by passing most of its work to an
   underlying stream.  We provide some basic functionality for the later
   classes."))

(defmethod close ((stream proxy-stream) &key abort)
  (with-slots (ustream) stream
    (close ustream :abort abort)))

(defmethod stream-element-type ((stream proxy-stream))
  (with-slots (ustream) stream
    (stream-element-type ustream)))

(defmethod stream-file-position
    ((stream proxy-stream) &optional (position nil posp))
  (with-slots (ustream) stream
    (if posp
	(file-position ustream position)
	(file-position ustream))))

(defmethod stream-pathname ((stream proxy-stream))
  (with-slots (ustream) stream
    (stream-pathname ustream)))

;; Base class for input streams.

(defclass proxy-input-stream (proxy-stream fundamental-input-stream)
  ()
  (:documentation
   "Base class for proxy input streams."))

(defmethod stream-clear-input ((stream proxy-input-stream))
  (with-slots (ustream) stream
    (clear-input ustream)))

(defmethod stream-read-sequence
    ((stream proxy-input-stream) seq
     #+clisp &key #-clisp &optional (start 0) end)
  (with-slots (ustream) stream
    (read-sequence seq ustream :start start :end end)))

;; Base class for output streams.

(defclass proxy-output-stream (proxy-stream fundamental-output-stream)
  ()
  (:documentation
   "Base class for proxy output streams."))

(defmethod stream-clear-output ((stream proxy-output-stream))
  (with-slots (ustream) stream
    (clear-output ustream)))

(defmethod stream-finish-output ((stream proxy-output-stream))
  (with-slots (ustream) stream
    (finish-output ustream)))

(defmethod stream-force-output ((stream proxy-output-stream))
  (with-slots (ustream) stream
    (force-output ustream)))

(defmethod stream-write-sequence
    ((stream proxy-output-stream) seq
     #+clisp &key #-clisp &optional (start 0) end)
  (with-slots (ustream) stream
    (write-sequence seq ustream :start start :end end)))

;; Character input streams.

(defclass proxy-character-input-stream
    (proxy-input-stream fundamental-character-input-stream)
  ()
  (:documentation
   "A character-input-stream which is a proxy for an existing stream.

   This doesn't actually change the behaviour of the underlying stream very
   much, but it's a useful base to work on when writing more interesting
   classes."))

(defmethod stream-read-char ((stream proxy-character-input-stream))
  (with-slots (ustream) stream
    (read-char ustream nil :eof nil)))

(defmethod stream-read-line ((stream proxy-character-input-stream))
  (with-slots (ustream) stream
    (read-line ustream nil "" nil)))

(defmethod stream-unread-char ((stream proxy-character-input-stream) char)
  (with-slots (ustream) stream
    (unread-char char ustream)))

;; Character output streams.

(defclass proxy-character-output-stream
    (proxy-stream fundamental-character-output-stream)
  ()
  (:documentation
   "A character-output-stream which is a proxy for an existing stream.

   This doesn't actually change the behaviour of the underlying stream very
   much, but it's a useful base to work on when writing more interesting
   classes."))

(defmethod stream-line-column ((stream proxy-character-output-stream))
  nil)

(defmethod stream-line-length ((stream proxy-character-output-stream))
  nil)

(defmethod stream-terpri ((stream proxy-character-output-stream))
  (with-slots (ustream) stream
    (terpri ustream)))

(defmethod stream-write-char ((stream proxy-character-output-stream) char)
  (with-slots (ustream) stream
    (write-char char ustream)))

(defmethod stream-write-string
    ((stream proxy-character-output-stream) string &optional (start 0) end)
  (with-slots (ustream) stream
    (write-string string ustream :start start :end end)))

;;;--------------------------------------------------------------------------
;;; The position-aware stream.

;; Base class.

(defmethod stream-line-and-column ((stream position-aware-stream))
  (with-slots (line column) stream
    (values line column)))

(defmethod stream-pathname ((stream position-aware-stream))
  "Return the pathname corresponding to a `position-aware-stream'.

   A `position-aware-stream' can be given an explicit pathname, which is
   returned in preference to the pathname of the underlying stream.  This is
   useful in two circumstances.  Firstly, the pathname associated with a file
   stream will have been subjected to `truename', and may be less pleasant to
   present back to a user.  Secondly, a name can be attached to a stream
   which doesn't actually have a file backing it."

  (or (position-aware-stream-file stream)
      (call-next-method)))

(defmethod file-location ((stream position-aware-stream))
  (multiple-value-bind (line column) (stream-line-and-column stream)
    (make-file-location (stream-pathname stream) line column)))

;; Utilities.

(defmacro with-position ((stream) &body body)
  "Convenience macro for tracking the read position.

   Within the BODY, the macro (update CHAR) is defined to update the STREAM's
   position according to the character CHAR.

   The position is actually cached in local variables, but will be written
   back to the stream even in the case of non-local control transfer from the
   BODY.  What won't work well is dynamically nesting `with-position' forms."

  (with-gensyms (line column char)
    (once-only (stream)
      `(let* ((,line (position-aware-stream-line ,stream))
	      (,column (position-aware-stream-column ,stream)))
	 (macrolet ((update (,char)
		      ;; This gets a little hairy.  Hold tight.
		      `(multiple-value-setq (,',line ,',column)
			 (update-position ,,char ,',line ,',column))))
	   (unwind-protect
		(progn ,@body)
	     (setf (position-aware-stream-line ,stream) ,line
		   (position-aware-stream-column ,stream) ,column)))))))

;; Input stream.

(defmethod stream-unread-char ((stream position-aware-input-stream) char)

  ;; I could have written this as a :before or :after method, but I think
  ;; this is the right answer.  All of the other methods have to be primary
  ;; (or around) methods, so at least it's consistent.
  (with-slots (line column) stream
    (setf (values line column) (backtrack-position char line column)))
  (call-next-method))

(defmethod stream-read-sequence
    ((stream position-aware-input-stream) seq
     #+clisp &key #-clisp &optional (start 0) end)
  (declare (ignore end))
  (let ((pos (call-next-method)))
    (with-position (stream)
      (dosequence (ch seq :start start :end pos)
	(update ch)))
    pos))

(defmethod stream-read-char ((stream position-aware-input-stream))
  (let ((char (call-next-method)))
    (with-position (stream)
      (update char))
    char))

(defmethod stream-read-line ((stream position-aware-input-stream))
  (multiple-value-bind (line eofp) (call-next-method)
    (if eofp
	(with-position (stream)
	  (dotimes (i (length line))
	    (update (char line i))))
	(with-slots (line column) stream
	  (incf line)
	  (setf column 0)))
    (values line eofp)))

;; Output stream.

(defmethod stream-write-sequence
    ((stream position-aware-output-stream) seq
     #+clisp &key #-clisp &optional (start 0) end)
  (with-position (stream)
    (dosequence (ch seq :start start :end end)
      (update ch))
    (call-next-method)))

(defmethod stream-line-column ((stream position-aware-output-stream))
  (with-slots (column) stream
    column))

(defmethod stream-start-line-p ((stream position-aware-output-stream))
  (with-slots (column) stream
    (zerop column)))

(defmethod stream-terpri ((stream position-aware-output-stream))
  (with-slots (line column) stream
    (incf line)
    (setf column 0))
  (call-next-method))

(defmethod stream-write-char ((stream position-aware-output-stream) char)
  (with-position (stream)
    (update char))
  (call-next-method))

(defmethod stream-write-string
    ((stream position-aware-output-stream) string &optional (start 0) end)
  (with-position (stream)
    (do ((i start (1+ i))
	 (end (or end (length string))))
	((>= i end))
      (update (char string i))))
  (call-next-method))

;;;----- That's all, folks --------------------------------------------------