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 alias-for 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 'alias-for' is given, no Lisp type is defined. Instead, the enum will be
 100    used as an alias for an enum type that already exists 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 alias-for
 119       ;; If we've got an alias, define a type matching the Lisp name
 120       ;; of this message so that typep and subtypep work
 121       (unless (eq name alias-for)
 122         (collect-form `(deftype ,name () ',alias-for)))
 123       ;; If no alias, define the Lisp enum 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            :alias-for ',alias-for
 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 alias-for 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 'alias-for' is given, no Lisp class is defined. Instead, the message will be
 148    used as an alias for a class that already exists in Lisp. This feature is intended
 149    to be used to defined messages that will be serialized from existing Lisp classes;
 150    unless you get the slot names or readers exactly right for each field, it will be
 151    the case that trying to (de)serialize into a Lisp object won't work.
 152    'options' is a set of keyword/value pairs, both of which are strings.
 153    Fields take the form (name &key type default reader)
 154    'name' can be either a symbol giving the field name, or a list whose
 155    first element is the field name and whose second element is the index."
 156   (with-collectors ((enums collect-enum)
 157                     (msgs  collect-msg)
 158                     (flds  collect-field)
 159                     (slots collect-slot)
 160                     (forms collect-form))
 161     (let ((index 0))
 162       (declare (type fixnum index))
 163       (dolist (fld fields)
 164         (case (car fld)
 165           ((define-enum define-message define-extension)
 166            (destructuring-bind (&optional progn type model definers)
 167                (macroexpand-1 fld env)
 168              (assert (eq progn 'progn) ()
 169                      "The macroexpansion for ~S failed" fld)
 170              (map () #'collect-form definers)
 171              (ecase type
 172                ((define-enum)
 173                 (collect-enum model))
 174                ((define-message)
 175                 (collect-msg model))
 176                ((define-extension)
 177                 (collect-msg model)))))
 178           (otherwise
 179            (when (i= index 18999)                       ;skip over the restricted range
 180              (setq index 19999))
 181            (destructuring-bind (slot &key type default reader proto-name) fld
 182              (let* ((idx  (if (listp slot) (second slot) (iincf index)))
 183                     (slot (if (listp slot) (first slot) slot))
 184                     (reqd (clos-type-to-protobuf-required type))
 185                     (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 186                                       (symbol-package slot))))
 187                (multiple-value-bind (ptype pclass)
 188                    (clos-type-to-protobuf-type type)
 189                  (unless alias-for
 190                    (collect-slot `(,slot :type ,type
 191                                          :accessor ,accessor
 192                                          :initarg ,(kintern (symbol-name slot))
 193                                          ,@(and default (list :initform default)))))
 194                  (collect-field `(make-instance 'protobuf-field
 195                                    :name  ,(or proto-name (slot-name->proto slot))
 196                                    :type  ,ptype
 197                                    :class ',pclass
 198                                    :required ,reqd
 199                                    :index  ,idx
 200                                    :value  ',slot
 201                                    :reader ',reader
 202                                    :default ,(and default (format nil "~A" default))
 203                                    :packed  ,(and (eq reqd :repeated)
 204                                                   (packed-type-p pclass)))))))))))
 205     (if alias-for
 206       ;; If we've got an alias, define a type matching the Lisp name
 207       ;; of this message so that typep and subtypep work
 208       (unless (or (eq name alias-for) (find-class name nil))
 209         (collect-form `(deftype ,name () ',alias-for)))
 210       ;; If no alias, define the class now
 211       (collect-form `(defclass ,name () (,@slots))))
 212     (let ((options (loop for (key val) on options by #'cddr
 213                          collect `(make-instance 'protobuf-option
 214                                     :name ,key
 215                                     :value ,val))))
 216       `(progn
 217          define-message
 218          (make-instance 'protobuf-message
 219            :name  ,(or proto-name (class-name->proto name))
 220            :class ',name
 221            :alias-for ',alias-for
 222            :conc-name ,(and conc-name (string conc-name))
 223            :options  (list ,@options)
 224            :enums    (list ,@enums)
 225            :messages (list ,@msgs)
 226            :fields   (list ,@flds)
 227            :documentation ,documentation)
 228          ,forms))))
 229
 230 (defmacro define-extension (from to)
 231   "Define an extension range within a message.
 232    The \"body\" is the start and end of the range, both inclusive."
 233   `(progn
 234      define-extension
 235      (make-instance 'protobuf-extension
 236        :from ,from
 237        :to   ,to)
 238      ()))
 239
 240 ;; Define a service named 'name' with generic functions declared for
 241 ;; each of the RPCs within the service
 242 (defmacro define-service (name (&key proto-name options documentation)
 243                           &body rpc-specs)
 244   "Define a service named 'name' and a Lisp 'defgeneric'.
 245    'proto-name' can be used to override the defaultly generated Protobufs name.
 246    'options' is a set of keyword/value pairs, both of which are strings.
 247    The body is a set of RPC specs of the form (name (input-type output-type) &key options)."
 248   (with-collectors ((rpcs collect-rpc)
 249                     (forms collect-form))
 250     (dolist (rpc rpc-specs)
 251       (destructuring-bind (name (input-class output-class) &key options) rpc
 252         (let ((options (loop for (key val) on options by #'cddr
 253                              collect `(make-instance 'protobuf-option
 254                                         :name ,key
 255                                         :value ,val))))
 256           (collect-rpc `(make-instance 'protobuf-rpc
 257                           :name ,(class-name->proto name)
 258                           :class ',name
 259                           :input-type  ,(and input-class  (class-name->proto input-class))
 260                           :input-class ',input-class
 261                           :output-type  ,(and output-class (class-name->proto output-class))
 262                           :output-class ',output-class
 263                           :options (list ,@options)))
 264           ;;--- Is this really all we need as the stub for the RPC?
 265           (collect-form `(defgeneric ,name (,@(and input-class (list input-class)))
 266                            (declare (values ,output-class)))))))
 267     (let ((options (loop for (key val) on options by #'cddr
 268                          collect `(make-instance 'protobuf-option
 269                                     :name ,key
 270                                     :value ,val))))
 271       `(progn
 272          define-service
 273          (make-instance 'protobuf-service
 274            :name ,(or proto-name (class-name->proto name))
 275            :class ',name
 276            :options  (list ,@options)
 277            :rpcs (list ,@rpcs)
 278            :documentation ,documentation)
 279          ,forms))))
 280
 281 \f
 282 ;;; Ensure everything in a Protobufs schema is defined
 283
 284 (defvar *undefined-messages*)
 285
 286 ;; A very useful tool during development...
 287 (defun ensure-all-protobufs ()
 288   (let ((protos (sort
 289                  (delete-duplicates
 290                   (loop for p being the hash-values of *all-protobufs*
 291                         collect p))
 292                  #'string< :key #'proto-name)))
 293     (mapcan #'ensure-protobuf protos)))
 294
 295 (defmethod ensure-protobuf ((proto protobuf))
 296   "Ensure that all of the types are defined in the Protobufs schema 'proto'.
 297    This returns two values:
 298     - A list whose elements are (<undefined-type> \"message:field\" ...)
 299     - The accumulated warnings table that has the same information as objects."
 300   (let ((*undefined-messages* (make-hash-table))
 301         (trace (list proto)))
 302     (map () (curry #'ensure-message trace) (proto-messages proto))
 303     (map () (curry #'ensure-service trace) (proto-services proto))
 304     (loop for type being the hash-keys of *undefined-messages*
 305             using (hash-value things)
 306           collect (list* type
 307                          (mapcar #'(lambda (thing)
 308                                      (format nil "~A:~A" (proto-name (car thing)) (proto-name (cdr thing))))
 309                                  things)) into warnings
 310           finally (return (values warnings *undefined-messages*)))))
 311
 312 (defmethod ensure-message (trace (message protobuf-message))
 313   (let ((trace (cons message trace)))
 314     (map () (curry #'ensure-message trace) (proto-messages message))
 315     (map () (curry #'ensure-field trace message) (proto-fields message))))
 316
 317 (defmethod ensure-field (trace message (field protobuf-field))
 318   (ensure-type trace message field (proto-class field)))
 319
 320 (defmethod ensure-service (trace (service protobuf-service))
 321   (map () (curry #'ensure-rpc trace service) (proto-rpcs service)))
 322
 323 (defmethod ensure-rpc (trace service (rpc protobuf-rpc))
 324   (ensure-type trace service rpc (proto-input-type rpc))
 325   (ensure-type trace service rpc (proto-output-type rpc)))
 326
 327 ;; 'message' and 'field' can be a message and a field or a service and an RPC
 328 (defun ensure-type (trace message field type)
 329   (unless (keywordp type)
 330     (let ((msg (loop for p in trace
 331                      thereis (or (find-message p type)
 332                                  (find-enum p type)))))
 333       (unless msg
 334         (push (cons message field) (gethash type *undefined-messages*))))))