protobuf

Copyright (C) 2011-2013 Thomas Chust <chust@web.de>.  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.

;; -*- 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 (make-limited-input-port in limit close-orig?)
  (make-input-port
   #;read
   (lambda ()
     (if (fx> limit 0)
	 (begin
	   (set! limit (fx- limit 1))
	   (read-char in))
	 #!eof))
   #;ready?
   (lambda ()
     (and (fx> limit 0)
	  (char-ready? in)))
   #;close
   (lambda ()
     (if close-orig?
	 (close-input-port in)
	 (void)))
   #;peek
   (lambda ()
     (if (fx> limit 0)
	 (peek-char in)
	 #!eof))))

(define (read-uint* #!optional [port (current-input-port)] [max-size 10])
  (let loop ([span 0])
    (if (and max-size (>= span max-size))
	(syntax-error 'read-uint* "maximum integer size exceeded" max-size)
	(let ((b (read-byte port)))
	  (if (and (not (eof-object? b)) (bit-set? b 7))
	      (+ (bitwise-and b #x7f)
		 (* 128 (loop (add1 span))))
	      b)))))

(define (write-uint* n #!optional [port (current-output-port)] [max-size 10])
  (let loop ([n n] [span 0])
    (if (and max-size (>= span max-size))
	(syntax-error 'write-uint* "maximum integer size exceeded" max-size)
        (let*-values ([(r b) (quotient&remainder n 128)]
                      [(last?) (zero? r)])
          (write-byte (if last? b (bitwise-ior #x80 b)) port)
	  (unless last? (loop r (add1 span)))))))

(define (read-sint* #!optional [port (current-input-port)] [max-size 10])
  (let ([z (read-uint* port max-size)])
    (if (eof-object? z)
        z
        (/ (if (odd? z) (- -1 z) z)
           2))))

(define (write-sint* i #!optional [port (current-output-port)] [max-size 10])
  (let ([2i (* 2 i)])
    (write-uint* (if (negative? i) (- -1 2i) 2i) port max-size)))

(define (read-int* #!optional [port (current-input-port)])
  (let ([n (read-uint* port)])
    (if (eof-object? n)
	n
        (if (positive? (- n #x8000000000000000))
            (- n #x10000000000000000)
            n))))

(define (write-int* i #!optional [port (current-output-port)])
  (write-uint* (if (negative? i) (+ i #x10000000000000000) i) port))

(define (read-bool #!optional [port (current-input-port)])
  (let ([n (read-uint* port)])
    (if (eof-object? n) n (not (zero? n)))))

(define (write-bool v #!optional [port (current-output-port)])
  (write-uint* (if v 1 0) port))

(define ((read-fixed* size signed?) #!optional [port (current-input-port)])
  (let ([bstr (read-u8vector size port)])
    (if (eof-object? bstr)
        bstr
        (let ([span (u8vector-length bstr)])
          (if (< span size)
              (syntax-error 'read-fixed* "found truncated fixed integer bytes")
	      (let ([unsigned
		     (sum-ec (:u8vector b (index i) bstr)
		       (arithmetic-shift b (fx* i 8)))])
		(if (and signed? (bit-set? unsigned (fx- (fx* size 8) 1)))
		    (- unsigned (arithmetic-shift 1 (fx* size 8)))
		    unsigned)))))))

(define read-fixed32
  (read-fixed* 4 #f))
(define read-fixed64
  (read-fixed* 8 #f))
(define read-sfixed32
  (read-fixed* 4 #t))
(define read-sfixed64
  (read-fixed* 8 #t))

(define ((write-fixed* size signed?) n #!optional [port (current-output-port)])
  (let* ([unsigned
	  (if (and signed? (negative? n))
	      (+ (arithmetic-shift 1 (fx* size 8)) n)
	      n)]
	 [bstr
	  (u8vector-of-length-ec size (:range i size)
	    (bitwise-and (arithmetic-shift unsigned (fx* i -8)) #xff))])
    (write-u8vector bstr port)))

(define write-fixed32
  (write-fixed* 4 #f))
(define write-fixed64
  (write-fixed* 8 #f))
(define write-sfixed32
  (write-fixed* 4 #t))
(define write-sfixed64
  (write-fixed* 8 #t))

(define ((read-float* size) #!optional [port (current-input-port)])
  (let ([bstr (read-u8vector size port)])
    (if (eof-object? bstr)
        bstr
        (let ([span (u8vector-length bstr)])
          (cond
	   ((< span size)
	    (syntax-error 'read-float* "found truncated fixed floating point bytes"))
	   ((= size 8)
	    (f64vector-ref (blob->f64vector/shared (u8vector->blob/shared bstr)) 0))
	   ((= size 4)
	    (f32vector-ref (blob->f32vector/shared (u8vector->blob/shared bstr)) 0))
	   (else
	    (error 'read-float* "only 64-bit and 32-bit floating point values are supported")))))))

(define read-float
  (read-float* 4))
(define read-double
  (read-float* 8))

(define ((write-float* size) x #!optional [port (current-output-port)])
  (write-u8vector
   (blob->u8vector/shared
    (cond
     ((= size 8)
      (f64vector->blob/shared (f64vector x)))
     ((= size 4)
      (f32vector->blob/shared (f32vector x)))
     (else
      (error 'write-float* "only 64-bit and 32-bit floating point values are supported"))))
   port))

(define write-float
  (write-float* 4))
(define write-double
  (write-float* 8))

(define (read-sized-bytes #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([bstr (read-u8vector size port)])
          (if (or (eof-object? bstr) (< (string-length bstr) size))
	      (syntax-error 'read-sized-bytes "found truncated bytes")
              bstr)))))

(define (write-sized-bytes bstr #!optional [port (current-output-port)])
  (write-uint* (u8vector-length bstr) port)
  (write-u8vector bstr port))

(define (read-sized-string #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([bstr (read-string size port)])
          (if (or (eof-object? bstr) (< (string-length bstr) size))
	      (syntax-error 'read-sized-string "found truncated bytes")
              bstr)))))

(define (write-sized-string bstr #!optional [port (current-output-port)])
  (write-uint* (string-length bstr) port)
  (write-string bstr #f port))

(define (read-sized read #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([v (read (make-limited-input-port port size #f))])
          (if (eof-object? v)
	      (syntax-error 'read-sized "found truncated data")
              v)))))

(define (write-sized write v #!optional [port (current-output-port)])
  (let ([bstr (call-with-output-string (cut write v <>))])
    (write-uint* (string-length bstr) port)
    (write-string bstr #f port)))

(define (read-tag/type #!optional [port (current-input-port)])
  (let ([tag/type (read-uint* port)])
    (if (eof-object? tag/type)
        (values tag/type
                tag/type)
        (values (arithmetic-shift tag/type -3)
                (let ([type (bitwise-and tag/type #b111)])
                  (case type
                    [(0) 'int*]
                    [(1) '64bit]
                    [(5) '32bit]
                    [(2) 'sized]
                    [else (syntax-error 'read-tag/type "found unknown field type" type)]))))))

(define (write-tag/type tag type #!optional [port (current-output-port)])
  (write-uint*
   (bitwise-ior
    (arithmetic-shift tag 3)
    (case type
      [(int*) 0]
      [(64bit) 1]
      [(32bit) 5]
      [(sized) 2]))
   port))

// 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.
package extend.protobuf;

import "google/protobuf/descriptor.proto";

extend google.protobuf.FieldOptions {
  // Explicitly changes the ten byte size restriction for uint64 or
  // sint64 types to allow big integers. If set to zero, the size of
  // the type is not limited.
  optional uint32 max_size = 76884 [default = 10];
}

;; Generated by protoc-gen-chicken v1.0.0
(module
  extend-protobuf
  *
  (import (except scheme string) chicken protobuf-syntax google-protobuf)
  (define-message-extension field-options (optional uint32 max-size 76884 10)))

;; -*- 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 make-identifier
  (let ([camel (sre->irregex '(: ($ lower) ($ upper)))]
	[score (sre->irregex '("._"))])
    (lambda (str #!optional prefix)
      (string->symbol
       (conc
	(or prefix "")
	(if prefix ":" "")
	(string-downcase
	 (irregex-replace/all
	  score (irregex-replace/all camel str 1 "-" 2) "-")))))))

(define (proto-file-register! types file)
  (define name
    (file-descriptor-proto-package file "main"))
  (define module
    (make-identifier name))

  (define (register-identifier! path name prefix)
    (let ([path (string-append path "." name)]
	  [prefix (make-identifier name prefix)])
      (hash-table-set! types path (cons module prefix))
      (values path prefix)))

  (define (register-enum! path enum #!optional prefix)
    (register-identifier! path (enum-descriptor-proto-name enum) prefix))
  
  (define (register-message! path msg #!optional prefix)
    (let-values ([(path prefix)
		  (register-identifier!
		   path (descriptor-proto-name msg) prefix)])
      (for-each
       (cut register-enum! path <> prefix)
       (descriptor-proto-enum-type msg '()))
      (for-each
       (cut register-message! path <> prefix)
       (descriptor-proto-nested-type msg '()))))
  
  (let ([path (string-append "." name)])
    (for-each
     (cut register-enum! path <>)
     (file-descriptor-proto-enum-type file '()))
    (for-each
     (cut register-message! path <>)
     (file-descriptor-proto-message-type file '()))))

(define (proto-file-translate types file)
  (define module
    (make-identifier (file-descriptor-proto-package file "main")))

  (define imports
    (make-hash-table eq? symbol-hash))

  (define (resolve-identifier! name prefix)
    (let-values ([(module symbol)
		  (car+cdr
		   (hash-table-ref
		    types name
		    (cut error prefix "unknown type" name)))])
      (hash-table-set! imports module #t)
      symbol))

  (define (translate-enum-definition enum #!optional prefix)
    (let ([name (make-identifier (enum-descriptor-proto-name enum) prefix)])
      `((define-enum-type ,name
	  ,@(map
	     (lambda (item)
	       (list
		(make-identifier (enum-value-descriptor-proto-name item))
		(enum-value-descriptor-proto-number item)))
	     (enum-descriptor-proto-value enum '()))))))
  
  (define (translate-field field prefix)
    (let ([name (make-identifier (field-descriptor-proto-name field))]
	  [options (field-descriptor-proto-options field make-field-options)])
      (cons*
       (case (field-descriptor-proto-label field)
	 [(label-required) 'required]
	 [(label-optional) 'optional]
	 [(label-repeated)
	  (if (field-options-packed options #f) 'packed 'repeated)])
       (case (field-descriptor-proto-type field)
	 [(type-int32) 'int32]
	 [(type-int64) 'int64]
	 [(type-uint32) 'uint32]
	 [(type-uint64)
	  (let ([max-size (field-options-max-size options)])
	    (if (= max-size 10)
		'uint64
		`(uint* ,(and (positive? max-size) max-size))))]
	 [(type-sint32) 'sint32]
	 [(type-sint64)
	  (let ([max-size (field-options-max-size options)])
	    (if (= max-size 10)
		'sint64
		`(sint* ,(and (positive? max-size) max-size))))]
	 [(type-fixed32) 'fixed32]
	 [(type-fixed64) 'fixed64]
	 [(type-sfixed32) 'sfixed32]
	 [(type-sfixed64) 'sfixed64]
	 [(type-bool) 'bool]
	 [(type-float) 'float]
	 [(type-double) 'double]
	 [(type-bytes) 'bytes]
	 [(type-string) 'string]
	 [else (resolve-identifier! (field-descriptor-proto-type-name field) name)])
       name
       (field-descriptor-proto-number field)
       (let ([default (field-descriptor-proto-default-value field void)])
	 (if (eq? default (void))
	     '()
	     (list
	      (case (field-descriptor-proto-type field)
		[(type-int32 type-int64
		  type-uint32 type-uint64
		  type-sint32 type-sint64
		  type-fixed32 type-fixed64
		  type-sfixed32 type-sfixed64
		  type-float type-double
		  type-bytes)
		 (call-with-input-string default read)]
		[(type-bool)
		 (not (equal? default "false"))]
		[(type-enum)
		 `(quote ,(make-identifier default))]
		[(type-string)
		 default]
		[else
		 (error prefix "unsupported default value" name default)])))))))
  
  (define (translate-message-definition msg #!optional prefix)
    (let ([name (make-identifier (descriptor-proto-name msg) prefix)])
      (append
       (append-map
	(cut translate-enum-definition <> name)
	(descriptor-proto-enum-type msg '()))
       (append-map
	(cut translate-message-definition <> name)
	(descriptor-proto-nested-type msg '()))
       (append-map
	translate-message-extension
	(descriptor-proto-extension msg '()))
       `((define-message-type ,name
	   ,@(map
	      (cut translate-field <> name)
	      (descriptor-proto-field msg '())))))))
  
  (define (translate-message-extension ext)
    (let ([name (resolve-identifier! (field-descriptor-proto-extendee ext) '<message-extension>)])
      `((define-message-extension ,name
	  ,(translate-field ext name)))))
  
  (define body
    (append
     (append-map
      translate-enum-definition
      (file-descriptor-proto-enum-type file '()))
     (append-map
      translate-message-definition
      (file-descriptor-proto-message-type file '()))
     (append-map
      translate-message-extension
      (file-descriptor-proto-extension file '()))))

  (hash-table-delete! imports module)

  (make-code-generator-response:file
   #:name
   (pathname-replace-extension
    (file-descriptor-proto-name file) "scm")
   #:content
   (call-with-output-string
     (lambda (port)
       (display ";; Generated by protoc-gen-chicken v1.0.0" port)
       (newline port)
       (pretty-print
	`(module ,module
	   *
	   (import
	    (except scheme string) chicken protobuf-syntax
	    ,@(hash-table-keys imports))
	   ,@body)
	port)))))

(define (generate-chicken request)
  (define files
    (make-hash-table string=? string-hash))
  (define types
    (make-hash-table string=? string-hash))

  (for-each
   (lambda (file)
     (hash-table-set! files (file-descriptor-proto-name file) file)
     (proto-file-register! types file))
   (code-generator-request-proto-file request '()))
  
  (condition-case
   (make-code-generator-response
    #:file
    (map
     (lambda (name)
       (proto-file-translate types (hash-table-ref files name)))
     (code-generator-request-file-to-generate request '())))
   [exn (exn)
    (make-code-generator-response
     #:error
     (call-with-output-string
      (cut print-error-message exn <>)))]))

;; Generated by protoc-gen-chicken v1.0.0
(module
  google-protobuf-compiler
  *
  (import (except scheme string) chicken protobuf-syntax google-protobuf)
  (define-message-type
    code-generator-request
    (repeated string file-to-generate 1)
    (optional string parameter 2)
    (repeated file-descriptor-proto proto-file 15))
  (define-message-type
    code-generator-response:file
    (optional string name 1)
    (optional string insertion-point 2)
    (optional string content 15))
  (define-message-type
    code-generator-response
    (optional string error 1)
    (repeated code-generator-response:file file 15)))

;; Generated by protoc-gen-chicken v1.0.0
(module
  google-protobuf
  *
  (import (except scheme string) chicken protobuf-syntax)
  (define-message-type
    file-descriptor-set
    (repeated file-descriptor-proto file 1))
  (define-message-type
    file-descriptor-proto
    (optional string name 1)
    (optional string package 2)
    (repeated string dependency 3)
    (repeated descriptor-proto message-type 4)
    (repeated enum-descriptor-proto enum-type 5)
    (repeated service-descriptor-proto service 6)
    (repeated field-descriptor-proto extension 7)
    (optional file-options options 8)
    (optional source-code-info source-code-info 9))
  (define-message-type
    descriptor-proto:extension-range
    (optional int32 start 1)
    (optional int32 end 2))
  (define-message-type
    descriptor-proto
    (optional string name 1)
    (repeated field-descriptor-proto field 2)
    (repeated field-descriptor-proto extension 6)
    (repeated descriptor-proto nested-type 3)
    (repeated enum-descriptor-proto enum-type 4)
    (repeated descriptor-proto:extension-range extension-range 5)
    (optional message-options options 7))
  (define-enum-type
    field-descriptor-proto:type
    (type-double 1)
    (type-float 2)
    (type-int64 3)
    (type-uint64 4)
    (type-int32 5)
    (type-fixed64 6)
    (type-fixed32 7)
    (type-bool 8)
    (type-string 9)
    (type-group 10)
    (type-message 11)
    (type-bytes 12)
    (type-uint32 13)
    (type-enum 14)
    (type-sfixed32 15)
    (type-sfixed64 16)
    (type-sint32 17)
    (type-sint64 18))
  (define-enum-type
    field-descriptor-proto:label
    (label-optional 1)
    (label-required 2)
    (label-repeated 3))
  (define-message-type
    field-descriptor-proto
    (optional string name 1)
    (optional int32 number 3)
    (optional field-descriptor-proto:label label 4)
    (optional field-descriptor-proto:type type 5)
    (optional string type-name 6)
    (optional string extendee 2)
    (optional string default-value 7)
    (optional field-options options 8))
  (define-message-type
    enum-descriptor-proto
    (optional string name 1)
    (repeated enum-value-descriptor-proto value 2)
    (optional enum-options options 3))
  (define-message-type
    enum-value-descriptor-proto
    (optional string name 1)
    (optional int32 number 2)
    (optional enum-value-options options 3))
  (define-message-type
    service-descriptor-proto
    (optional string name 1)
    (repeated method-descriptor-proto method 2)
    (optional service-options options 3))
  (define-message-type
    method-descriptor-proto
    (optional string name 1)
    (optional string input-type 2)
    (optional string output-type 3)
    (optional method-options options 4))
  (define-enum-type
    file-options:optimize-mode
    (speed 1)
    (code-size 2)
    (lite-runtime 3))
  (define-message-type
    file-options
    (optional string java-package 1)
    (optional string java-outer-classname 8)
    (optional bool java-multiple-files 10 #f)
    (optional bool java-generate-equals-and-hash 20 #f)
    (optional file-options:optimize-mode optimize-for 9 'speed)
    (optional bool cc-generic-services 16 #f)
    (optional bool java-generic-services 17 #f)
    (optional bool py-generic-services 18 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    message-options
    (optional bool message-set-wire-format 1 #f)
    (optional bool no-standard-descriptor-accessor 2 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-enum-type field-options:ctype (string 0) (cord 1) (string-piece 2))
  (define-message-type
    field-options
    (optional field-options:ctype ctype 1 'string)
    (optional bool packed 2)
    (optional bool deprecated 3 #f)
    (optional string experimental-map-key 9)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-options
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-value-options
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    service-options
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    method-options
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    uninterpreted-option:name-part
    (required string name-part 1)
    (required bool is-extension 2))
  (define-message-type
    uninterpreted-option
    (repeated uninterpreted-option:name-part name 2)
    (optional string identifier-value 3)
    (optional uint64 positive-int-value 4)
    (optional int64 negative-int-value 5)
    (optional double double-value 6)
    (optional bytes string-value 7)
    (optional string aggregate-value 8))
  (define-message-type
    source-code-info:location
    (packed int32 path 1)
    (packed int32 span 2))
  (define-message-type
    source-code-info
    (repeated source-code-info:location location 1)))

;; -*- 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-file <> 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-file <> 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))))))

;; -*- mode: Scheme; -*-
((category data io)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "Protocol buffer serialization")
 (doc-from-wiki)
 (needs srfi-42 srfi-4-comprehensions srfi-99 numbers)
 (test-depends srfi-78)
 (files
  "protobuf.scm"
  "encoding.scm" "reflection.scm" "syntax.scm" "main.scm"
  "protoc-gen-chicken.scm"
  "google/protobuf/descriptor.scm" "extend/protobuf/bigint.scm"
  "google/protobuf/compiler/plugin.scm"
  "generator.scm"
  "tests/run.scm"
  "tests/abook.proto" "tests/abook.scm"))

;; -*- 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.

(require-library
 srfi-4 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
 ports extras
 numbers)

(module protobuf-encoding
  (make-limited-input-port
   read-uint* write-uint*
   read-sint* write-sint*
   read-int* write-int*
   read-bool write-bool
   read-fixed* read-fixed32 read-fixed64 read-sfixed32 read-sfixed64
   write-fixed* write-fixed32 write-fixed64 write-sfixed32 write-sfixed64
   read-float* read-float read-double
   write-float* write-float write-double
   read-sized-bytes write-sized-bytes
   read-sized-string write-sized-string
   read-sized write-sized
   read-tag/type write-tag/type)
  (import
   scheme chicken
   srfi-4 (only srfi-18 raise) srfi-42 srfi-4-comprehensions
   ports extras
   numbers)
  (include "encoding.scm"))

(module protobuf-reflection
  (type-info
   make-type-info type-info?
   type-info-name
   primitive-info
   make-primitive-info primitive-info?
   primitive-info-type
   primitive-info-reader primitive-info-writer
   enum-info
   make-enum-info enum-info?
   enum-info-integer->enum enum-info-enum->integer
   message-info
   make-message-info message-info?
   message-info-constructor
   message-info-fields message-info-required
   field-info
   make-field-info field-info?
   field-info-type
   field-info-repeated? field-info-packed?
   field-info-accessor field-info-mutator
   message
   message?
   message-extensions
   message-unknown message-unknown-set!
   prop:protobuf)
  (import
   scheme (except chicken define-record-type)
   srfi-69 srfi-99)
  (include "reflection.scm"))

(module protobuf-syntax
  (int32 int64
   uint32 uint64 uint*
   sint32 sint64 sint*
   fixed32 fixed64
   sfixed32 sfixed64
   bool
   float double
   bytes string
   define-enum-type
   define-message-type
   define-message-extension)
  (import
   (except scheme string) (except chicken define-record-type)
   srfi-69 srfi-99
   protobuf-encoding protobuf-reflection)
  (include "syntax.scm"))

(module protobuf
  (serialize
   deserialize)
  (import
   scheme (except chicken define-record-type)
   srfi-69 srfi-99
   ports extras
   protobuf-encoding protobuf-reflection)
  (reexport
   (only protobuf-reflection
	 message? message-extensions message-unknown))
  (include "main.scm"))

;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "protobuf.scm" -J)
(compile -s -O2 -d0 "protobuf-encoding.import.scm")
(compile -s -O2 -d0 "protobuf-reflection.import.scm")
(compile -s -O2 -d0 "protobuf-syntax.import.scm")
(compile -s -O2 -d0 "protobuf.import.scm")

(install-extension
 'protobuf
 '("protobuf.so"
   "protobuf-encoding.import.so"
   "protobuf-reflection.import.so"
   "protobuf-syntax.import.so"
   "protobuf.import.so")
 '((version "1.0.0")))

(compile -O2 -d1 "protoc-gen-chicken.scm")

(install-program
 'protoc-gen-chicken
 '("protoc-gen-chicken")
 '((version "1.0.0")))

;; -*- 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.

(require-library
 srfi-1 srfi-13 srfi-69
 data-structures irregex files ports extras
 protobuf)

(include "google/protobuf/descriptor.scm")
(include "extend/protobuf/bigint.scm")
(include "google/protobuf/compiler/plugin.scm")

(module protobuf-generator
  (proto-file-register!
   proto-file-translate
   generate-chicken)
  (import
   scheme chicken
   srfi-1 srfi-13 srfi-69
   data-structures irregex files ports extras
   google-protobuf extend-protobuf google-protobuf-compiler)
  (include "generator.scm"))

(import
 protobuf google-protobuf-compiler protobuf-generator)

(serialize (generate-chicken (deserialize code-generator-request)))

;; -*- 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 type-info
  #t #t
  name)

(define-record-type (primitive-info type-info)
  #t #t
  type reader writer)

(define-record-printer (primitive-info v port)
  (fprintf port "#<primitive-type: ~a>" (type-info-name v)))

(define-record-type (enum-info type-info)
  #t #t
  integer->enum enum->integer)

(define-record-printer (enum-info v port)
  (fprintf port "#<enum-type: ~a>" (type-info-name v)))

(define-record-type (message-info type-info)
  #t #t
  constructor
  fields required)

(define-record-type field-info
  #t #t
  (type field-info-type*)
  repeated? packed?
  accessor mutator)

(define (field-info-type v)
  (force (field-info-type* v)))

(define-record-printer (message-info v port)
  (fprintf port "#<message-type: ~a ~s>"
	   (type-info-name v)
	   (hash-table-keys (message-info-fields v))))

(define-record-type (message #:uid 'protobuf:message)
  #f #t
  extensions
  (unknown))

(define-record-property prop:protobuf)

;; -*- 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-syntax define-primitive-type
  (syntax-rules ()
    [(define-primitive-type name type
       reader writer)
     (define name
       (make-primitive-info 'name 'type reader writer))]))

(define-primitive-type int32 int*
  read-int* write-int*)
(define-primitive-type int64 int*
  read-int* write-int*)
(define-primitive-type uint32 int*
  read-uint* write-uint*)
(define-primitive-type uint64 int*
  read-uint* write-uint*)
(define (uint* max-size)
  (primitive-info
   'uint* 'int*
   (cut read-uint* <> max-size)
   (cut write-uint* <> <> max-size)))
(define-primitive-type sint32 int*
  read-sint* write-sint*)
(define-primitive-type sint64 int*
  read-sint* write-sint*)
(define (sint* max-size)
  (primitive-info
   'sint* 'int*
   (cut read-sint* <> max-size)
   (cut write-sint* <> <> max-size)))
(define-primitive-type fixed32 32bit
  read-fixed32 write-fixed32)
(define-primitive-type fixed64 64bit
  read-fixed64 write-fixed64)
(define-primitive-type sfixed32 32bit
  read-sfixed32 write-sfixed32)
(define-primitive-type sfixed64 64bit
  read-sfixed64 write-sfixed64)
(define-primitive-type bool int*
  read-bool write-bool)
(define-primitive-type float 32bit
  read-float write-float)
(define-primitive-type double 64bit
  read-double write-double)
(define-primitive-type bytes sized
  read-sized-bytes write-sized-bytes)
(define-primitive-type string sized
  read-sized-string write-sized-string)

(define-syntax define-enum-type
  (syntax-rules ()
    [(define-enum-type name
       (alt tag)
       ...)
     (define name
       (make-enum-info
	'name
	(lambda (int)
	  (case int
	    [(tag) 'alt]
	    ...
	    [else (syntax-error 'name "unknown enumeration tag" int)]))
	(lambda (sym)
	  (case sym
	    [(alt) tag]
	    ...
	    [else (syntax-error 'name "unknown enumeration value" sym)]))))]))

(define-syntax %message-field-label
  (syntax-rules (required optional repeated packed)
    ;;                               packed? -------\
    ;;                             repeated? ----\  |
    ;;                             required? -\  |  |
    ;;                                        |  |  |
    ;;                                        v  v  v
    [(%message-field-label required) (values #t #f #f)]
    [(%message-field-label optional) (values #f #f #f)]
    [(%message-field-label repeated) (values #f #t #f)]
    [(%message-field-label packed)   (values #f #t #t)]))

(define-syntax %message-field-default
  (syntax-rules ()
    [(%message-field-default expr) (lambda _ expr)]
    [(%message-field-default) void]))

(define-syntax %define-message-constructor+predicate
  (er-macro-transformer
   (lambda (stx rename compare)
     (cons*
      (rename 'define-values)
      (map
       string->symbol
       (list (conc "make-" (cadr stx))
	     (conc (cadr stx) "?")))
      (cddr stx)))))

(define-syntax %define-message-accessor+mutator
  (er-macro-transformer
   (lambda (stx rename compare)
     (cons*
      (rename 'define-values)
      (map
       string->symbol
       (list (conc (cadr stx) "-" (caddr stx))
	     (conc (cadr stx) "-" (caddr stx) "-set!")))
      (cdddr stx)))))

(define-syntax define-message-type
  (syntax-rules ()
    [(define-message-type name
       (label type field tag . default)
       ...)
     (begin
       (define name
	 (letrec ([name
		   (make-rtd
		    'name '#((mutable field) ...)
		    #:parent message
		    #:property prop:protobuf (lambda _ descriptor))]
		  [descriptor
		   (void)])
	   (set! descriptor
	     (make-message-info
	      'name
	      (let ([constructor* (rtd-constructor name)])
		(lambda (#!key [field ((%message-field-default . default))] ...)
		  (constructor*
		   (make-hash-table eqv? eqv?-hash) ""
		   field ...)))
	      (make-hash-table eqv? eqv?-hash)
	      (make-hash-table eqv? eqv?-hash)))
	   (let-values ([(required? repeated? packed?)
			 (%message-field-label label)]
			[(accessor mutator)
			 (values
			  (let ([accessor* (rtd-accessor name 'field)])
			    (lambda (msg #!optional [v* (%message-field-default . default)])
			      (let ([v (accessor* msg)])
				(if (eq? v (void))
				    (if (procedure? v*) (v*) v*)
				    v))))
			  (rtd-mutator name 'field))])
	     (hash-table-set!
	      (message-info-fields descriptor) tag
	      (make-field-info
	       (delay type) repeated? packed?
	       (getter-with-setter accessor mutator) mutator))
	     (when required?
	       (hash-table-set!
		(message-info-required descriptor) tag
		#t)))
	   ...
	   name))
       (%define-message-constructor+predicate name
         (values (message-info-constructor (prop:protobuf #f name))
		 (rtd-predicate name)))
       (%define-message-accessor+mutator name field
	 (let ([descriptor
		(hash-table-ref
		 (message-info-fields (prop:protobuf #f name)) tag)])
	   (values (field-info-accessor descriptor)
		   (field-info-mutator descriptor))))
       ...)]))

(define-syntax define-message-extension
  (syntax-rules ()
    [(define-message-extension name
       (label type field tag . default)
       ...)
     (begin
       (let-values ([(descriptor)
		     (prop:protobuf #f name)]
		    [(required? repeated? packed?)
		     (%message-field-label label)]
		    [(accessor mutator)
		     (values
		      (lambda (msg #!optional [v* (%message-field-default . default)])
			(hash-table-ref
			 (message-extensions msg) tag v*))
		      (lambda (msg v)
			(hash-table-set!
			 (message-extensions msg) tag
			 v)))])
	 (hash-table-set!
	  (message-info-fields descriptor) tag
	  (make-field-info
	   (delay type) repeated? packed?
	   (getter-with-setter accessor mutator) mutator))
	 (when required?
	   (hash-table-set!
	    (message-info-required descriptor) tag
	    #t)))
       ...
       (%define-message-accessor+mutator name field
	 (let ([descriptor
		(hash-table-ref
		 (message-info-fields (prop:protobuf #f name)) tag)])
	   (values (field-info-accessor descriptor)
		   (field-info-mutator descriptor))))
       ...)]))

// 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.
package abook;

message Person {
  required string name = 1;
  required int32 id = 2;
  optional string email = 3;

  enum PhoneType {
    MOBILE = 0;
    HOME = 1;
    WORK = 2;
  }

  message PhoneNumber {
    required string number = 1;
    optional PhoneType type = 2 [default = HOME];
  }

  repeated PhoneNumber phone = 4;
}

message AddressBook {
  repeated Person person = 1;
}

;; Generated by protoc-gen-chicken v1.0.0
(module
  abook
  *
  (import (except scheme string) chicken protobuf-syntax)
  (define-enum-type person:phone-type (mobile 0) (home 1) (work 2))
  (define-message-type
    person:phone-number
    (required string number 1)
    (optional person:phone-type type 2 'home))
  (define-message-type
    person
    (required string name 1)
    (required int32 id 2)
    (optional string email 3)
    (repeated person:phone-number phone 4))
  (define-message-type address-book (repeated person person 1)))

;; -*- 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.

(require-library srfi-78 srfi-99 protobuf)
(include "abook.scm")

(import srfi-78 srfi-99 protobuf protobuf-reflection abook)

(define (message-rtd? v)
  (and (rtd? v) (message-info? (prop:protobuf #f v))))

(check (message-rtd? person) => #t)
(check (enum-info? person:phone-type) => #t)
(check (message-rtd? person:phone-number) => #t)
(check (message-rtd? address-book) => #t)

(check ((enum-info-integer->enum person:phone-type) 2) => 'work)
(check ((enum-info-enum->integer person:phone-type) 'home) => 1)

(define msg
  (make-address-book
   #:person
   (list
    (make-person
     #:id 42 #:name "Jane Doe"
     #:phone
     (list
      (make-person:phone-number #:number "+12-3456-7890")))
    (make-person
     #:id 23 #:name "Johannes Mustermann" #:email "joe@example.com"
     #:phone
     (list
      (make-person:phone-number
       #:number "+67-876743724-8751751" #:type 'mobile)
      (make-person:phone-number
       #:number "+60-9848752576-987832" #:type 'work))))))

(define (check-structure msg)
  (check (message? msg) => #t)
  (check (address-book? msg) => #t)

  (let ([persons (address-book-person msg '())])
    (check (length persons) => 2)
    (let ([jane (first persons)]
	  [joe (second persons)])
      (check (person? jane) => #t)
      (check (person-id jane) => 42)
      (check (person-name jane) => "Jane Doe")
      (check (person-email jane) => (void))
      (check (person-email jane "jane@example.com") => "jane@example.com")

      (let ([phones (person-phone jane)])
	(check (length phones) => 1)
	(let ([phone (car phones)])
	  (check (person:phone-number-number phone) => "+12-3456-7890")
	  (check (person:phone-number-type phone) => 'home)))

      (check (person? joe) => #t)
      (check (person-id joe) => 23)
      (check (person-name joe) => "Johannes Mustermann")
      (check (person-email joe) => "joe@example.com")
      (check (person-email joe "whatever@example.com") => "joe@example.com")

      (let ([phones (person-phone joe)])
	(check (length phones) => 2)
	(let ([phone (first phones)])
	  (check (person:phone-number-number phone) => "+67-876743724-8751751")
	  (check (person:phone-number-type phone) => 'mobile))
	(let ([phone (second phones)])
	  (check (person:phone-number-number phone) => "+60-9848752576-987832")
	  (check (person:phone-number-type phone) => 'work))))))

(check-structure msg)
(check-structure
 (call-with-input-string
  (call-with-output-string (cut serialize msg <>))
  (cut deserialize address-book <>)))

(set! (address-book-person msg) (cdr (address-book-person msg)))
(check (person-id (car (address-book-person msg))) => 23)

(check-report)
(exit (if (check-passed? (+ 7 (* 2 21))) 0 1))