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 (defmacro define-proto (name (&key proto-name syntax package import options documentation)
  18                         &body messages &environment env)
  19   "Define a schema named 'name', corresponding to a .proto file of that name.
  20    'proto-name' can be used to override the defaultly generated name.
  21    'syntax' and 'package' are as in .proto files.
  22    'imports' is a list of pathname strings to be imported.
  23    'options' is a property list, i.e., (\"key1\" \"val1\" \"key2\" \"val2\" ...).
  24    The body consists of 'define-enum', 'define-message' or 'define-service' forms."
  25   (with-collectors ((enums collect-enum)
  26                     (msgs  collect-msg)
  27                     (svcs  collect-svc)
  28                     (forms collect-form))
  29     (dolist (msg messages)
  30       (assert (and (listp msg)
  31                    (member (car msg) '(define-enum define-message define-service))) ()
  32               "The body of ~S must be one of ~{~S~^ or ~}"
  33               'define-proto '(define-enum define-message define-service))
  34       ;; The macro-expander will return a form that consists
  35       ;; of 'progn' followed by a symbol naming what we've expanded
  36       ;; (define-enum, define-message, define-service), followed by
  37       ;; by a (optional) Lisp defining form (deftype, defclass),
  38       ;; followed by a form that creates the model object
  39       (destructuring-bind (&optional progn type model definers)
  40           (macroexpand-1 msg env)
  41         (assert (eq progn 'progn) ()
  42                 "The macroexpansion for ~S failed" msg)
  43         (map () #'collect-form definers)
  44         (ecase type
  45           ((define-enum)
  46            (collect-enum model))
  47           ((define-message)
  48            (collect-msg model))
  49           ((define-service)
  50            (collect-svc model)))))
  51     ;;--- This should warn if the old one isn't upgradable to the new one
  52     (let ((vname (fintern "*~A*" name))
  53           (pname (or proto-name (class-name->proto name)))
  54           (cname name)
  55           (options (loop for (key val) on options by #'cddr
  56                          collect `(make-instance 'protobuf-option
  57                                     :name ,key
  58                                     :value ,val))))
  59       `(progn
  60          ,@forms
  61          (defvar ,vname nil)
  62          (let ((protobuf (make-instance 'protobuf
  63                            :name     ',pname
  64                            :class    ',cname
  65                            :package  ,(if (stringp package) package (string-downcase (string package)))
  66                            :imports  ',(if (listp import) import (list import))
  67                            :syntax   ,syntax
  68                            :options  (list ,@options)
  69                            :enums    (list ,@enums)
  70                            :messages (list ,@msgs)
  71                            :services (list ,@svcs)
  72                            :documentation ,documentation)))
  73            (setq ,vname protobuf)
  74            (setf (gethash ',pname *all-protobufs*) protobuf)
  75            (setf (gethash ',cname *all-protobufs*) protobuf)
  76            protobuf)))))
  77
  78 ;; Define an enum type named 'name' and a Lisp 'deftype'
  79 (defmacro define-enum (name (&key proto-name conc-name options documentation) &body values)
  80   "Define an enum type named 'name' and a Lisp 'deftype'.
  81   'proto-name' can be used to override the defaultly generated name.
  82    The body consists of the enum values in the form (name &key index)."
  83   (with-collectors ((vals  collect-val)
  84                     (evals collect-eval)
  85                     (forms collect-form))
  86     (let ((index 0))
  87       (dolist (val values)
  88         (let* ((idx  (if (listp val) (second val) (incf index)))
  89                (name (if (listp val) (first val)  val))
  90                (val-name  (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
  91                (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
  92           (collect-val val-name)
  93           (collect-eval `(make-instance 'protobuf-enum-value
  94                            :name  ,(enum-name->proto enum-name)
  95                            :index ,idx
  96                            :value ,val-name)))))
  97     (collect-form `(deftype ,name () '(member ,@vals)))
  98     (let ((options (loop for (key val) on options by #'cddr
  99                          collect `(make-instance 'protobuf-option
 100                                     :name ,key
 101                                     :value ,val))))
 102       `(progn
 103          define-enum
 104          (make-instance 'protobuf-enum
 105            :name   ,(or proto-name (class-name->proto name))
 106            :class  ',name
 107            :options (list ,@options)
 108            :values  (list ,@evals)
 109            :documentation ,documentation)
 110          ,forms))))
 111
 112 ;; Define a message named 'name' and a Lisp 'defclass'
 113 (defmacro define-message (name (&key proto-name conc-name options documentation)
 114                           &body fields &environment env)
 115   "Define a message named 'name' and a Lisp 'defclass'.
 116    'proto-name' can be used to override the defaultly generated name.
 117    The body consists of fields, or 'define-enum' or 'define-message' forms.
 118    Fields take the form (name &key type default index)."
 119   (with-collectors ((enums collect-enum)
 120                     (msgs  collect-msg)
 121                     (flds  collect-field)
 122                     (slots collect-slot)
 123                     (forms collect-form))
 124     (let ((index 0))
 125       (dolist (fld fields)
 126         (case (car fld)
 127           ((define-enum define-message define-extension)
 128            (destructuring-bind (&optional progn type model definers)
 129                (macroexpand-1 fld env)
 130              (assert (eq progn 'progn) ()
 131                      "The macroexpansion for ~S failed" fld)
 132              (map () #'collect-form definers)
 133              (ecase type
 134                ((define-enum)
 135                 (collect-enum model))
 136                ((define-message)
 137                 (collect-msg model))
 138                ((define-extension)
 139                 (collect-msg model)))))
 140           (otherwise
 141            (destructuring-bind (slot &key type default) fld
 142              (let* ((idx  (if (listp slot) (second slot) (incf index)))
 143                     (slot (if (listp slot) (first slot) slot))
 144                     (reqd (clos-type-to-protobuf-required type))
 145                     (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 146                                       (symbol-package slot))))
 147                (multiple-value-bind (ptype pclass)
 148                    (clos-type-to-protobuf-type type)
 149                  (collect-slot `(,slot :type ,type
 150                                        :accessor ,accessor
 151                                        :initarg ,(kintern (symbol-name slot))
 152                                        ,@(and default (list :initform default))))
 153                  (collect-field `(make-instance 'protobuf-field
 154                                    :name  ,(slot-name->proto slot)
 155                                    :type  ,ptype
 156                                    :class ',pclass
 157                                    :required ,reqd
 158                                    :index ,idx
 159                                    :value ',slot
 160                                    :default ,(and default (format nil "~A" default))
 161                                    :packed  ,(and (eq reqd :repeated)
 162                                                   (packed-type-p pclass)))))))))))
 163     (collect-form `(defclass ,name () (,@slots)))
 164     (let ((options (loop for (key val) on options by #'cddr
 165                          collect `(make-instance 'protobuf-option
 166                                     :name ,key
 167                                     :value ,val))))
 168       `(progn
 169          define-message
 170          (make-instance 'protobuf-message
 171            :name  ,(or proto-name (class-name->proto name))
 172            :class ',name
 173            :conc-name ,(and conc-name (string conc-name))
 174            :options  (list ,@options)
 175            :enums    (list ,@enums)
 176            :messages (list ,@msgs)
 177            :fields   (list ,@flds)
 178            :documentation ,documentation)
 179          ,forms))))
 180
 181 (defmacro define-extension (from to)
 182   "Define an extension range within a message.
 183    The \"body\" is the start and end of the range, both inclusive."
 184   `(progn
 185      define-extension
 186      (make-instance 'protobuf-extension
 187        :from ,from
 188        :to   ,to)
 189      ()))
 190
 191 ;; Define a service named 'name' and a Lisp 'defun'
 192 (defmacro define-service (name (&key proto-name options documentation) &body rpc-specs)
 193   "Define a service named 'name' and a Lisp 'defun'.
 194    'proto-name' can be used to override the defaultly generated name.
 195    The body consists of a set of RPC specs of the form (name input-type output-type)."
 196   (with-collectors ((rpcs collect-rpc))
 197     (dolist (rpc rpc-specs)
 198       (destructuring-bind (name input-type output-type &key options) rpc
 199         (let ((options (loop for (key val) on options by #'cddr
 200                              collect `(make-instance 'protobuf-option
 201                                         :name ,key
 202                                         :value ,val))))
 203           (collect-rpc `(make-instance 'protobuf-rpc
 204                           :name ,(class-name->proto name)
 205                           :class ',name
 206                           :input-type  ,(and input-type  (class-name->proto input-type))
 207                           :output-type ,(and output-type (class-name->proto output-type))
 208                           :options (list ,@options))))))
 209     (let ((options (loop for (key val) on options by #'cddr
 210                          collect `(make-instance 'protobuf-option
 211                                     :name ,key
 212                                     :value ,val))))
 213       `(progn
 214          define-service
 215          (make-instance 'protobuf-service
 216            :name ,(or proto-name (class-name->proto name))
 217            :class ',name
 218            :options  (list ,@options)
 219            :rpcs (list ,@rpcs)
 220            :documentation ,documentation)
 221          ()))))                                         ;---*** define Lisp stub here