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 optimize 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 they would be in a .proto file.
  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     (let ((vname (fintern "*~A*" name))
  52           (pname (or proto-name (class-name->proto name)))
  53           (cname name)
  54           (options (loop for (key val) on options by #'cddr
  55                          collect `(make-instance 'protobuf-option
  56                                     :name ,key
  57                                     :value ,val))))
  58       `(progn
  59          ,@forms
  60          (defvar ,vname nil)
  61          (let ((old      ,vname)
  62                (protobuf (make-instance 'protobuf
  63                            :name     ',pname
  64                            :class    ',cname
  65                            :syntax   ,(or syntax "proto2")
  66                            :package  ,(if (stringp package) package (string-downcase (string package)))
  67                            :imports  ',(if (listp import) import (list import))
  68                            :options  (list ,@options)
  69                            :optimize ,optimize
  70                            :enums    (list ,@enums)
  71                            :messages (list ,@msgs)
  72                            :services (list ,@svcs)
  73                            :documentation ,documentation)))
  74            (when old
  75              (multiple-value-bind (upgradable warnings)
  76                  (protobuf-upgradable old protobuf)
  77                (unless upgradable
  78                  (protobufs-warn "The old schema for ~S (~A) can't be safely upgraded; proceeding anyway"
  79                                  ',cname ',pname)
  80                  (map () #'protobufs-warn warnings))))
  81            (setq ,vname protobuf)
  82            (setf (gethash ',pname *all-protobufs*) protobuf)
  83            (setf (gethash ',cname *all-protobufs*) protobuf)
  84            #+++ignore (
  85            ,@(when (eq optimize :speed)
  86                (mapcar (curry #'generate-object-size  protobuf) (proto-messages protobuf)))
  87            ,@(when (eq optimize :speed)
  88                (mapcar (curry #'generate-serializer   protobuf) (proto-messages protobuf)))
  89            ,@(when (eq optimize :speed)
  90                (mapcar (curry #'generate-deserializer protobuf) (proto-messages protobuf))) )
  91            protobuf)))))
  92
  93 ;; Define an enum type named 'name' and a Lisp 'deftype'
  94 (defmacro define-enum (name (&key proto-name conc-name type options documentation)
  95                        &body values)
  96   "Define an enum type named 'name' and a Lisp 'deftype'.
  97    'proto-name' can be used to override the defaultly generated Protobufs name.
  98    'conc-name' will be used as the prefix to the Lisp enum names, if it's supplied.
  99    If 'type' is given, no Lisp deftype is defined. This feature is intended to be used
 100    to model enum types that already exist in Lisp.
 101    'options' is a set of keyword/value pairs, both of which are strings.
 102    The body consists of the enum values in the form (name &key index)."
 103   (with-collectors ((vals  collect-val)
 104                     (evals collect-eval)
 105                     (forms collect-form))
 106     (let ((index 0))
 107       (dolist (val values)
 108         (let* ((idx  (if (listp val) (second val) (incf index)))
 109                (name (if (listp val) (first val)  val))
 110                (val-name  (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
 111                (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
 112           (collect-val val-name)
 113           (collect-eval `(make-instance 'protobuf-enum-value
 114                            :name  ,(enum-name->proto enum-name)
 115                            :index ,idx
 116                            :value ,val-name)))))
 117
 118     (if type
 119       ;; If we've got a type override, define a type matching the Lisp name
 120       ;; of this message so that typep and subtypep work
 121       (unless (eq name type)
 122         (collect-form `(deftype ,name () ',type)))
 123       ;; If no type override, define the type now
 124       (collect-form `(deftype ,name () '(member ,@vals))))
 125     (let ((options (loop for (key val) on options by #'cddr
 126                          collect `(make-instance 'protobuf-option
 127                                     :name ,key
 128                                     :value ,val))))
 129       `(progn
 130          define-enum
 131          (make-instance 'protobuf-enum
 132            :name   ,(or proto-name (class-name->proto name))
 133            :class  ',name
 134            :class-override ',type
 135            :options (list ,@options)
 136            :values  (list ,@evals)
 137            :documentation ,documentation)
 138          ,forms))))
 139
 140 ;; Define a message named 'name' and a Lisp 'defclass'
 141 (defmacro define-message (name (&key proto-name conc-name class options documentation)
 142                           &body fields &environment env)
 143   "Define a message named 'name' and a Lisp 'defclass'.
 144    'proto-name' can be used to override the defaultly generated Protobufs name.
 145    The body consists of fields, or 'define-enum' or 'define-message' forms.
 146    'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
 147    If 'class' is given, no Lisp class is defined. This feature is intended to be used
 148    to model messages that will be serialized from existing Lisp classes; unless you
 149    get the slot names correct in each field, it will be the case that trying to
 150    deserialize into a Lisp object won't work.
 151    'options' is a set of keyword/value pairs, both of which are strings.
 152    Fields take the form (name &key type default reader)
 153    'name' can be either a symbol giving the field name, or a list whose
 154    first element is the field name and whose second element is the index."
 155   (with-collectors ((enums collect-enum)
 156                     (msgs  collect-msg)
 157                     (flds  collect-field)
 158                     (slots collect-slot)
 159                     (forms collect-form))
 160     (let ((index 0))
 161       (declare (type fixnum index))
 162       (dolist (fld fields)
 163         (case (car fld)
 164           ((define-enum define-message define-extension)
 165            (destructuring-bind (&optional progn type model definers)
 166                (macroexpand-1 fld env)
 167              (assert (eq progn 'progn) ()
 168                      "The macroexpansion for ~S failed" fld)
 169              (map () #'collect-form definers)
 170              (ecase type
 171                ((define-enum)
 172                 (collect-enum model))
 173                ((define-message)
 174                 (collect-msg model))
 175                ((define-extension)
 176                 (collect-msg model)))))
 177           (otherwise
 178            (when (i= index 18999)                       ;skip over the restricted range
 179              (setq index 19999))
 180            (destructuring-bind (slot &key type default reader proto-name) fld
 181              (let* ((idx  (if (listp slot) (second slot) (iincf index)))
 182                     (slot (if (listp slot) (first slot) slot))
 183                     (reqd (clos-type-to-protobuf-required type))
 184                     (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 185                                       (symbol-package slot))))
 186                (multiple-value-bind (ptype pclass)
 187                    (clos-type-to-protobuf-type type)
 188                  (unless class
 189                    (collect-slot `(,slot :type ,type
 190                                          :accessor ,accessor
 191                                          :initarg ,(kintern (symbol-name slot))
 192                                          ,@(and default (list :initform default)))))
 193                  (collect-field `(make-instance 'protobuf-field
 194                                    :name  ,(or proto-name (slot-name->proto slot))
 195                                    :type  ,ptype
 196                                    :class ',pclass
 197                                    :required ,reqd
 198                                    :index  ,idx
 199                                    :value  ',slot
 200                                    :reader ',reader
 201                                    :default ,(and default (format nil "~A" default))
 202                                    :packed  ,(and (eq reqd :repeated)
 203                                                   (packed-type-p pclass)))))))))))
 204     (if class
 205       ;; If we've got a class override, define a type matching the Lisp name
 206       ;; of this message so that typep and subtypep work
 207       (unless (or (eq name class) (find-class name nil))
 208         (collect-form `(deftype ,name () ',class)))
 209       ;; If no class override, define the class now
 210       (collect-form `(defclass ,name () (,@slots))))
 211     (let ((options (loop for (key val) on options by #'cddr
 212                          collect `(make-instance 'protobuf-option
 213                                     :name ,key
 214                                     :value ,val))))
 215       `(progn
 216          define-message
 217          (make-instance 'protobuf-message
 218            :name  ,(or proto-name (class-name->proto name))
 219            :class ',name
 220            :class-override ',class
 221            :conc-name ,(and conc-name (string conc-name))
 222            :options  (list ,@options)
 223            :enums    (list ,@enums)
 224            :messages (list ,@msgs)
 225            :fields   (list ,@flds)
 226            :documentation ,documentation)
 227          ,forms))))
 228
 229 (defmacro define-extension (from to)
 230   "Define an extension range within a message.
 231    The \"body\" is the start and end of the range, both inclusive."
 232   `(progn
 233      define-extension
 234      (make-instance 'protobuf-extension
 235        :from ,from
 236        :to   ,to)
 237      ()))
 238
 239 ;; Define a service named 'name' with generic functions declared for
 240 ;; each of the RPCs within the service
 241 (defmacro define-service (name (&key proto-name options documentation)
 242                           &body rpc-specs)
 243   "Define a service named 'name' and a Lisp 'defgeneric'.
 244    'proto-name' can be used to override the defaultly generated Protobufs name.
 245    'options' is a set of keyword/value pairs, both of which are strings.
 246    The body is a set of RPC specs of the form (name (input-type output-type) &key options)."
 247   (with-collectors ((rpcs collect-rpc)
 248                     (forms collect-form))
 249     (dolist (rpc rpc-specs)
 250       (destructuring-bind (name (input-class output-class) &key options) rpc
 251         (let ((options (loop for (key val) on options by #'cddr
 252                              collect `(make-instance 'protobuf-option
 253                                         :name ,key
 254                                         :value ,val))))
 255           (collect-rpc `(make-instance 'protobuf-rpc
 256                           :name ,(class-name->proto name)
 257                           :class ',name
 258                           :input-type  ,(and input-class  (class-name->proto input-class))
 259                           :input-class ',input-class
 260                           :output-type  ,(and output-class (class-name->proto output-class))
 261                           :output-class ',output-class
 262                           :options (list ,@options)))
 263           ;;--- Is this really all we need as the stub for the RPC?
 264           (collect-form `(defgeneric ,name (,@(and input-class (list input-class)))
 265                            (declare (values ,output-class)))))))
 266     (let ((options (loop for (key val) on options by #'cddr
 267                          collect `(make-instance 'protobuf-option
 268                                     :name ,key
 269                                     :value ,val))))
 270       `(progn
 271          define-service
 272          (make-instance 'protobuf-service
 273            :name ,(or proto-name (class-name->proto name))
 274            :class ',name
 275            :options  (list ,@options)
 276            :rpcs (list ,@rpcs)
 277            :documentation ,documentation)
 278          ,forms))))
 279
 280 \f
 281 ;;; Ensure everything in a Protobufs schema is defined
 282
 283 (defvar *undefined-messages*)
 284
 285 ;; A very useful tool during development...
 286 (defun ensure-all-protobufs ()
 287   (let ((protos (sort
 288                  (delete-duplicates
 289                   (loop for p being the hash-values of *all-protobufs*
 290                         collect p))
 291                  #'string< :key #'proto-name)))
 292     (mapcan #'ensure-protobuf protos)))
 293
 294 (defmethod ensure-protobuf ((proto protobuf))
 295   "Ensure that all of the types are defined in the Protobufs schema 'proto'.
 296    This returns two values:
 297     - A list whose elements are (<undefined-type> \"message:field\" ...)
 298     - The accumulated warnings table that has the same information as objects."
 299   (let ((*undefined-messages* (make-hash-table))
 300         (trace (list proto)))
 301     (map () (curry #'ensure-message trace) (proto-messages proto))
 302     (map () (curry #'ensure-service trace) (proto-services proto))
 303     (loop for type being the hash-keys of *undefined-messages*
 304             using (hash-value things)
 305           collect (list* type
 306                          (mapcar #'(lambda (thing)
 307                                      (format nil "~A:~A" (proto-name (car thing)) (proto-name (cdr thing))))
 308                                  things)) into warnings
 309           finally (return (values warnings *undefined-messages*)))))
 310
 311 (defmethod ensure-message (trace (message protobuf-message))
 312   (let ((trace (cons message trace)))
 313     (map () (curry #'ensure-message trace) (proto-messages message))
 314     (map () (curry #'ensure-field trace message) (proto-fields message))))
 315
 316 (defmethod ensure-field (trace message (field protobuf-field))
 317   (ensure-type trace message field (proto-class field)))
 318
 319 (defmethod ensure-service (trace (service protobuf-service))
 320   (map () (curry #'ensure-rpc trace service) (proto-rpcs service)))
 321
 322 (defmethod ensure-rpc (trace service (rpc protobuf-rpc))
 323   (ensure-type trace service rpc (proto-input-type rpc))
 324   (ensure-type trace service rpc (proto-output-type rpc)))
 325
 326 ;; 'message' and 'field' can be a message and a field or a service and an RPC
 327 (defun ensure-type (trace message field type)
 328   (unless (keywordp type)
 329     (let ((msg (loop for p in trace
 330                      thereis (or (find-message p type)
 331                                  (find-enum p type)))))
 332       (unless msg
 333         (push (cons message field) (gethash type *undefined-messages*))))))