(in-package :vector-update-stream)
 
 (defclass vector-update-stream (fundamental-binary-output-stream)
   ((vector :accessor vector-stream-vector :initarg :vector))
   (:documentation "A binary output stream that writes its data to an associated vector."))
 
 (deftype octet ()
   '(unsigned-byte 8))
 
 (defun make-update-stream (array)
   (unless (and (array-has-fill-pointer-p array)
 	       (adjustable-array-p array))
     (error "GET-STREAM-FOR-ARRAY requires an adjustable array with a fill pointer"))
   (make-instance 'vector-update-stream
 		 :vector array))
 
 (defun check-if-open (stream)
   "Checks if STREAM is open and signals an error otherwise."
   (unless (open-stream-p stream)
     (error 'flexi-streams:in-memory-stream-closed-error
 	   :stream stream)))
 
 (defmethod stream-write-byte ((stream vector-update-stream) byte)
   "Writes a byte \(octet) by extending the underlying vector."
   (check-if-open stream)
   (with-accessors ((vector vector-stream-vector)) stream
     (let ((orig-fill-pointer (fill-pointer vector)))
       (handler-bind ((error (lambda (c)
 			      (declare (ignore c))
 			      (setf (fill-pointer vector) orig-fill-pointer))))
 	(vector-push-extend byte vector)))))
 
 (defmethod stream-write-sequence ((stream vector-update-stream) sequence start end &key)
   "Just calls VECTOR-PUSH-EXTEND repeatedly."
   (declare (fixnum start end))
   (with-accessors ((vector vector-stream-vector)) stream
     (let ((orig-fill-pointer (fill-pointer vector)))
       (handler-bind ((error (lambda (c)
 			      (declare (ignore c))
 			      (setf (fill-pointer vector) orig-fill-pointer))))
 	(loop for index of-type fixnum from start below end
 	   do (vector-push-extend (elt sequence index) vector))))
     sequence))
 
 (defmethod stream-file-position ((stream vector-update-stream))
   "Simply returns the fill pointer of the underlying vector."
   (with-accessors ((vector vector-stream-vector)) stream
     (fill-pointer vector)))
 
 (defmethod (setf stream-file-position) (position-spec (stream vector-update-stream))
   "Sets the fill pointer underlying vector if POSITION-SPEC is
 acceptable.  Adjusts the vector if necessary."
   (with-accessors ((vector vector-stream-vector))
       stream
     (let* ((total-size (array-total-size vector))
            (new-fill-pointer
             (case position-spec
               (:start 0)
               (:end
                (warn "File position designator :END doesn't really make sense for an output stream.")
                total-size)
               (otherwise
                (unless (integerp position-spec)
                  (error 'flexi-streams:in-memory-stream-position-spec-error
                         :format-control "Unknown file position designator: ~S."
                         :format-arguments (list position-spec)
                         :stream stream
                         :position-spec position-spec))
                (unless (<= 0 position-spec array-total-size-limit)
                  (error 'flexi-streams:in-memory-stream-position-spec-error
                         :format-control "File position designator ~S is out of bounds."
                         :format-arguments (list position-spec)
                         :stream stream
                         :position-spec position-spec))
                position-spec))))
       (declare (fixnum total-size new-fill-pointer))
       (when (> new-fill-pointer total-size)
         (adjust-array vector new-fill-pointer))
       (setf (fill-pointer vector) new-fill-pointer)
       position-spec)))
 
 (defmethod get-output-stream-sequence ((stream vector-update-stream) &key)
   "Returns a vector containing, in order, all the octets that have
 been output to the IN-MEMORY stream STREAM. This operation clears any
 octets on STREAM, so the vector contains only those octets which have
 been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
 the creation of the stream, whichever occurred most recently.  If
 AS-LIST is true the return value is coerced to a list."
   (vector-stream-vector stream))
 
 (defmacro deftest (name (expected actual-init) (&rest bindings) &body actions)
   (alexandria:with-gensyms (assertion-template)
     `(let* ((expected ,expected)
 	    (actual ,actual-init)
 	    ,@bindings
 	    (,assertion-template (formatter "~&~a Test: ~:[fail~%~4texpected ~s~%~4tactual ~s~;succeed~]~%")))
        (declare (ignorable ,assertion-template))
        (flet ((check (assertion)
 		    (funcall ,assertion-template t ',name (funcall assertion expected actual) expected actual)))
 	 ,@actions)
        (values))))
 
 (defun test ()
   (deftest write-sequence
       (#(1 2 3) (make-array 0 :adjustable t :fill-pointer 0))
       ((vs (make-update-stream actual)))
     (write-sequence expected vs)
     (check 'serapeum:vector=))
 
   (deftest write-sequence-undo-on-error
       (#(1 2 3) (make-array 0 :adjustable t :fill-pointer 0 :element-type 'octet))
       ((vs (make-update-stream actual)))
     (write-sequence expected vs)
     (handler-case (write-sequence #(1 2 3 #\a) vs)
       (type-error (c) c (values)))
     (check 'serapeum:vector=))
 
   (deftest write-byte
       (#(1) (make-array 0 :adjustable t :fill-pointer 0))
       ((vs (make-update-stream actual)))
     (write-byte 1 vs)
     (check 'serapeum:vector=))
 
   (deftest write-byte-undo-on-error
       (#() (make-array 0 :adjustable t :fill-pointer 0 :element-type 'octet))
       ((vs (make-update-stream actual)))
     (handler-case (stream-write-byte vs #\a)
       (type-error (c) c (values)))
     (check 'serapeum:vector=)))