;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deserialization of Java Serialized Objects.
;;; http://docs.oracle.com/javase/7/docs/platform/serialization/spec/protocol.html
;;;
;;;  Copyright (C) 2015, Andy Bennett, Skipjaq Inc.
;;;  All rights reserved.
;;;
;;;  Redistribution and use in source and binary forms, with or without
;;;  modification, are permitted provided that the following conditions are met:
;;;
;;;  Redistributions of source code must retain the above copyright notice, this
;;;  list of conditions and the following disclaimer.
;;;  Redistributions in binary form must reproduce the above copyright notice,
;;;  this list of conditions and the following disclaimer in the documentation
;;;  and/or other materials provided with the distribution.
;;;  Neither the name of the author nor the names of its contributors may be
;;;  used to endorse or promote products derived from this software without
;;;  specific prior written permission.
;;;
;;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;;  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
;;;  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;;  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;;  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;;  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;;  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;  POSSIBILITY OF SUCH DAMAGE.
;;;
;;; Andy Bennett <andyjpb@skipjaq.com>, 2015/06
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module s11n4j
	(deserialize
	 entities-ref

	 baseWireHandle

	 make-enum
	 enum?
	 enum-handle
	 enum-name
	 enum-class-description

	 make-object
	 object?
	 object-handle
	 object-class-description
	 object-fields
	 object-annotation
	 object-external-contents

	 make-object-field
	 object-field-type-code
	 object-field-type-class-description
	 object-field-level
	 object-field-name

	 make-object-annotation
	 object-annotation?
	 object-annotation-class-description
	 object-annotation-annotation

	 make-class-field
	 class-field?
	 class-field-type-code
	 class-field-type-class-description
	 class-field-name

	 make-class-description
	 class-description?
	 class-description-handle
	 class-description-name
	 class-description-serial
	 class-description-flags
	 class-description-fields
	 class-description-annotation
	 class-description-super

	 make-array
	 array?
	 array-handle
	 array-class-description
	 array-size
	 array-values

	 obj-types
	 prim-types
	 )

(import chicken scheme)

; Units - http://api.call-cc.org/doc/chicken/language
(use data-structures srfi-1 extras srfi-4)

; Eggs - http://wiki.call-cc.org/chicken-projects/egg-index-4.html
(use numbers comparse matchable)


;;;;;;;;;;
;;; Helpers

(define (s11n4j-abort . x)
  (fprintf (current-error-port) "\ns11n4j Aborting!\n\n")
  ;(pp (entities) (current-error-port))
  (apply abort x))


;;;;;;;;;;
;;; ADTs


; Handles for referencing entities in the stream

(define (make-handle value)
  `(handle: ,value))

(define handle-value second)


; Enum

(define (make-enum handle name class-description)
  `(enum: .
	  ((handle            . ,handle)
	   (name              . ,name)
	   (class-description . ,class-description))))

(define (enum? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? enum: (car obj))
    (= 4 (length obj))))

(define (make-enum-accessor field)
  (lambda (enum)
    (match enum
      (('enum: . enum)
       (alist-ref field enum))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not an enum: ~S\n" enum))))))

(define enum-handle            (make-enum-accessor 'handle))
(define enum-name              (make-enum-accessor 'name))
(define enum-class-description (make-enum-accessor 'class-description))


; Class Data

(define (make-class-data fields annotation)
  `(class-data: .
		((fields     . ,fields)
		 (annotation . ,annotation))))

(define (class-data? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? class-data: (car obj))
    (= 3 (length obj))))

(define (make-class-data-accessor field)
  (lambda (class-data)
    (match class-data
      (('class-data: . class-data)
       (alist-ref field class-data))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not a class-data: ~S\n" class-data))))))

(define class-data-fields      (make-class-data-accessor 'fields))
(define class-data-annotation  (make-class-data-accessor 'annotation))


; Object

(define (make-object handle class-description fields annotation external-contents)
 `(object: .
	 ((handle            . ,handle)
	  (class-description . ,class-description)
	  (fields            . ,fields)
	  (annotation        . ,annotation)
	  (external-contents  . ,external-contents))))

(define (object? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? object: (car obj))
    (= 6 (length obj))))

(define (make-object-accessor field)
  (lambda (object)
    (match object
      (('object: . object)
       (alist-ref field object))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not an object: ~S\n" object))))))

(define object-handle            (make-object-accessor 'handle))
(define object-class-description (make-object-accessor 'class-description))
(define object-fields            (make-object-accessor 'fields))
(define object-annotation        (make-object-accessor 'annotation))
(define object-external-contents (make-object-accessor 'external-contents))


; Object Fields

; Takes a field from a class description and annotates it with its level in the
; class hierarchy.
;
; When an object is instantiated it contains a flat field list produced by
; get-field-list. Fields in derived classes can hide fields with the same name
; in super classes so we number the fields, starting at 0 for fields of the
; most derived class and working towards the base class. The correct field
; value is the field with the lowest number of those with the field name you
; are looking for.
(define (make-object-field field #!optional (level 0))
  `(object-field: .
		  ((type-code              . ,(class-field-type-code field))
		   (type-class-description . ,(class-field-type-class-description field))
		   (level                  . ,level)
		   (name                   . ,(class-field-name field)))))

(define (make-object-field-accessor field)
  (lambda (object-field)
    (match object-field
      (('object-field: . object-field)
       (alist-ref field object-field))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not an object-field: ~S\n" object-field))))))

(define object-field-type-code               (make-object-field-accessor 'type-code))
(define object-field-type-class-description  (make-object-field-accessor 'type-class-description))
(define object-field-level                   (make-object-field-accessor 'level))
(define object-field-name                    (make-object-field-accessor 'name))


; Object Annotations

(define (make-object-annotation class-description-handle annotation)
  `(object-annotation: .
		       ((class-description . ,class-description-handle)
			(annotation        . ,annotation))))

(define (object-annotation? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? object-annotation: (car obj))
    (= 3 (length obj))))

(define (make-object-annotation-accessor field)
  (lambda (object-annotation)
    (match object-annotation
      (('object-annotation: . object-annotation)
       (alist-ref field object-annotation))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not an object-annotation: ~S\n" object-annotation))))))

(define object-annotation-class-description (make-object-annotation-accessor 'class-description))
(define object-annotation-annotation        (make-object-annotation-accessor 'annotation))


; Class Fields

(define (make-class-field type-code type-class-description name)
  `(class-field: .
		 ((type-code              . ,type-code)
		  (type-class-description . ,type-class-description)
		  (name                   . ,name))))

(define (class-field? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? class-field: (car obj))
    (= 4 (length obj))))

(define (make-class-field-accessor field)
  (lambda (class-field)
    (match class-field
      (('class-field: . class-field)
       (alist-ref field class-field))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not a class-field: ~S\n" class-field))))))

(define class-field-type-code              (make-class-field-accessor 'type-code))
(define class-field-type-class-description (make-class-field-accessor 'type-class-description))
(define class-field-name                   (make-class-field-accessor 'name))


; ClassDesc

(define (make-class-description handle name serial flags fields annotation super)
  `(class-description: .
		       ((handle     . ,handle)
			(name       . ,name)
			(serial     . ,serial)
			(flags      . ,flags)
			(fields     . ,fields)
			(annotation . ,annotation)
			(super      . ,super))))

(define (class-description? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? class-description: (car obj))
    (= 8 (length obj))))

(define (make-class-description-accessor field)
  (lambda (class-description)
    (match class-description
      (('class-description: . class-description)
       (alist-ref field class-description))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not a class-description: ~S\n" class-description))))))

(define class-description-handle  (make-class-description-accessor 'handle))

(define class-description-name    (make-class-description-accessor 'name))

(define class-description-serial  (make-class-description-accessor 'serial))

(define class-description-flags   (make-class-description-accessor 'flags))

(define class-description-fields  (make-class-description-accessor 'fields))

(define class-description-annotation
  (make-class-description-accessor 'annotation))

(define class-description-super   (make-class-description-accessor 'super))

(define (get-field-list class-description-handle n)
  (let ((class-description (entities-ref class-description-handle)))
    (if class-description
      (map (cut make-object-field <> n)
	   (class-description-fields class-description))
      '())))


; Array

(define (make-array handle class-description size values*)
 `(array: .
	 ((handle            . ,handle)
	  (class-description . ,class-description)
	  (size              . ,size)
	  (values            . ,(cond
				 ((list? values*)   (list->vector values*))
				 ((vector? values*) values*)
				 (else (abort (conc "Don't know how to make an array from " values*))))))))

(define (array? obj)
  (and
    (pair? obj)
    (list? obj)
    (eq? array: (car obj))
    (= 5 (length obj))))

(define (make-array-accessor field)
  (lambda (array)
    (match array
      (('array: . array)
       (alist-ref field array))
      (()
       '())
      (else (s11n4j-abort
	      (sprintf "Not an array: ~S\n" array))))))

(define array-handle            (make-array-accessor 'handle))

(define array-class-description (make-array-accessor 'class-description))

(define array-size              (make-array-accessor 'size))

(define array-values            (make-array-accessor 'values))


;;;;;;;;;;



;;;;;;;;;;
;;; Terminal Symbols and Constants
;;; http://docs.oracle.com/javase/7/docs/platform/serialization/spec/protocol.html#10152

(define (bytes->string . bytes)
  (list->string
    (map integer->char bytes)))

; Returns a parser that parses bytes.
(define (short-seq . bytes)
  (assert (= 2 (length bytes)))
  (char-seq
    (apply bytes->string bytes)))

; Returns a parser that parses bytes.
(define (byte-seq . bytes)
  (assert (= 1 (length bytes)))
  (char-seq
    (apply bytes->string bytes)))

(define (bytes->number . bytes)
  (let loop ((int   0)
	     (bytes bytes))
    (if (null? bytes)
      int
      (loop
	(bitwise-ior
	  (arithmetic-shift int 8)
	  (char->integer (car bytes)))
	(cdr bytes)))))


; Terminal and constant values

(define STREAM_MAGIC      (short-seq #xac #xed)) ; short
(define STREAM_VERSION    (short-seq #x00 #x05)) ; short
(define TC_NULL           (byte-seq  #x70))      ; byte
(define TC_REFERENCE      (byte-seq  #x71))      ; byte
(define TC_CLASSDESC      (byte-seq  #x72))      ; byte
(define TC_OBJECT         (byte-seq  #x73))      ; byte
(define TC_STRING         (byte-seq  #x74))      ; byte
(define TC_ARRAY          (byte-seq  #x75))      ; byte
(define TC_CLASS          (byte-seq  #x76))      ; byte
(define TC_BLOCKDATA      (byte-seq  #x77))      ; byte
(define TC_ENDBLOCKDATA   (byte-seq  #x78))      ; byte
(define TC_RESET          (byte-seq  #x79))      ; byte
(define TC_BLOCKDATALONG  (byte-seq  #x7A))      ; byte
(define TC_EXCEPTION      (byte-seq  #x7B))      ; byte
(define TC_LONGSTRING     (byte-seq  #x7C))      ; byte
(define TC_PROXYCLASSDESC (byte-seq  #x7D))      ; byte
(define TC_ENUM           (byte-seq  #x7E))      ; byte


(define baseWireHandle    #x7E0000) ; int


; Flag bytes

(define SC_WRITE_METHOD   #x01) ; byte //if SC_SERIALIZABLE
(define SC_BLOCK_DATA     #x08) ; byte //if SC_EXTERNALIZABLE
(define SC_SERIALIZABLE   #x02) ; byte
(define SC_EXTERNALIZABLE #x04) ; byte
(define SC_ENUM           #x10) ; byte

(define (test-bit-flag flag value)
 (> (bitwise-and flag value) 0))

(define (write-method? flags)
  (test-bit-flag SC_WRITE_METHOD flags))

(define (block-data? flags)
  (test-bit-flag SC_BLOCK_DATA flags))

(define (serializable? flags)
  (test-bit-flag SC_SERIALIZABLE flags))

(define (externalizable? flags)
  (test-bit-flag SC_EXTERNALIZABLE flags))

(define (flag-enum? flags)
  (test-bit-flag SC_ENUM flags))

;;;;;;;;;;



;;;;;;;;;;
;;; Parser State


;; Handles

(define current-handle (make-parameter baseWireHandle))


; newHandle:       // The next number in sequence is assigned
;                  // to the object being serialized or deserialized
;
; This is used as a parser combinator so it returns a dummy result. The main
; work of this procedure is to have a side effect that causes the
; current-handle to be incremented.
;
; Who knows what happens if this gets called and then the parser backtracks. We
; assume that the grammar is robust enough that this never happens. The
; evidence we use to make that assumption is that it is only ever called after
; the parser that calls it has consumed the appropriate type code for that
; parser.
(define (newHandle)
  (let* ((n      (current-handle))
	 (result (result (make-handle n))))
    (current-handle (+ 1 n))
    result))

(define (handle-reset)
  (current-handle baseWireHandle))


;; Entities

(define entities (make-parameter '()))

(define (add-entity! handle entity)
  (entities
    (cons `(,handle . ,entity)
    (entities))))

(define (entities-reset)
  (entities `((old . ,(entities)))))

;(define entities-ref (cut alist-ref <> (entities) <...>))
(define (entities-ref key #!optional (entities (entities)))
  (alist-ref key entities))

;;;;;;;;;;



;;;;;;;;;;
;;; Rules of the Grammar
;;; http://docs.oracle.com/javase/7/docs/platform/serialization/spec/protocol.html#53688

; Consume n bytes and convert them.
(define (bytes size convert)
  (bind (repeated item size)
	(lambda (x)
	  (result
	    (convert (list->string x))))))

(define unsigned-byte (bind item
			    (lambda (x)
			      (result
				(char->integer x)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; Single 16-bit, Unicode character
; FIXME: Test this!
(define char (bind (repeated item 2)
		   (lambda (x)
		     (result
		       (list->string x)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; Double precision, 64-bit, IEEE 754 floating point
; With a little help from protobuf's encoding.scm
(define double (bind (repeated item 8)
		     (lambda (x)
		       (result
			 (f64vector-ref
			   (blob->f64vector/shared
			     (u8vector->blob/shared
			       (apply u8vector
				      (map char->integer x))))
			   0)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; Single precision, 32-bit, IEEE 754 floating point
; With a little help from protobuf's encoding.scm
(define float (bind (repeated item 4)
		    (lambda (x)
		      (result
			(f32vector-ref
			  (blob->f32vector/shared
			    (u8vector->blob/shared
			      (apply u8vector
				     (map char->integer x))))
			  0)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; 8-bit, signed, two's complement integer
; With a little help from protobuf's encoding.scm
; More verbose than necessary but consistent with short, int and long.
(define byte (bind (repeated item 1)
		   (lambda (x)
		     (result
		       (s8vector-ref
			 (blob->s8vector/shared
			   (u8vector->blob/shared
			     (apply u8vector
				    (reverse ; Endianness!
				      (map char->integer x)))))
			 0)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; 16-bit, signed, two's complement integer
; With a little help from protobuf's encoding.scm
(define short (bind (repeated item 2)
		    (lambda (x)
		      (result
			(s16vector-ref
			  (blob->s16vector/shared
			    (u8vector->blob/shared
			      (apply u8vector
				     (reverse ; Endianness!
				       (map char->integer x)))))
			  0)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; 32-bit, signed, two's complement integer
;(define int (bind (repeated item 4)
;		  (lambda (x)
;		    (result
;		      (apply bytes->number x)))))
; With a little help from protobuf's encoding.scm
(define int (bind (repeated item 4)
		  (lambda (x)
		    (result
		      (s32vector-ref
			(blob->s32vector/shared
			  (u8vector->blob/shared
			    (apply u8vector
				   (reverse ; Endianness!
				     (map char->integer x)))))
			0)))))

; https://docs.oracle.com/javase/tutorial/java/nutsandbolts/datatypes.html
; 64-bit, signed, two's complement integer
; With a little help from protobuf's encoding.scm
(define long (bind (repeated item 8)
		   (lambda (x)
		     (result
		       (let ((n (apply bytes->number x)))
			 (if (positive? (- n #x8000000000000000))
			   (- n #x10000000000000000)
			   n))))))

(define boolean (bind item
		      (lambda (x)
			(result
			  (char->integer x)))))

; Regarding the Java Modified UTF8 Format:
;
; There are two differences between this format and the "standard" UTF-8
; format. First, the null character (char)0 is encoded using the 2-byte format
; rather than the 1-byte format, so that modified UTF-8 strings never have
; embedded nulls. Second, only the 1-byte, 2-byte, and 3-byte formats of
; standard UTF-8 are used. The Java Virtual Machine does not recognize the
; four-byte format of standard UTF-8; it uses its own two-times-three-byte
; format instead.
;   -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.4.7
;
; FIXME: convert from modified java utf8 to regular utf8
(define long-utf (sequence* ((size long)
			     (str (bytes size identity)))

			    (result str)))

; FIXME: convert from modified java utf8 to regular utf8
(define utf (sequence* ((size short)
			(str  (bytes size identity)))

		       (result str)))

(define Throwable
  (lambda (_)
    (s11n4j-abort "Throwable not implemented!")))



; contents:
;   content
;   contents content

(define contents (recursive-parser
		   (one-or-more content)))


; reset:           // The set of known objects is discarded
;                  // so the objects of the exception do not
;                  // overlap with the previously sent objects
;                  // or with objects that may be sent after
;                  // the exception

(define (reset)
  (s11n4j-abort "Reset not implemented!")
  (entities-reset)
  (handle-reset) ; ?
  (result '(reset)))


; values:          // The size and types are described by the
;                  // classDesc for the current object

(define (values* object-field-list)
  (if (null? object-field-list)
    (result '())
    (apply sequence
	   (map ; resolve the typecode of each field into the relevant parser
	     (lambda (field)
	       (typecode-ref
		 (object-field-type-code field)
		 types))
	     object-field-list))))


; TODO: assert that all the values that were read have the type of declared in
;       the array or have the type declared in the array as one of their
;       sub-types.
(define (array-values* class-desc-handle size)
  (let* ((class-desc (entities-ref class-desc-handle))
	 (_          (assert class-desc
			     "Could not find class-description with handle " class-desc-handle))
	 (name       (class-description-name class-desc))
	 (_          (assert (>= (string-length name) 2)
			     "Unexpected class-description name " name))
	 (_          (assert (eqv? #\[ (string-ref name 0))
			     "class-description name does not denote an array " name))
	 (type       (string (string-ref name 1))))

    (if (= 0 size)
      (result '())
      (apply sequence
	     (make-list
	       size
	       (typecode-ref type types))))))


; version
;   STREAM_VERSION

(define version STREAM_VERSION)


; magic:
;   STREAM_MAGIC

(define magic STREAM_MAGIC)


; exception:
;   TC_EXCEPTION reset (Throwable)object	 reset

(define exception (sequence* ((_      TC_EXCEPTION)
			      (_      (reset))
			      (object object)
			      (_      (reset)))

		   (result
		    (list Exception: object)))) ; FIXME


; nullReference
;   TC_NULL

(define nullReference (sequence* ((_ TC_NULL))

				 (result
				   '())))


; prevObject
;   TC_REFERENCE (int)handle

(define prevObject (sequence* ((_      TC_REFERENCE)
			       (handle int))

			      (result handle)))


; enumConstantName:
;   (String)object

(define enumConstantName (recursive-parser
			   (sequence* ((object object))

				      (assert
					(string? (entities-ref object))
					"enumConstantName expected a string but found " object)

				      (result object))))


; newEnum:
;   TC_ENUM classDesc newHandle enumConstantName

(define newEnum (sequence* ((_                TC_ENUM)
			    (classDesc        classDesc)
			    (newHandle        (newHandle))
			    (enumConstantName enumConstantName))

			   (let* ((handle    (handle-value newHandle))
				  (new-enum  (make-enum
					       handle
					       enumConstantName
					       classDesc)))

			     (add-entity! handle new-enum)
			     (result
			       handle))))



; newString:
;   TC_STRING newHandle (utf)
;   TC_LONGSTRING newHandle (long-utf)

(define newString (let ((return (lambda (newHandle utf)
				  (let ((handle (handle-value newHandle))
					(utf    (identity utf)))

				    (add-entity! handle utf)
				    (result
				      handle)))))
		    (any-of
		      (sequence* ((_         TC_STRING)
				  (newHandle (newHandle))
				  (utf       utf))

				 (return newHandle utf))

		      (sequence* ((_ TC_LONGSTRING)
				  (newHandle (newHandle))
				  (long-utf  long-utf))

				 (return newHandle long-utf)))))


;   ( bytes)                // primitive data
;     object

(define externalContent
  (lambda (_)
    (s11n4j-abort "externalContent not implemented!")))


; externalContents:         // externalContent written by
;   externalContent         // writeExternal in PROTOCOL_VERSION_1.
;   externalContents externalContent

(define externalContents (one-or-more externalContent))


; endBlockData	:
;   TC_ENDBLOCKDATA

(define endBlockData (sequence* ((_ TC_ENDBLOCKDATA))

				(result #f)))


; blockdatalong:
;   TC_BLOCKDATALONG (int)<size> (byte)[size]

(define blockdatalong (sequence* ((_     TC_BLOCKDATALONG)
				  (size  int)
				  (bytes (bytes size string->blob)))

				 (result
				   bytes)))


; blockdatashort:
;   TC_BLOCKDATA (unsigned byte)<size> (byte)[size]

(define blockdatashort (sequence* ((_     TC_BLOCKDATA)
				   (size  unsigned-byte)
				   (bytes (bytes size string->blob)))

				  (result
				    bytes)))


; blockdata:
;   blockdatashort
;   blockdatalong

(define blockdata (any-of
		   blockdatashort
		   blockdatalong))


; objectAnnotation:
;   endBlockData
;   contents endBlockData     // contents written by writeObject
;                             // or writeExternal PROTOCOL_VERSION_2.

(define objectAnnotation (any-of
			   endBlockData
			   (sequence* ((contents contents)
				       (_        endBlockData))

				      (result
					contents))))


; nowrclass:
;   values                    // fields in order of class descriptor
;
; Returns a list of fields cons'd up with their fieldDesc signatures.

(define (nowrclass object-field-list)
  (sequence* ((field-values (values* object-field-list)))

	     (result
	       (map cons object-field-list field-values))))


; wrclass:
;   nowrclass

(define wrclass nowrclass)


; classdata:
;   nowrclass                 // SC_SERIALIZABLE & classDescFlag &&
;                             // !(SC_WRITE_METHOD & classDescFlags)
;   wrclass objectAnnotation  // SC_SERIALIZABLE & classDescFlag &&
;                             // SC_WRITE_METHOD & classDescFlags
;   externalContents          // SC_EXTERNALIZABLE & classDescFlag &&
;                             // !(SC_BLOCKDATA  & classDescFlags
;   objectAnnotation          // SC_EXTERNALIZABLE & classDescFlag&&
;                             // SC_BLOCKDATA & classDescFlags
;
; For now we assume that this returns a class-data ADT. In order to completely
; support externalContents we will need the Java class implementation details.

(define (classdata class-description-handle level)
  (let* ((class-description (entities-ref class-description-handle))
	 (fields            (get-field-list class-description-handle level))
	 (flags             (class-description-flags class-description)))
    (assert class-description
	    "Could not find class-description with handle " class-description)

    ; Return the correct parser based on the class-description flags.
    (cond
      ((and (serializable? flags)
	    (not (write-method? flags)))

       (sequence* ((nowrclass (nowrclass fields)))

		  (result
		    (make-class-data nowrclass #f))))


      ((and (serializable? flags)
	    (write-method? flags))

       (sequence* ((wrclass          (wrclass fields))
		   (objectAnnotation objectAnnotation))

		  (result
		    (make-class-data
		      wrclass
		      (make-object-annotation
			class-description-handle
			objectAnnotation)))))


      ((and (externalizable? flags)
	    (not (block-data? flags)))

       externalContents)


      ((and (externalizable? flags)
	    (block-data? flags))

       (sequence* ((objectAnnotation objectAnnotation))

		  (result
		    (make-class-data
		      #f
		      (make-object-annotation
			class-description-handle
			objectAnnotation)))))


      (else
	(s11n4j-abort
	 (sprintf "Could not deserialise classdata for ~S" class-description))))))


; classdata[]:
;
; Reads the classdata for each object in the class hierarchy in turn.

(define (classdatas classDesc)
  (apply
    sequence
    (let ((handles ; The handles of the classDesc and it super-classDescs.
	    (let loop ((handle classDesc)
		       (handles '()))
	      (if (null? handle)
		handles
		(loop
		  (class-description-super (entities-ref handle))
		  (cons handle handles))))))
      (map
	(lambda  (classDesc level)
	  (classdata classDesc level))
	handles
	(reverse (iota (length handles)))))))



; newObject:
;   TC_OBJECT classDesc newHandle classdata[]  // data for each class

(define newObject (sequence* ((_         TC_OBJECT)
			      (classDesc classDesc)
			      (newHandle (newHandle))
			      (classdata (classdatas classDesc)))

			     (assert (map class-data? classdata)
				     "newObject classdata not a class-data ADT: "
				     classdata)

			     (let* ((handle     (handle-value newHandle))
				    (fields     (apply
						  append
						  (map class-data-fields
						       classdata)))
				    (annotation (apply
						  list
						  (map class-data-annotation
						       classdata)))
				    (new-object (make-object
						  handle
						  classDesc
						  fields
						  annotation
						  #f)))

			       (add-entity! handle new-object)
			       (result
				 handle))))


; newArray:
;   TC_ARRAY classDesc newHandle (int)<size> values[size]

(define newArray (sequence* ((_         TC_ARRAY)
			     (classDesc classDesc)
			     (newHandle (newHandle))
			     (size      int)
			     (values*   (array-values* classDesc size)))

			    (let* ((handle (handle-value newHandle))
				   (new-array (make-array
						handle
						classDesc
						size
						values*)))

			      (add-entity! handle new-array)
			      (result
				handle))))


; obj_typecode:
;   `[`	// array
;   `L'	// object

; Create char-seq parsers for each typecode.
(define (types->parsers types)
  (map (cut char-seq <>) (map car types)))

(define typecode-ref (cut alist-ref <> <> equal? <...>))

(define obj_typecode
  (recursive-parser
    (apply any-of (types->parsers obj-types))))


; prim_typecode:
;   `B'	// byte
;   `C'	// char
;   `D'	// double
;   `F'	// float
;   `I'	// integer
;   `J'	// long
;   `S'	// short
;   `Z'	// boolean

(define prim_typecode
  (recursive-parser
    (apply any-of (types->parsers prim-types))))


; classAnnotation:
;   endBlockData
;   contents endBlockData      // contents written by annotateClass

(define classAnnotation (any-of endBlockData
				(sequence* ((contents contents)
					    (_        endBlockData))

					   (result
					     contents))))


; fieldName:
;   (utf)

(define fieldName utf)


; objectDesc:
;   obj_typecode fieldName className1

(define objectDesc (sequence* ((obj_typecode obj_typecode)
			       (fieldName    fieldName)
			       (className1   className1))

			      (result
				(make-class-field
				  obj_typecode
				  className1
				  fieldName))))


; primitiveDesc:
;   prim_typecode fieldName

(define primitiveDesc (sequence* ((prim_typecode prim_typecode)
				  (fieldName     fieldName))

				 (result
				   (make-class-field
				     prim_typecode
				     #f
				     fieldName))))


; fieldDesc:
;   primitiveDesc
;   objectDesc

(define fieldDesc (any-of
		    primitiveDesc
		    objectDesc))

; fields:
;   (short)<count>  fieldDesc[count]

(define fields (sequence* ((count  short)
			   (fields (repeated fieldDesc count)))

			  (result
			    fields)))


; proxyInterfaceName:
;   (utf)

(define proxyInterfaceName utf)

; proxyClassDescInfo:
;   (int)<count> proxyInterfaceName[count] classAnnotation
;       superClassDesc

(define proxyClassDescInfo (sequence* ((count int)
				       (proxyInterfaceName (repeated proxyInterfaceName count))
				       (classAnnotation    classAnnotation)
				       (superClassDesc     superClassDesc))

				      (result
					(list count proxyInterfaceName classAnnotation superClassDesc))))


; classDescFlags:
;   (byte)                  // Defined in Terminal Symbols and
;                           // Constants

(define classDescFlags byte)


; serialVersionUID:
;   (long)

(define serialVersionUID long)


; className:
;   (utf)

(define className utf)


; classDescInfo:
;   classDescFlags fields classAnnotation superClassDesc

(define classDescInfo (sequence* ((classDescFlags  classDescFlags)
				  (fields          fields)
				  (classAnnotation classAnnotation)
				  (superClassDesc  superClassDesc))

				 (result
				   (list classDescFlags fields classAnnotation superClassDesc))))

; newClassDesc:
;   TC_CLASSDESC className serialVersionUID newHandle classDescInfo
;   TC_PROXYCLASSDESC newHandle proxyClassDescInfo

(define newClassDesc (any-of
		       (sequence* ((_                TC_CLASSDESC)
				   (className        className)
				   (serialVersionUID serialVersionUID)
				   (newHandle        (newHandle))
				   (classDescInfo    classDescInfo))

				  (let* ((flags      (first  classDescInfo))
					 (fields     (second classDescInfo))
					 (annotation (third  classDescInfo))
					 (super      (fourth classDescInfo))
					 (handle     (handle-value newHandle)))

				    (let ((new-class (make-class-description
						       handle
						       className
						       serialVersionUID
						       flags
						       fields
						       annotation
						       super)))

				      (add-entity! handle new-class)
				      (result
					(class-description-handle
					  new-class)))))

		       (sequence* ((_                  TC_PROXYCLASSDESC)
				   (newHandle          (newHandle))
				   (proxyClassDescInfo proxyClassDescInfo))

				  (s11n4j-abort
				   (sprintf "Got a TC_PROXYCLASSDESC that we don't yet have a high-level description for: ~S" proxyClassDescInfo))

				  (result
				    (list newHandle proxyClassDescInfo)))))


; classDesc:
;   newClassDesc
;   nullReference
;   (ClassDesc)prevObject      // an object required to be of type
;                              // ClassDesc

(define classDesc (any-of
		    newClassDesc
		    nullReference

		    ; (ClassDesc)prevObject
		    (sequence* ((prevObject prevObject))

			       (assert
				 (class-description? (entities-ref prevObject))
				 "classDesc expected a class-description but found " prevObject)

			       (result prevObject))))


; superClassDesc:
;   classDesc

(define superClassDesc (recursive-parser classDesc))


; newClass:
;   TC_CLASS classDesc newHandle

(define newClass (sequence* ((_         TC_CLASS)
			     (classDesc classDesc)
			     (newHandle (newHandle)))

			    (result
			      (cons classDesc newHandle))))


; object:
;   newObject
;   newClass
;   newArray
;   newString
;   newEnum
;   newClassDesc
;   prevObject
;   nullReference
;   exception
;   TC_RESET

(define object (any-of
		 newObject
		 newClass
		 newArray
		 newString
		 newEnum
		 newClassDesc
		 prevObject
		 nullReference
		 exception
		 TC_RESET))


; className1:
;   (String)object             // String containing the field's type,
;                              // in field descriptor format

(define className1 (sequence* ((object object))

			      (assert
				(string? (entities-ref object))
				"className1 expected a string but found " object)

			      (result object)))


; obj_typecode:
;   `[`	// array
;   `L'	// object

(define obj-types
  `(("[" . ,object)
    ("L" . ,object)))


; prim_typecode:
;   `B'	// byte
;   `C'	// char
;   `D'	// double
;   `F'	// float
;   `I'	// integer
;   `J'	// long
;   `S'	// short
;   `Z'	// boolean

(define prim-types
  `(("B" . ,byte)
    ("C" . ,char)
    ("D" . ,double)
    ("F" . ,float)
    ("I" . ,int)
    ("J" . ,long)
    ("S" . ,short)
    ("Z" . ,boolean)))


(define types (append obj-types prim-types))


; stream:

; content:
;   object
;   blockdata

(define content (any-of
		  object
		  blockdata))


; stream:
(define stream (sequence* ((_        magic)
			   (_        version)
			   (contents contents))

			  (result
			    contents)))








;;;;;;;;;;


(define (deserialize str-port-etc)
  (parameterize ((current-handle baseWireHandle)
		 (entities       '()))
		(receive (entity-list rest) (parse stream str-port-etc)
			 (assert
			   (parser-input-end? rest)
			   "s11n4j deserialization did not consume entire input" rest)
			 (values entity-list (entities)))))


(define (zinger parser #!optional input)
  (with-input-from-file "blobs/B_fna_fna_AMAZON-EC2_c3-large_jason_test"
   (lambda ()
     (parse parser (read-string #f (current-input-port))))))

(define (nuts . x)
 (receive (a b) (apply (car x) (cdr x))
  (values b a)))

)