;; -*- 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 ((appender accessor mutator) msg v)
  (mutator msg (append (accessor msg '()) (if (list? v) v (list v)))))

(define (deserialize type #!optional [port (current-input-port)])
  (let ([info (prop:protobuf #f type)])
    (letrec ([msg ((message-info-constructor info))]
             [fields (message-info-fields info)]
             [required (hash-table-copy (message-info-required info))]
             [unknown (open-output-string)])
      (let loop ()
        (let-values ([(tag type) (read-tag/type port)])
          (unless (or (eof-object? tag) (eof-object? type))
            (hash-table-delete! required tag)
            (cond
              [(hash-table-ref/default fields tag #f)
               => (lambda (field)
                    (let* ([ftype (field-info-type field)]
                           [repeated? (field-info-repeated? field)]
                           [accessor (field-info-accessor field)]
                           [mutator (field-info-mutator field)]
                           [updator
                            (if repeated?
                                (appender accessor mutator)
                                mutator)])
                      (cond
                       [(primitive-info? ftype)
                        (let ([ptype (primitive-info-type ftype)]
                              [read (primitive-info-reader ftype)])
                          (updator
                           msg
                           (cond
                            [(eq? type ptype)
                             (read port)]
                            [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized)))
                             (read-sized (cut read-list <> read) port)]
                            [else
                             (syntax-error 'deserialize "wire type does not match declared type" type)])))]
                       [(enum-info? ftype)
                        (let ([integer->enum (enum-info-integer->enum ftype)])
                          (updator
                           msg
                           (cond
                            [(eq? type 'int*)
                             (integer->enum (read-int* port))]
                            [(and repeated? (eq? type 'sized))
                             (map integer->enum
                                  (read-sized (cut read-list <> read-int*) port))]
                            [else
                             (syntax-error 'deserialize "wire type does not match declared type" type)])))]
                       [(rtd? ftype)
                        (updator
                         msg
                         (cond
                          [(eq? type 'sized)
                           (read-sized (cut deserialize ftype <>) port)]
                          [else
                           (syntax-error 'deserialize "wire type does not match declared type" type)]))])))]
              [else
               (write-tag/type tag type unknown)
               (case type
                 [(int*)
                  (write-uint* (read-uint* port) unknown)]
                 [(64bit)
                  (copy-port (make-limited-input-port port 8 #f) unknown)]
                 [(32bit)
                  (copy-port (make-limited-input-port port 4 #f) unknown)]
                 [(sized)
                  (let ([size (read-uint* port)])
                    (write-uint* size unknown)
                    (copy-port (make-limited-input-port port size #f) unknown))])])
            (loop))))
      (message-unknown-set! msg (get-output-string unknown))
      (unless (zero? (hash-table-size required))
        (syntax-error 'deserialize "missing required fields" (hash-table-keys required)))
      msg)))

(define (serialize msg #!optional [port (current-output-port)])
  (let ([info (prop:protobuf msg)])
    (let ([fields (message-info-fields info)]
          [required (hash-table-copy (message-info-required info))])
      (hash-table-walk
       fields
       (lambda (tag field)
         (let ([vs ((field-info-accessor field) msg void)])
           (unless (eq? vs (void))
             (let ([repeated? (field-info-repeated? field)]
                   [packed? (field-info-packed? field)])
               (for-each
                (lambda (v)
                  (hash-table-delete! required tag)
                  (let ([ftype (field-info-type field)])
                    (cond
                     [(primitive-info? ftype)
                      (let ([ptype (primitive-info-type ftype)]
                            [write (primitive-info-writer ftype)])
                        (cond
                         [(and repeated? packed?)
                          (when (eq? ptype 'sized)
                            (error 'serialize "cannot apply packed encoding to sized type"))
                          (write-tag/type tag 'sized port)
                          (write-sized
                           (cut for-each write <> <>) vs port)]
                         [else
                          (write-tag/type tag ptype port)
                          (write v port)]))]
                     [(enum-info? ftype)
                      (let ([enum->integer (enum-info-enum->integer ftype)])
                        (cond
                         [(and repeated? packed?)
                          (write-tag/type tag 'sized port)
                          (write-sized
                           (cut for-each write-int* <> <>) (map enum->integer vs) port)]
                         [else
                          (write-tag/type tag 'int* port)
                          (write-int* (enum->integer v) port)]))]
                     [else
                      (write-tag/type tag 'sized port)
                      (write-sized serialize v port)])))
                (if (and repeated? (not packed?)) vs (list vs))))))))
      (write-string (message-unknown msg) #f port)
      (unless (zero? (hash-table-size required))
        (syntax-error 'serialize "missing required fields" (hash-table-keys required))))))

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