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)
  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            (setq ,vname protobuf)
  73            (setf (gethash ',pname *all-protobufs*) protobuf)
  74            (setf (gethash ',cname *all-protobufs*) protobuf)
  75            protobuf)))))
  76
  77 ;; Define an enum type named 'name' and a Lisp 'deftype'
  78 (defmacro define-enum (name (&key proto-name conc-name) &body values)
  79   "Define an enum type named 'name' and a Lisp 'deftype'.
  80   'proto-name' can be used to override the defaultly generated name.
  81    The body consists of the enum values in the form (name &key index)."
  82   (with-collectors ((vals  collect-val)
  83                     (evals collect-eval)
  84                     (forms collect-form))
  85     (let ((index 0))
  86       (dolist (val values)
  87         (let* ((idx  (if (listp val) (second val) (incf index)))
  88                (name (if (listp val) (first val)  val))
  89                (val-name  (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
  90                (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
  91           (collect-val val-name)
  92           (collect-eval `(make-instance 'protobuf-enum-value
  93                            :name  ,(enum-name->proto enum-name)
  94                            :index ,idx
  95                            :value ,val-name)))))
  96     (collect-form `(deftype ,name () '(member ,@vals)))
  97     `(progn
  98        define-enum
  99        (make-instance 'protobuf-enum
 100          :name   ,(or proto-name (class-name->proto name))
 101          :class  ',name
 102          :values (list ,@evals))
 103        ,forms)))
 104
 105 ;; Define a message named 'name' and a Lisp 'defclass'
 106 (defmacro define-message (name (&key proto-name conc-name) &body fields &environment env)
 107   "Define a message named 'name' and a Lisp 'defclass'.
 108    'proto-name' can be used to override the defaultly generated name.
 109    The body consists of fields, or 'define-enum' or 'define-message' forms.
 110    Fields take the form (name &key type default index)."
 111   (with-collectors ((enums collect-enum)
 112                     (msgs  collect-msg)
 113                     (flds  collect-field)
 114                     (slots collect-slot)
 115                     (forms collect-form))
 116     (let ((index 0))
 117       (dolist (fld fields)
 118         (case (car fld)
 119           ((define-enum define-message define-extension)
 120            (destructuring-bind (&optional progn type model definers)
 121                (macroexpand-1 fld env)
 122              (assert (eq progn 'progn) ()
 123                      "The macroexpansion for ~S failed" fld)
 124              (map () #'collect-form definers)
 125              (ecase type
 126                ((define-enum)
 127                 (collect-enum model))
 128                ((define-message)
 129                 (collect-msg model))
 130                ((define-extension)
 131                 (collect-msg model)))))
 132           (otherwise
 133            (destructuring-bind (slot &key type default) fld
 134              (let* ((idx  (if (listp slot) (second slot) (incf index)))
 135                     (slot (if (listp slot) (first slot) slot))
 136                     (reqd (clos-type-to-protobuf-required type))
 137                     (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 138                                       (symbol-package slot))))
 139                (multiple-value-bind (ptype pclass)
 140                    (clos-type-to-protobuf-type type)
 141                  (collect-slot `(,slot :type ,type
 142                                        :accessor ,accessor
 143                                        :initarg ,(kintern (symbol-name slot))
 144                                        ,@(and default (list :initform default))))
 145                  (collect-field `(make-instance 'protobuf-field
 146                                    :name  ,(slot-name->proto slot)
 147                                    :type  ,ptype
 148                                    :class ',pclass
 149                                    :required ,reqd
 150                                    :index ,idx
 151                                    :value ',slot
 152                                    :default ,(and default (format nil "~A" default))
 153                                    :packed  ,(and (eq reqd :repeated)
 154                                                   (packed-type-p pclass)))))))))))
 155     (collect-form `(defclass ,name () (,@slots)))
 156     `(progn
 157        define-message
 158        (make-instance 'protobuf-message
 159          :name  ,(or proto-name (class-name->proto name))
 160          :class ',name
 161          :conc-name ,(and conc-name (string conc-name))
 162          :enums    (list ,@enums)
 163          :messages (list ,@msgs)
 164          :fields   (list ,@flds))
 165        ,forms)))
 166
 167 (defmacro define-extension (from to)
 168   "Define an extension range within a message.
 169    The \"body\" is the start and end of the range, both inclusive."
 170   `(progn
 171      define-extension
 172      (make-instance 'protobuf-extension
 173        :from ,from
 174        :to   ,to)
 175      ()))
 176
 177 ;; Define a service named 'name' and a Lisp 'defun'
 178 (defmacro define-service (name (&key proto-name) &body rpc-specs)
 179   "Define a service named 'name' and a Lisp 'defun'.
 180    'proto-name' can be used to override the defaultly generated name.
 181    The body consists of a set of RPC specs of the form (name input-type output-type)."
 182   (with-collectors ((rpcs collect-rpc))
 183     (dolist (rpc rpc-specs)
 184       (destructuring-bind (name input-type output-type &key options) rpc
 185         (let ((options (loop for (key val) on options by #'cddr
 186                              collect `(make-instance 'protobuf-option
 187                                         :name ,key
 188                                         :value ,val))))
 189           (collect-rpc `(make-instance 'protobuf-rpc
 190                           :name ,(class-name->proto name)
 191                           :class ',name
 192                           :input-type  ,(and input-type  (class-name->proto input-type))
 193                           :output-type ,(and output-type (class-name->proto output-type))
 194                           :options (list ,@options))))))
 195     `(progn
 196        define-service
 197        (make-instance 'protobuf-service
 198          :name ,(or proto-name (class-name->proto name))
 199          :class ',name
 200          :rpcs (list ,@rpcs))
 201        ())))                                            ;---*** DEFINE LISP STUB HERE