;; -*- mode: Scheme; -*-
;;
;; This file is part of Protocol Buffers for CHICKEN
;; Copyright (c) 2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(define-record-type (serialization-context
                     #:uid 'protobuf:serialization-context
                     #:opaque #t #:sealed #t)
  #f #t
  obj->ref
  ref->obj)

(define current-serialization-context
  (make-parameter #f))

(define make-serialization-context
  (let ([make-serialization-context* (rtd-constructor serialization-context)])
    (lambda vs
      (let* ([obj->ref (make-hash-table eq? eq?-hash)]
             [ref->obj (make-hash-table eqv? eqv?-hash)]
             [context (make-serialization-context* obj->ref ref->obj)])
        (do-ec (:list v (index ref) (cons context vs))
          (begin
            (hash-table-set! obj->ref v ref)
            (hash-table-set! ref->obj ref v)))
        context))))

(define (serialization-context-rememberer context)
  (let ([obj->ref (serialization-context-obj->ref context)]
        [ref->obj (serialization-context-ref->obj context)])
    (lambda (v)
      (or (hash-table-ref/default obj->ref v #f)
          (let ([ref (hash-table-size ref->obj)])
            (hash-table-set! obj->ref v ref)
            (hash-table-set! ref->obj ref v)
            #f)))))

(define-record-property prop:serialization-info
  #f)

(define-record-type (serialization-info
                     #:uid 'protobuf:serialization-info)
  #t #t
  reader writer)

(define %procedure-id
  (foreign-lambda* c-string ([scheme-object proc])
    "C_return(C_lookup_procedure_id((void *) C_block_item(proc, 0)));"))

(define %procedure-id-set!
  (foreign-lambda* bool ([scheme-object proc] [c-string id])
    "void *addr = C_lookup_procedure_ptr(id);"
    "if (addr) {"
    "  C_set_block_item(proc, 0, (C_word) addr);"
    "  C_vector_to_closure(proc);"
    "  C_return(1);"
    "} else {"
    "  C_return(0);"
    "}"))

(define (serialize v #!optional [port (current-output-port)] [context (current-serialization-context)])
  (define remember!
    void)

  (define (write-real v port)
    (if (exact? v)
        (let ([numer (numerator v)]
              [denom (denominator v)])
          (unless (zero? numer)
            (write-tag/type 1 'int* port)
            (write-sint* numer port #f))
          (unless (= 1 denom)
            (write-tag/type 2 'int* port)
            (write-sint* denom port #f)))
        (begin
          (write-tag/type 3 '64bit port)
          (write-double v port))))

  (define (write-complex v port)
    (let ([real (real-part v)]
          [imag (imag-part v)])
      (unless (zero? real)
        (write-tag/type 1 'sized port)
        (write-sized write-real real port))
      (unless (zero? imag)
        (write-tag/type 2 'sized port)
        (write-sized write-real imag port))))

  (define (write-keyword v port)
    (write-tag/type 1 'sized port)
    (write-sized-string (symbol->string v) port)
    (write-tag/type 2 'int* port)
    (write-int* 3 port))

  (define (write-symbol v port)
    (write-tag/type 1 'sized port)
    (write-sized-string (symbol->string v) port)
    (write-tag/type 2 'int* port)
    (write-int* (if (##sys#interned-symbol? v) 1 2) port))

  (define (write-pair v port)
    (write-tag/type 1 'sized port)
    (write-sized write-value (car v) port)
    (write-tag/type 2 'sized port)
    (write-sized write-value (cdr v) port))

  (define ((write-block i0) block port)
    (do-ec (:range i i0 (##sys#size block))
      (begin
        (write-tag/type 1 'sized port)
        (write-sized write-value (##sys#slot block i) port))))

  (define write-vector
    (write-block 0))

  (define (write-hash-table v port)
    (let ([v (hash-table-equivalence-function v)])
      (unless (eq? v equal?)
        (write-tag/type 2 'sized port)
        (write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)
        (write-sized write-value v port)))
    (let ([v (hash-table-min-load v)])
      (unless (= v 0.5)
        (write-tag/type 4 '64bit port)
        (write-double v port)))
    (let ([v (hash-table-max-load v)])
      (unless (= v 0.8)
        (write-tag/type 5 '64bit port)
        (write-double v port)))
    (let ([v (hash-table-weak-keys v)])
      (when v
        (write-tag/type 6 'int* port)
        (write-bool v port)))
    (let ([v (hash-table-weak-values v)])
      (when v
        (write-tag/type 7 'int* port)
        (write-bool v port)))
    (let ([v (hash-table-initial v)])
      (when v
        (write-tag/type 8 'sized port)
        (write-sized write-value v port)))
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k v) port))))

  (define write-procedure
    (let ([write-upvalues (write-block 1)])
      (lambda (v port)
        (write-tag/type 2 'sized port)
        (write-sized-string (%procedure-id v) port)
        (write-upvalues v port))))

  (define ((write-custom info) v port)
    (let ([reader (serialization-info-reader info)])
      (unless (eq? reader read)
        (write-tag/type 2 'sized port)
        (write-sized write-value reader port)))
    (write-tag/type 1 'sized port)
    (write-sized (serialization-info-writer info) v port))

  (define (write-value v port)
    (cond
     [(eq? v (void))
      (write-tag/type 1 'int* port)
      (write-int* 1 port)]
     [(null? v)
      (write-tag/type 1 'int* port)
      (write-int* 2 port)]
     [(eof-object? v)
      (write-tag/type 1 'int* port)
      (write-int* 3 port)]
     [(eq? v #f)
      (write-tag/type 1 'int* port)
      (write-int* 4 port)]
     [(eq? v #t)
      (write-tag/type 1 'int* port)
      (write-int* 5 port)]
     [(char? v)
      (write-tag/type 2 'int* port)
      (write-int* (char->integer v) port)]
     [(fixnum? v)
      (write-tag/type 3 'int* port)
      (write-sint* v port)]

     [(remember! v)
      => (lambda (ref)
           (write-tag/type 15 'int* port)
           (write-uint* ref port))]

     [(number? v)
      (write-tag/type 5 'sized port)
      (write-sized write-complex v port)]
     [(string? v)
      (write-tag/type 6 'sized port)
      (write-sized-string v port)]
     [(keyword? v)
      (write-tag/type 7 'sized port)
      (write-sized write-keyword v port)]
     [(symbol? v)
      (write-tag/type 7 'sized port)
      (write-sized write-symbol v port)]
     [(pair? v)
      (write-tag/type 8 'sized port)
      (write-sized write-pair v port)]
     [(vector? v)
      (write-tag/type 9 'sized port)
      (write-sized write-vector v port)]
     [(hash-table? v)
      (write-tag/type 10 'sized port)
      (write-sized write-hash-table v port)]

     [(procedure? v)
      (write-tag/type 11 'sized port)
      (write-sized write-procedure v port)]
     [(##core#inline "C_lambdainfop" v)
      (write-tag/type 12 'sized port)
      (write-sized-string (##sys#lambda-info->string v) port)]

     [(u8vector? v)
      (write-tag/type 16 'sized port)
      (write-sized-bytes v port)]
     [(s8vector? v)
      (write-tag/type 17 'sized port)
      (write-sized-bytes (blob->u8vector/shared (s8vector->blob/shared v)) port)]
     [(u16vector? v)
      (write-tag/type 18 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:u16vector v block) (write-uint* v port)))
       v port)]
     [(s16vector? v)
      (write-tag/type 19 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:s16vector v block) (write-sint* v port)))
       v port)]
     [(u32vector? v)
      (write-tag/type 20 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:u32vector v block) (write-uint* v port)))
       v port)]
     [(s32vector? v)
      (write-tag/type 21 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:s32vector v block) (write-sint* v port)))
       v port)]
     [(u64vector? v)
      (write-tag/type 22 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:u64vector v block) (write-uint* v port)))
       v port)]
     [(s64vector? v)
      (write-tag/type 23 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:s64vector v block) (write-sint* v port)))
       v port)]
     [(f32vector? v)
      (write-tag/type 24 'sized port)
      (write-sized-bytes (blob->u8vector/shared (f32vector->blob/shared v)) port)]
     [(f64vector? v)
      (write-tag/type 25 'sized port)
      (write-sized-bytes (blob->u8vector/shared (f64vector->blob/shared v)) port)]
     [(blob? v)
      (write-tag/type 26 'sized port)
      (write-sized-bytes (blob->u8vector/shared v) port)]

     [(record? v)
      (cond
       [(prop:serialization-info v)
        => (lambda (info)
             (write-tag/type 13 'sized port)
             (write-sized (write-custom info) v port))]
       [else
        (write-tag/type 14 'sized port)
        (write-sized write-vector v port)])]

     [else
      (error 'serialize "cannot serialize value" v)]))

  (unless context
    (set! context
      (make-serialization-context
       (current-input-port) (current-output-port) (current-error-port))))
  (set! remember!
    (serialization-context-rememberer context))
  (parameterize ([current-serialization-context context])
    (write-value v port)))

(define (ensure-type expected actual value)
  (unless (eq? expected actual)
    (syntax-error
     'deserialize (string-append "bad wire type for " value)
     actual)))

(define (reverse!/length tail)
  (let next ([head '()] [tail tail] [length 0])
    (if (pair? tail)
        (let ([rest (cdr tail)])
          (set-cdr! tail head)
          (next tail rest (fx+ length 1)))
        (values head length))))

(define-record-type (hash-table-dummy
                     #:opaque #t #:sealed #t)
  #t #t
  test hash
  min-load max-load
  weak-keys weak-values
  initial size slots)

(define-record-type (custom-dummy
                     #:opaque #t #:sealed #t)
  #t #f
  data reader)

(define (deserialize #!optional [port (current-input-port)] [context (current-serialization-context)])
  (define remember!
    void)

  (define (read-real port)
    (let more ([v 1])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'int* type "numerator")
           (more (* v (read-sint* port #f)))]
          [(2)
           (ensure-type 'int* type "denominator")
           (more (/ v (read-sint* port #f)))]
          [(3)
           (ensure-type '64bit type "flonum")
           (more (read-double port))]
          [(#!eof)
           v]
          [else
           (syntax-error 'deserialize "unknown real part" tag)]))))

  (define (read-complex port)
    (let more ([real 0] [imag 0])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'sized type "real part")
           (more (read-sized read-real port) imag)]
          [(2)
           (ensure-type 'sized type "imaginary part")
           (more real (read-sized read-real port))]
          [(#!eof)
           (make-rectangular real imag)]
          [else
           (syntax-error 'deserialize "unknown complex part" tag)]))))

  (define (read-symbol port)
    (let more ([id #f] [import-symbol string->symbol])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'sized type "symbol id")
           (more (read-sized-string port) import-symbol)]
          [(2)
           (ensure-type 'int* type "symbol type")
           (let ([tag (read-int* port)])
             (case tag
               [(1) (more id string->symbol)]
               [(2) (more id string->uninterned-symbol)]
               [(3) (more id string->keyword)]
               [else (syntax-error 'deserialize "unknown symbol type" tag)]))]
          [(#!eof)
           (if id
               (import-symbol id)
               (syntax-error 'deserialize "missing symbol id"))]
          [else
           (syntax-error 'deserialize "unknown symbol part" tag)]))))

  (define ((read-pair! v) port)
    (let more ()
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'sized type "car")
           (set-car! v (read-sized read-value port))
           (more)]
          [(2)
           (ensure-type 'sized type "cdr")
           (set-cdr! v (read-sized read-value port))
           (more)]
          [(#!eof)
           v]
          [else
           (syntax-error 'deserialize "unknown pair part" tag)]))))

  (define ((read-block read-special make-block) port)
    (let more ([slots '()] [specials '()])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'sized type "slot")
           (more (cons (read-sized-string port) slots) specials)]
          [(#!eof)
           (let-values ([(slots length) (reverse!/length slots)])
             (apply make-block length slots specials))]
          [else
           (let-values ([special (read-special tag type port)])
             (more slots (append special specials)))]))))

  (define ((decode-block! i0) v)
    (do-ec (:range i i0 (##sys#size v))
      (##sys#setslot v i (call-with-input-string (##sys#slot v i) read-value)))
    v)

  (define read-vector*
    (read-block
     (lambda (tag type port)
       (syntax-error 'deserialize "unknown vector part" tag))
     (lambda (n slots)
       (vector-of-length-ec n (:list s slots) s))))

  (define decode-vector!
    (decode-block! 0))

  (define read-hash-table*
    (read-block
     (lambda (tag type port)
       (case tag
         [(2)
          (ensure-type 'sized type "equality function")
          (values #:test (read-sized-string port))]
         [(3)
          (ensure-type 'sized type "hash function")
          (values #:hash (read-sized-string port))]
         [(4)
          (ensure-type '64bit type "minimum load factor")
          (values #:min-load (read-double port))]
         [(5)
          (ensure-type '64bit type "maximum load factor")
          (values #:max-load (read-double port))]
         [(6)
          (ensure-type 'int* type "weak keys flag")
          (values #:weak-keys (read-bool port))]
         [(7)
          (ensure-type 'int* type "weak values flag")
          (values #:weak-values (read-bool port))]
         [(8)
          (ensure-type 'sized type "initial value")
          (values #:initial (read-sized-string port))]
         [else
          (syntax-error 'deserialize "unknown hash table part" tag)]))
     (lambda (n slots #!key test hash [min-load 0.5] [max-load 0.8] weak-keys weak-values initial)
       (if (or test hash initial)
           (make-hash-table-dummy
            test hash min-load max-load weak-keys weak-values initial
            n slots)
           (alist->hash-table
            (list (cons 'slots slots))
            #:min-load min-load #:max-load max-load
            #:weak-keys weak-keys #:weak-values weak-values
            #:size n)))))

  (define (decode-hash-table! v)
    (let ([slots
           (if (hash-table-dummy? v)
               (let* ([test
                       (cond
                        [(hash-table-dummy-test v) => decode-value]
                        [else equal?])]
                      [hash
                       (cond
                        [(hash-table-dummy-hash v) => decode-value]
                        [else equal?-hash])]
                      [min-load
                       (hash-table-dummy-min-load v)]
                      [max-load
                       (hash-table-dummy-max-load v)]
                      [weak-keys
                       (hash-table-dummy-weak-keys v)]
                      [weak-values
                       (hash-table-dummy-weak-values v)]
                      [initial
                       (cond
                        [(hash-table-dummy-initial v) => decode-value]
                        [else #f])]
                      [size
                       (hash-table-dummy-size v)]
                      [slots
                       (hash-table-dummy-slots v)])
                 (object-become!
                  (list
                   (cons
                    v
                    (make-hash-table
                     #:test test #:hash hash
                     #:min-load min-load #:max-load max-load
                     #:weak-keys weak-keys #:weak-values weak-values
                     #:initial initial #:size size))))
                 slots)
               (let ([slots (hash-table-ref v 'slots)])
                 (hash-table-delete! v 'slots)
                 slots))])
      (do-ec (:list s slots)
        (let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))])
          (hash-table-set! v (car k+v) (cdr k+v)))))
    v)

  (define read-procedure*
    (read-block
     (lambda (tag type port)
       (case tag
         [(2)
          (ensure-type 'sized type "procedure id")
          (read-sized-string port)]
         [else
          (syntax-error 'deserialize "unknown procedure part" tag)]))
     (lambda (n slots #!optional id)
       (let ([v (##sys#allocate-vector (fx+ n 1) #f (void) #f)])
         (unless (%procedure-id-set! v id)
           (syntax-error 'deserialize "invalid procedure id" id))
         (do-ec (:list s (index i) slots) (##sys#setslot v (fx+ i 1) s))
         v))))

  (define decode-procedure!
    (decode-block! 1))

  (define read-custom*
    (read-block
     (lambda (tag type port)
       (case tag
         [(2)
          (ensure-type 'sized type "custom reader")
          (read-sized-string port)]
         [else
          (syntax-error 'deserialize "unknown custom value part" tag)]))
     (lambda (n data #!optional reader)
       (make-custom-dummy (string-concatenate data) reader))))

  (define (decode-custom! v)
    (object-become!
     (list
      (cons
       v
       (call-with-input-string
        (custom-dummy-data v)
        (cond
         [(custom-dummy-reader v) => decode-value]
         [else read])))))
    v)

  (define read-record*
    (read-block
     (lambda (tag type port)
       (syntax-error 'deserialize "unknown record part" tag))
     (lambda (n slots #!optional id)
       (let ([v (##sys#allocate-vector n #f (void) #f)])
         (##core#inline "C_vector_to_structure" v)
         (do-ec (:list s (index i) slots) (##sys#setslot v i s))
         v))))

  (define (read-value port)
    (let-values ([(tag type) (read-tag/type port)])
      (case tag
        [(1)
         (ensure-type 'int* type "special value")
         (let ([tag (read-int* port)])
           (case tag
             [(1) (void)]
             [(2) '()]
             [(3) #!eof]
             [(4) #f]
             [(5) #t]
             [else (syntax-error 'deserialize "unknown special value" tag)]))]
        [(2)
         (ensure-type 'int* type "char")
         (integer->char (read-int* port))]
        [(3)
         (ensure-type 'int* type "fixnum")
         (read-sint* port)]

        [(5)
         (ensure-type 'sized type "number")
         (remember! (read-sized read-complex port))]
        [(6)
         (ensure-type 'sized type "string")
         (remember! (read-sized-string port))]
        [(7)
         (ensure-type 'sized type "symbol")
         (remember! (read-sized read-symbol port))]

        [(8)
         (ensure-type 'sized type "pair")
         (read-sized (read-pair! (remember! (cons #f #f))) port)]
        [(9)
         (ensure-type 'sized type "vector")
         (decode-vector! (remember! (read-sized read-vector* port)))]
        [(10)
         (ensure-type 'sized type "hash table")
         (decode-hash-table! (remember! (read-sized read-hash-table* port)))]

        [(11)
         (ensure-type 'sized type "procedure")
         (decode-procedure! (remember! (read-sized read-procedure* port)))]
        [(12)
         (ensure-type 'sized type "lambda info")
         (remember! (##sys#make-lambda-info (read-sized-string port)))]

        [(16)
         (ensure-type 'sized type "u8vector")
         (remember! (read-sized-bytes port))]
        [(17)
         (ensure-type 'sized type "s8vector")
         (remember! (blob->s8vector/shared (u8vector->blob/shared (read-sized-bytes port))))]
        [(18)
         (ensure-type 'sized type "u16vector")
         (remember!
          (read-sized
           (lambda (port)
             (u16vector-ec (:port v port read-uint*) v))
           port))]
        [(19)
         (ensure-type 'sized type "s16vector")
         (remember!
          (read-sized
           (lambda (port)
             (s16vector-ec (:port v port read-sint*) v))
           port))]
        [(20)
         (ensure-type 'sized type "u32vector")
         (remember!
          (read-sized
           (lambda (port)
             (u32vector-ec (:port v port read-uint*) v))
           port))]
        [(21)
         (ensure-type 'sized type "s32vector")
         (remember!
          (read-sized
           (lambda (port)
             (s32vector-ec (:port v port read-sint*) v))
           port))]
        [(22)
         (ensure-type 'sized type "u64vector")
         (remember!
          (read-sized
           (lambda (port)
             (u64vector-ec (:port v port read-uint*) v))
           port))]
        [(23)
         (ensure-type 'sized type "s64vector")
         (remember!
          (read-sized
           (lambda (port)
             (s64vector-ec (:port v port read-sint*) v))
           port))]
        [(24)
         (ensure-type 'sized type "f32vector")
         (remember!
          (blob->f32vector/shared
           (u8vector->blob/shared (read-sized-bytes port))))]
        [(25)
         (ensure-type 'sized type "f64vector")
         (remember!
          (blob->f64vector/shared
           (u8vector->blob/shared (read-sized-bytes port))))]
        [(26)
         (ensure-type 'sized type "blob")
         (remember!
          (u8vector->blob/shared (read-sized-bytes port)))]

        [(13)
         (ensure-type 'sized type "custom value")
         (decode-custom! (remember! (read-sized read-custom* port)))]
        [(14)
         (ensure-type 'sized type "record")
         (decode-vector! (remember! (read-sized read-record* port)))]
        [(15)
         (ensure-type 'int* type "shared structure")
         (let ([tag (read-uint* port)])
           (hash-table-ref
            (serialization-context-ref->obj context) tag
            (lambda ()
              (syntax-error 'deserialize "unknown shared structure" tag))))]

        [(#!eof)
         tag]
        [else
         (syntax-error 'deserialize "unknown value type" tag)])))

  (define decode-value
    (cut call-with-input-string <> read-value))

  (unless context
    (set! context
      (make-serialization-context
       (current-input-port) (current-output-port) (current-error-port))))
  (set! remember!
    (let ([rememberer (serialization-context-rememberer context)])
      (lambda (v)
        (rememberer v)
        v)))
  (parameterize ([current-serialization-context context])
    (read-value port)))

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;