;; -*- 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)
  (make-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)
  (make-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))))
       ...)]))

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