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 syntax options)
  21                         &body messages &environment env)
  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  ,(if (stringp package) package (string-downcase (string package)))
  54                           :imports  ',(if (consp import) import (list import))
  55                           :syntax   ,syntax
  56                           :options  '(,@options)
  57                           :enums    (list ,@enums)
  58                           :messages (list ,@msgs)
  59                           :services (list ,@svcs)))))))
  60
  61 ;; Define an enum type named 'name' and a Lisp 'deftype'
  62 ;; 'proto-name' can be used to override the defaultly generated name
  63 ;; The body consists of the enum values in the form (name &key index)
  64 (defmacro define-enum (name (&key proto-name) &body values)
  65   (with-collectors ((vals  collect-val)
  66                     (evals collect-eval)
  67                     (forms collect-form))
  68     (let ((index 0))
  69       (dolist (val values)
  70         (destructuring-bind (name)
  71             (if (listp val) val (list val))             ;---*** &KEY INDEX?
  72           (let ((lname (kintern (symbol-name name))))
  73             (collect-val lname)
  74             (collect-eval `(make-instance 'protobuf-enum-value
  75                              :name  ,(proto-enum-name name)
  76                              :index ,(incf index)
  77                              :value ,lname))))))
  78     (collect-form `(deftype ,name () '(member ,@vals)))
  79     `(progn
  80        define-enum
  81        (make-instance 'protobuf-enum
  82          :name   ,(or proto-name (proto-class-name name))
  83          :class  ',name
  84          :values (list ,@evals))
  85        ,forms)))
  86
  87 ;; Define a message named 'name' and a Lisp 'defclass'
  88 ;; 'proto-name' can be used to override the defaultly generated name
  89 ;; The body consists of fields, or 'define-enum' or 'define-message' forms
  90 ;; Fields take the form (name &key type default index)
  91 (defmacro define-message (name (&key proto-name) &body fields &environment env)
  92   (with-collectors ((enums collect-enum)
  93                     (msgs  collect-msg)
  94                     (flds  collect-field)
  95                     (slots collect-slot)
  96                     (forms collect-form))
  97     (let ((index 0))
  98       (dolist (fld fields)
  99         (case (car fld)
 100           ((define-enum define-message)
 101            (destructuring-bind (&optional progn type model definers)
 102                (macroexpand-1 fld env)
 103              (assert (eq progn 'progn) ()
 104                      "The macroexpansion for ~S failed" fld)
 105              (map () #'collect-form definers)
 106              (ecase type
 107                ((define-enum)
 108                 (collect-enum model))
 109                ((define-message)
 110                 (collect-msg model)))))
 111           (otherwise
 112            (destructuring-bind (slot &key type default) fld ;---*** &KEY INDEX?
 113              (multiple-value-bind (ptype pclass)
 114                  (clos-type-to-protobuf-type type)
 115                (collect-slot `(,slot :type ,type
 116                                      :ACCESSOR ,SLOT    ;---*** BETTER ACCESSOR NAME VIA :CONC-NAME
 117                                      :initarg ,(kintern (symbol-name slot))
 118                                      ,@(and default (list :initform default))))
 119                (collect-field `(make-instance 'protobuf-field
 120                                  :name  ,(proto-field-name slot)
 121                                  :type  ,ptype
 122                                  :class ',pclass
 123                                  :required ,(clos-type-to-protobuf-required type)
 124                                  :index ,(incf index)
 125                                  :value ',slot
 126                                  :default ,(and default (FORMAT NIL "~A" DEFAULT))      ;---***
 127                                  :packed  ,(packed-type-p pclass)))))))))
 128     (collect-form `(defclass ,name () (,@slots)))
 129     `(progn
 130        define-message
 131        (make-instance 'protobuf-message
 132          :name  ,(or proto-name (proto-class-name name))
 133          :class ',name
 134          :enums    (list ,@enums)
 135          :messages (list ,@msgs)
 136          :fields   (list ,@flds))
 137        ,forms)))
 138
 139 ;; Define a service named 'name' and a Lisp 'defun'
 140 ;; 'proto-name' can be used to override the defaultly generated name
 141 ;; The body consists of a set of RPC specs of the form (name input-type output-type)
 142 (defmacro define-service (name (&key proto-name) &body rpc-specs)
 143   (with-collectors ((rpcs collect-rpc))
 144     (dolist (rpc rpc-specs)
 145       (destructuring-bind (name input-type output-type) rpc
 146         (collect-rpc `(make-instance 'protobuf-rpc
 147                         :name ,(proto-class-name name)
 148                         :input-type  ,(and input-type  (proto-class-name input-type))
 149                         :output-type ,(and output-type (proto-class-name output-type))))))
 150     `(progn
 151        define-service
 152        (make-instance 'protobuf-service
 153          :name ,(or proto-name (proto-class-name name))
 154          :rpcs (list ,@rpcs))
 155        ())))                                            ;---*** DEFINE LISP STUB HERE