define-proto.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protocol buffer defining macros
  15
  16 ;; Define a schema named 'name', corresponding to a .proto file of that name
  17 ;; 'proto-name' can be used to override the defaultly generated name
  18 ;; 'package' and 'imports' are as in .proto files
  19 ;; The body consists of 'define-enum', 'define-message' or 'define-service' forms
  20 (defmacro define-proto (name (&key proto-name package import) &body messages &environment env)
  21   IMPORT                                                ;---*** DO THIS
  22   (with-collectors ((enums collect-enum)
  23                     (msgs  collect-msg)
  24                     (svcs  collect-svc)
  25                     (forms collect-form))
  26     (dolist (msg messages)
  27       (assert (and (listp msg)
  28                    (member (car msg) '(define-enum define-message define-service))) ()
  29               "The body of ~S must be one of ~{~S~^ or ~}"
  30               'define-proto '(define-enum define-message define-service))
  31       ;; The macro-expander will return a form that consists
  32       ;; of 'progn' followed by a symbol naming what we've expanded
  33       ;; (define-enum, define-message, define-service), followed by
  34       ;; by a (optional) Lisp defining form (deftype, defclass),
  35       ;; followed by a form that creates the model object
  36       (destructuring-bind (&optional progn type model definers)
  37           (macroexpand-1 msg env)
  38         (assert (eq progn 'progn) ()
  39                 "The macroexpansion for ~S failed" msg)
  40         (map () #'collect-form definers)
  41         (ecase type
  42           ((define-enum)
  43            (collect-enum model))
  44           ((define-message)
  45            (collect-msg model))
  46           ((define-service)
  47            (collect-svc model)))))
  48     (let ((sname   (fintern "*~A*" name)))
  49       `(progn
  50          ,@forms
  51          (defvar ,sname (make-instance 'protobuf
  52                           :name    ,(or proto-name (proto-class-name name))
  53                           :package ,package
  54                           :enums    (list ,@enums)
  55                           :messages (list ,@msgs)
  56                           :services (list ,@svcs)))))))
  57
  58 ;; Define an enum type named 'name' and a Lisp 'deftype'
  59 ;; 'proto-name' can be used to override the defaultly generated name
  60 ;; The body consists of the enum values in the form (name &key index)
  61 (defmacro define-enum (name (&key proto-name) &body values)
  62   (with-collectors ((vals  collect-val)
  63                     (evals collect-eval)
  64                     (forms collect-form))
  65     (let ((index 0))
  66       (dolist (val values)
  67         (destructuring-bind (name)
  68             (if (listp val) val (list val))             ;---*** &KEY INDEX?
  69           (let ((lname (kintern (symbol-name name))))
  70             (collect-val lname)
  71             (collect-eval `(make-instance 'protobuf-enum-value
  72                              :name  ,(proto-enum-name name)
  73                              :index ,(incf index)
  74                              :value ,lname))))))
  75     (collect-form `(deftype ,name () '(member ,@vals)))
  76     `(progn
  77        define-enum
  78        (make-instance 'protobuf-enum
  79          :name   ,(or proto-name (proto-class-name name))
  80          :class  ',name
  81          :values (list ,@evals))
  82        ,forms)))
  83
  84 ;; Define a message named 'name' and a Lisp 'defclass'
  85 ;; 'proto-name' can be used to override the defaultly generated name
  86 ;; The body consists of fields, or 'define-enum' or 'define-message' forms
  87 ;; Fields take the form (name &key type default index)
  88 (defmacro define-message (name (&key proto-name) &body fields &environment env)
  89   (with-collectors ((enums collect-enum)
  90                     (msgs  collect-msg)
  91                     (flds  collect-field)
  92                     (slots collect-slot)
  93                     (forms collect-form))
  94     (let ((index 0))
  95       (dolist (fld fields)
  96         (case (car fld)
  97           ((define-enum define-message)
  98            (destructuring-bind (&optional progn type model definers)
  99                (macroexpand-1 fld env)
 100              (assert (eq progn 'progn) ()
 101                      "The macroexpansion for ~S failed" fld)
 102              (map () #'collect-form definers)
 103              (ecase type
 104                ((define-enum)
 105                 (collect-enum model))
 106                ((define-message)
 107                 (collect-msg model)))))
 108           (otherwise
 109            (destructuring-bind (slot &key type default) fld ;---*** &KEY INDEX?
 110              (multiple-value-bind (ptype pclass)
 111                  (clos-type-to-protobuf-type type)
 112                (collect-slot `(,slot :type ,type
 113                                      :ACCESSOR ,SLOT    ;---*** BETTER ACCESSOR NAME, PLEASE
 114                                      :initarg ,(kintern (symbol-name slot))
 115                                      ,@(and default (list :initform default))))
 116                (collect-field `(make-instance 'protobuf-field
 117                                  :name  ,(proto-field-name slot)
 118                                  :type  ,ptype
 119                                  :class ',pclass
 120                                  :required ,(clos-type-to-protobuf-required type)
 121                                  :index ,(incf index)
 122                                  :value ',slot
 123                                  :default ,(and default (FORMAT NIL "~A" DEFAULT))      ;---***
 124                                  :packed  ,(packed-type-p pclass)))))))))
 125     (collect-form `(defclass ,name () (,@slots)))
 126     `(progn
 127        define-message
 128        (make-instance 'protobuf-message
 129          :name  ,(or proto-name (proto-class-name name))
 130          :class ',name
 131          :enums    (list ,@enums)
 132          :messages (list ,@msgs)
 133          :fields   (list ,@flds))
 134        ,forms)))
 135
 136 ;; Define a service named 'name' and a Lisp 'defun'
 137 ;; 'proto-name' can be used to override the defaultly generated name
 138 ;; The body consists of a set of RPC specs of the form (name input-type output-type)
 139 (defmacro define-service (name (&key proto-name) &body rpc-specs)
 140   (with-collectors ((rpcs collect-rpc))
 141     (dolist (rpc rpc-specs)
 142       (destructuring-bind (name input-type output-type) rpc
 143         (collect-rpc `(make-instance 'protobuf-rpc
 144                         :name ,(proto-class-name name)
 145                         :input-type  ,(and input-type  (proto-class-name input-type))
 146                         :output-type ,(and output-type (proto-class-name output-type))))))
 147     `(progn
 148        define-service
 149        (make-instance 'protobuf-service
 150          :name ,(or proto-name (proto-class-name name))
 151          :rpcs (list ,@rpcs))
 152        ())))                                            ;---*** DEFINE LISP STUB HERE