;;; -*-lisp-*-
;;;
;;; Position-aware stream type
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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)

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

;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions
;; with the Gray generic versions.
#-ecl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'stream-close) #'cl:close
	(fdefinition 'stream-elt-type) #'cl:stream-element-type))

;;;--------------------------------------------------------------------------
;;; File names.

(defgeneric stream-pathname (stream)
  (:documentation
   "Returns the pathname of the file that STREAM is open on.

   If STREAM is open on a file, then return the pathname of that file.
   Otherwise return NIL.")

  ;; Provide some default methods.  Most streams don't have a pathname.
  ;; File-based streams provide a pathname, but it's usually been TRUENAMEd,
  ;; which isn't ideal.  We'll hack around this later.
  (:method ((stream stream))
    nil)
  (:method ((stream file-stream))
    (pathname stream)))

;;;--------------------------------------------------------------------------
;;; Locations.

(defclass file-location ()
  ((pathname :initarg :pathname :type (or pathname null)
	     :accessor file-location-pathname)
   (line :initarg :line :type (or fixnum null) :accessor file-location-line)
   (column :initarg :column :type (or fixnum null)
	   :accessor file-location-column))
  (:documentation
   "A simple structure containing file location information.

   Construct using MAKE-FILE-LOCATION; the main useful function is
   ERROR-FILE-LOCATION."))

(defun make-file-location (pathname line column)
  "Constructor for FILE-LOCATION objects.

   Returns a FILE-LOCATION object with the given contents."
  (make-instance 'file-location
		 :pathname (and pathname (pathname pathname))
		 :line line :column column))

(defgeneric file-location (thing)
  (:documentation
   "Convert THING into a FILE-LOCATION, if possible.")
  (:method ((thing null)) (make-file-location nil nil nil))
  (:method ((thing file-location)) thing)
  (:method ((stream stream))
    (make-file-location (stream-pathname stream) nil nil)))

(defmethod print-object ((object file-location) stream)
  (maybe-print-unreadable-object (object stream :type t)
    (with-slots (pathname line column) object
      (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
	      pathname line column))))

(defmethod make-load-form ((object file-location) &optional environment)
  (make-load-form-saving-slots object :environment environment))

;;;--------------------------------------------------------------------------
;;; 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 stream-close ((stream proxy-stream) &key abort)
  (with-slots (ustream) stream
    (close ustream :abort abort)))

(defmethod stream-elt-type ((stream proxy-stream))
  (with-slots (ustream) stream
    (stream-elt-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 &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 &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.

(defclass position-aware-stream (proxy-stream)
  ((file :initarg :file :initform nil
	 :type pathname :accessor position-aware-stream-file)
   (line :initarg :line :initform 1
	 :type fixnum :accessor position-aware-stream-line)
   (column :initarg :column :initform 0
	   :type fixnum :accessor position-aware-stream-column))
  (:documentation
   "Character stream which keeps track of the line and column position.

   A position-aware-stream wraps an existing character stream and tracks the
   line and column position of the current stream position.  A newline
   character increases the line number by one and resets the column number to
   zero; most characters advance the column number by one, but tab advances
   to the next multiple of eight.  (This is consistent with Emacs, at least.)
   The position can be read using STREAM-LINE-AND-COLUMN.

   This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
   POSITION-AWARE-OUTPUT-STREAM."))

(defgeneric stream-line-and-column (stream)
  (:documentation
   "Returns the current stream position of STREAM as line/column numbers.

   Returns two values: the line and column numbers of STREAM's input
   position.")
  (:method ((stream stream))
    (values nil nil))
  (:method ((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."

  (with-slots (file) stream
    (or file (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.

(declaim (inline update-position))
(defun update-position (char line column)
  "Updates LINE and COLUMN according to the character CHAR.

   Returns the new LINE and COLUMN numbers resulting from having read CHAR."
  (case char
    ((#\newline #\vt #\page)
     (values (1+ line) 0))
    ((#\tab)
     (values line (logandc2 (+ column 7) 7)))
    (t
     (values line (1+ column)))))

(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."

  (let ((streamvar (gensym "STREAM"))
	(linevar (gensym "LINE"))
	(colvar (gensym "COLUMN"))
	(charvar (gensym "CHAR")))
    `(let* ((,streamvar ,stream)
	    (,linevar (position-aware-stream-line ,streamvar))
	    (,colvar (position-aware-stream-column ,streamvar)))
       (macrolet ((update (,charvar)
		    ;; This gets a little hairy.  Hold tight.
		    `(multiple-value-setq (,',linevar ,',colvar)
		      (update-position ,,charvar ,',linevar ,',colvar))))
	 (unwind-protect
	      (progn ,@body)
	   (setf (position-aware-stream-line ,streamvar) ,linevar
		 (position-aware-stream-column ,streamvar) ,colvar))))))

;; Input stream.

(defclass position-aware-input-stream
    (position-aware-stream proxy-character-input-stream)
  ()
  (:documentation
   "A character input stream which tracks the input position.

   This is particularly useful for parsers and suchlike, which want to
   produce accurate error-location information."))

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

  ;; Tweak the position so that the next time the character is read, it will
  ;; end up here.  This isn't perfect: if the character doesn't actually
  ;; match what was really read then it might not actually be possible: for
  ;; example, if we push back a newline while in the middle of a line, or a
  ;; tab while not at a tab stop.  In that case, we'll just lose, but
  ;; hopefully not too badly.
  (with-slots (line column) stream
    (case char

      ;; In the absence of better ideas, I'll set the column number to zero.
      ;; This is almost certainly wrong, but with a little luck nobody will
      ;; ask and it'll be all right soon.
      ((#\newline #\vt #\page)
       (decf line)
       (setf column 0))

      ;; Winding back a single space is sufficient.  If the position is
      ;; currently on a tab stop then it'll advance back here next time.  If
      ;; not, we're going to lose anyway.
      (#\tab
       (decf column))

      ;; Anything else: just decrement the column and cross fingers.
      (t
       (decf column))))

  ;; And actually do it.  (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.)
  (call-next-method))

(defmethod stream-read-sequence
    ((stream position-aware-input-stream) seq &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.

(defclass position-aware-output-stream
    (position-aware-stream proxy-character-output-stream)
  ()
  (:documentation
   "A character output stream which tracks the output position.

   This is particularly useful when generating C code: the position can be
   used to generate `#line' directives referring to the generated code after
   insertion of some user code."))

(defmethod stream-write-sequence
    ((stream position-aware-output-stream) seq &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 --------------------------------------------------