;; -*- 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.1.3" port)
       (newline port)
       (pretty-print
        `(module ,module
           *
           (import
            (except scheme string) (chicken base) 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 <>)))]))

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