(defpackage #:swank-locked-stream
  (:use #:cl
        #+sbcl #:sb-mop
        #+sbcl #:sb-gray)
  (:export #:make-locked-stream))

(in-package #:swank-locked-stream)

;;; FIXME: there's an explicit sb-thread:with-recursive-lock down
;;; below.

(defclass locked-stream-mixin ()
  ((lock :initform (swank-backend:make-lock :name "stream lock")
         :reader lock-of)))

(defclass wrapped-stream (fundamental-character-input-stream
                          fundamental-character-output-stream
                          fundamental-binary-input-stream
                          fundamental-binary-output-stream)
  ((stream :initarg :stream :reader stream-of)
   (column :initform 0 :accessor column-of :reader stream-line-column)))

(defclass locked-wrapped-stream (locked-stream-mixin
                                 wrapped-stream)
  ())

(defmacro maybe-defmethod (name &rest args)
  (when (and (fboundp name)
             (typep (symbol-function name) 'generic-function))
    `(defmethod ,name ,@args)))

;;{{{ Wrapped stream methods

;;{{{ Character input

(defmethod stream-read-char ((stream wrapped-stream))
  (read-char (stream-of stream) nil :eof))

(defmethod stream-unread-char ((stream wrapped-stream) character)
  (unread-char character (stream-of stream)))

(defmethod stream-read-char-no-hang ((stream wrapped-stream))
  (read-char-no-hang (stream-of stream) nil :eof))

(defmethod stream-peek-char ((stream wrapped-stream))
  (peek-char nil (stream-of stream) nil :eof))

(defmethod stream-listen ((stream wrapped-stream))
  (listen (stream-of stream)))

(defmethod stream-read-line ((stream wrapped-stream))
  (read-line (stream-of stream) nil ""))

(defmethod stream-clear-input ((stream wrapped-stream))
  (clear-input (stream-of stream)))

;;}}}
;;{{{ Character output

(defmethod stream-write-char ((stream wrapped-stream) character)
  (prog1
      (write-char character (stream-of stream))
    (if (eql character #\Newline)
        (setf (column-of stream) 0)
        (incf (column-of stream)))))

(defmethod stream-start-line-p ((stream wrapped-stream))
  (eql (column-of stream) 0))

(defun write-string/sequence (f stream seq start/end)
  (prog1
      (apply f seq (stream-of stream) start/end)
    (destructuring-bind (&key start end) start/end
      (let ((seqlen (or end (length seq)))
            (newline-pos (apply #'position #\Newline seq
                                :from-end t start/end)))
        (if newline-pos
            (setf (column-of stream) (- seqlen newline-pos))
            (incf (column-of stream) (- seqlen (or start 0))))))))

(defmethod stream-write-string ((stream wrapped-stream)
                                string
                                &optional
                                (start nil startp)
                                (end nil endp))
  (let ((start/end (nconc (if startp (list :start start))
                          (if endp (list :end end)))))
    (write-string/sequence #'write-string stream string start/end)))

(defmethod stream-terpri ((stream wrapped-stream))
  (prog1
      (terpri (stream-of stream))
    (setf (column-of stream) 0)))

(defmethod stream-fresh-line ((stream wrapped-stream))
  (prog1
      (fresh-line (stream-of stream))
    (setf (column-of stream) 0)))

(defmethod stream-finish-output ((stream wrapped-stream))
  (finish-output (stream-of stream)))

(defmethod stream-force-output ((stream wrapped-stream))
  (force-output (stream-of stream)))

(defmethod stream-advance-to-column ((stream wrapped-stream) column)
  (let ((spaces (- column
                   (column-of stream)))
        (stream (stream-of stream)))
    (loop for i below spaces
          do (write-char #\Space stream)
             (incf (column-of stream)))))

(defmethod stream-clear-output ((stream wrapped-stream))
  (clear-output (stream-of stream)))

;;}}}
;;{{{ Binary IO

(defmethod stream-read-byte ((stream wrapped-stream))
  (read-byte (stream-of stream) nil :eof))

(defmethod stream-write-byte ((stream wrapped-stream stream)
                              integer)
  (write-byte integer (stream-of stream)))

;;}}}
;;{{{ Sequence IO

(defmethod stream-read-sequence ((stream wrapped-stream)
                                 seq
                                 &optional
                                 (start nil startp)
                                 (end nil endp))
  (let ((start/end (nconc (if startp (list :start start))
                          (if endp (list :end end)))))
    (apply #'read-sequence seq (stream-of stream) start/end)))

(defmethod stream-write-sequence ((stream wrapped-stream)
                                  seq
                                  &optional
                                  (start nil startp)
                                  (end nil endp))
  (let ((start/end (nconc (if startp (list :start start))
                          (if endp (list :end end)))))
    (write-string/sequence #'write-sequence stream seq start/end)))

;;}}}
;;{{{ Misc functions

(defmethod close ((stream wrapped-stream) &key abort)
  (close (stream-of stream) :abort abort))

(defmethod open-stream-p ((stream wrapped-stream))
  (open-stream-p (stream-of stream)))

(maybe-defmethod streamp ((stream wrapped-stream))
  (streamp (stream-of stream)))

(maybe-defmethod input-stream-p ((stream wrapped-stream))
  (input-stream-p (stream-of stream)))

(maybe-defmethod output-stream-p ((stream wrapped-stream))
  (output-stream-p (stream-of stream)))

(maybe-defmethod stream-element-type ((stream wrapped-stream))
  (stream-element-type (stream-of stream)))

(maybe-defmethod stream-yes-or-no-p ((stream wrapped-stream)
                                     &optional format-string
                                     &rest args)
  (apply #'yes-or-no-p (stream-of stream) format-string args))

(maybe-defmethod stream-y-or-n-p ((stream wrapped-stream)
                                  &optional format-string
                                  &rest args)
  (apply #'y-or-n-p (stream-of stream) format-string args))

;;}}}

;;}}}

(defmacro define-locked-around-methods (&body specs)
  `(progn
    ,@(mapcar (lambda (spec)
                (destructuring-bind (name arglist) spec
                  (let* ((arglist* (copy-list arglist))
                         (param (member 'stream arglist*)))
                    (setf (car param) `(,(car param) locked-stream-mixin))
                    `(maybe-defmethod ,name :around ,arglist*
                      (declare (ignorable ,@(set-difference arglist
                                                            lambda-list-keywords)))
                      (sb-thread:with-recursive-lock ((lock-of ,(caar param)))
                        (call-next-method))))))
        specs)))

(define-locked-around-methods
  (stream-read-char (stream))
  (stream-unread-char (stream character))
  (stream-read-char-no-hang (stream))
  (stream-peek-char (stream))
  (stream-listen (stream))
  (stream-read-line (stream))
  (stream-clear-input (stream))

  (stream-write-char (stream character))
  (stream-line-column (stream))
  (stream-start-line-p (stream))
  (stream-write-string (stream string &optional start end))
  (stream-terpri (stream))
  (stream-fresh-line (stream))
  (stream-finish-output (stream))
  (stream-force-output (stream))
  (stream-advance-to-column (stream column))
  (stream-clear-output (stream))
  
  (stream-read-byte (stream))
  (stream-write-byte (stream integer))

  (stream-read-sequence (stream seq &optional start end))
  (stream-write-sequence (stream seq &optional start end))

  (close (stream &key abort))
  (open-stream-p (stream))
  (streamp (stream))
  (input-stream-p (stream))
  (output-stream-p (stream))
  (stream-element-type (stream))
  (stream-yes-or-no-p (stream &optional format-string &rest args))
  (stream-y-or-n-p (stream &optional format-string &rest args))
  (stream-input-fn (stream))
  (stream-output-fn (stream))
  
  (stream-line-length (stream))
  (stream-output-width (stream)))

(defvar *locked-stream-classes* (make-hash-table))

(defun make-locked-stream (stream)
  "Returns a version of STREAM that prevents concurrent access.  If
STREAM is already a locked stream, it's returned.  If it's a Gray
stream, its class is changed to a subtype of its current class which
has had a locked-stream mixin prepended to its precedence list.
Otherwise, it's wrapped in a Gray stream that simply calls the
standard CL stream functions with a lock held."
  (etypecase stream
    (locked-stream-mixin
     stream)
    (fundamental-stream
     (let ((locked-class (gethash (class-of stream) *locked-stream-classes*)))
       (unless locked-class
         (setf locked-class (ensure-class
                             (gensym (princ-to-string (type-of stream)))
                             :direct-superclasses (list 'locked-stream-mixin
                                                        (class-of stream))))
         (setf (gethash (class-of stream) *locked-stream-classes*) locked-class))
       (change-class stream locked-class)))
    (stream
     (make-instance 'locked-wrapped-stream :stream stream))))