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 'type', corresponding to a .proto file of that name
  17 (defmacro define-proto (type (&key name syntax package lisp-package import optimize options documentation)
  18                         &body messages &environment env)
  19   "Define a schema named 'type', corresponding to a .proto file of that name.
  20    'name' can be used to override the defaultly generated Protobufs name.
  21    'syntax' and 'package' are as they would be in a .proto file.
  22    'lisp-package' can be used to specify a Lisp package if it is different from
  23    the Protobufs package given by 'package'.
  24    'import' is a list of pathname strings to be imported.
  25    'optimize' can be either :space (the default) or :speed; if it is :speed, the
  26    serialization code will be much faster, but much less compact.
  27    'options' is a property list, i.e., (\"key1\" \"val1\" \"key2\" \"val2\" ...).
  28
  29    The body consists of 'define-enum', 'define-message' or 'define-service' forms."
  30   (let* ((name     (or name (class-name->proto type)))
  31          (package  (and package (if (stringp package) package (string-downcase (string package)))))
  32          (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
  33          (options  (loop for (key val) on options by #'cddr
  34                          collect (make-instance 'protobuf-option
  35                                    :name  key
  36                                    :value val)))
  37          (imports  (if (listp import) import (list import)))
  38          (protobuf (make-instance 'protobuf
  39                      :class    type
  40                      :name     name
  41                      :syntax   (or syntax "proto2")
  42                      :package  package
  43                      :lisp-package (or lisp-pkg package)
  44                      :imports  imports
  45                      :options  (if optimize
  46                                  (append options (list (make-instance 'protobuf-option
  47                                                          :name  "optimize_for"
  48                                                          :value (if (eq optimize :speed) "SPEED" "CODE_SIZE")
  49                                                          :type  'symbol)))
  50                                  options)
  51                      :documentation documentation))
  52          (*protobuf* protobuf)
  53          (*protobuf-package* (or (find-package lisp-pkg)
  54                                  (find-package (string-upcase lisp-pkg))
  55                                  *package*)))
  56     (apply #'process-imports protobuf imports)
  57     (with-collectors ((forms collect-form))
  58       (dolist (msg messages)
  59         (assert (and (listp msg)
  60                      (member (car msg) '(define-enum define-message define-extend define-service))) ()
  61                 "The body of ~S must be one of ~{~S~^ or ~}"
  62                 'define-proto '(define-enum define-message define-extend define-service))
  63         ;; The macro-expander will return a form that consists
  64         ;; of 'progn' followed by a symbol naming what we've expanded
  65         ;; (define-enum, define-message, define-extend, define-service),
  66         ;; followed by the Lisp model object created by the defining form,
  67         ;; followed by other defining forms (e.g., deftype, defclass)
  68         (destructuring-bind (&optional progn model-type model definers)
  69             (macroexpand-1 msg env)
  70           (assert (eq progn 'progn) ()
  71                   "The macroexpansion for ~S failed" msg)
  72           (map () #'collect-form definers)
  73           (ecase model-type
  74             ((define-enum)
  75              (setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list model))))
  76             ((define-message define-extend)
  77              (setf (proto-parent model) protobuf)
  78              (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list model)))
  79              (when (eq (proto-message-type model) :extends)
  80                (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list model)))))
  81             ((define-service)
  82              (setf (proto-services protobuf) (nconc (proto-services protobuf) (list model)))))))
  83       (let ((var (intern (format nil "*~A*" type) *protobuf-package*)))
  84         `(progn
  85            ,@forms
  86            (defvar ,var nil)
  87            (let* ((old-proto ,var)
  88                   (new-proto ,protobuf))
  89              (when old-proto
  90                (multiple-value-bind (upgradable warnings)
  91                    (protobuf-upgradable old-proto new-proto)
  92                  (unless upgradable
  93                    (protobufs-warn "The old schema for ~S (~A) can't be safely upgraded; proceeding anyway"
  94                                    ',type ',name)
  95                    (map () #'protobufs-warn warnings))))
  96              (setq ,var new-proto)
  97              ,@(when (eq optimize :speed)
  98                  (with-collectors ((messages collect-message))
  99                    (labels ((collect-messages (message)
 100                               (collect-message message)
 101                               (map () #'collect-messages (proto-messages message))))
 102                    (map () #'collect-messages (proto-messages protobuf)))
 103                    (append (mapcar #'generate-object-size  messages)
 104                            (mapcar #'generate-serializer   messages)
 105                            (mapcar #'generate-deserializer messages))))
 106              new-proto))))))
 107
 108 ;; Define an enum type named 'type' and a Lisp 'deftype'
 109 (defmacro define-enum (type (&key name conc-name alias-for options documentation)
 110                        &body values)
 111   "Define a Protobufs enum type and a Lisp 'deftype' named 'type'.
 112    'name' can be used to override the defaultly generated Protobufs enum name.
 113    'conc-name' will be used as the prefix to the Lisp enum names, if it's supplied.
 114    If 'alias-for' is given, no Lisp 'deftype' will be defined. Instead, the enum
 115    will be used as an alias for an enum type that already exists in Lisp.
 116    'options' is a set of keyword/value pairs, both of which are strings.
 117
 118    The body consists of the enum values in the form 'name' or (name index)."
 119   (let* ((name    (or name (class-name->proto type)))
 120          (options (loop for (key val) on options by #'cddr
 121                         collect (make-instance 'protobuf-option
 122                                   :name  key
 123                                   :value val)))
 124          (index -1)
 125          (enum  (make-instance 'protobuf-enum
 126                   :class  type
 127                   :name   name
 128                   :alias-for alias-for
 129                   :options options
 130                   :documentation documentation)))
 131     (with-collectors ((vals  collect-val)
 132                       (forms collect-form))
 133       (dolist (val values)
 134         (let* ((idx  (if (listp val) (second val) (incf index)))
 135                (name (if (listp val) (first val)  val))
 136                (val-name  (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
 137                (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name)))
 138                (enum-val  (make-instance 'protobuf-enum-value
 139                             :name  (enum-name->proto enum-name)
 140                             :index idx
 141                             :value val-name)))
 142           (collect-val val-name)
 143           (setf (proto-values enum) (nconc (proto-values enum) (list enum-val)))))
 144       (if alias-for
 145         ;; If we've got an alias, define a a type that is the subtype of
 146         ;; the Lisp enum so that typep and subtypep work
 147         (unless (eq type alias-for)
 148           (collect-form `(deftype ,type () ',alias-for)))
 149         ;; If no alias, define the Lisp enum type now
 150         (collect-form `(deftype ,type () '(member ,@vals))))
 151       `(progn
 152          define-enum
 153          ,enum
 154          ,forms))))
 155
 156 ;; Define a message named 'name' and a Lisp 'defclass'
 157 (defmacro define-message (type (&key name conc-name alias-for options documentation)
 158                           &body fields &environment env)
 159   "Define a message named 'type' and a Lisp 'defclass'.
 160    'name' can be used to override the defaultly generated Protobufs message name.
 161    The body consists of fields, or 'define-enum' or 'define-message' forms.
 162    'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
 163    If 'alias-for' is given, no Lisp class is defined. Instead, the message will be
 164    used as an alias for a class that already exists in Lisp. This feature is intended
 165    to be used to define messages that will be serialized from existing Lisp classes;
 166    unless you get the slot names or readers exactly right for each field, it will be
 167    the case that trying to (de)serialize into a Lisp object won't work.
 168    'options' is a set of keyword/value pairs, both of which are strings.
 169
 170    Fields take the form (slot &key type name default reader)
 171    'slot' can be either a symbol giving the field name, or a list whose
 172    first element is the slot name and whose second element is the index.
 173    'type' is the type of the slot.
 174    'name' can be used to override the defaultly generated Protobufs field name.
 175    'default' is the default value for the slot.
 176    'reader' is a Lisp slot reader function to use to get the value, instead of
 177    using 'slot-value'; this is often used when aliasing an existing class.
 178    'writer' is a Lisp slot writer function to use to set the value."
 179   (let* ((name    (or name (class-name->proto type)))
 180          (options (loop for (key val) on options by #'cddr
 181                         collect (make-instance 'protobuf-option
 182                                   :name  key
 183                                   :value val)))
 184          (message (make-instance 'protobuf-message
 185                     :class type
 186                     :name  name
 187                     :parent *protobuf*
 188                     :alias-for alias-for
 189                     :conc-name (and conc-name (string conc-name))
 190                     :options  options
 191                     :documentation documentation))
 192          (index 0)
 193          (*protobuf* message))
 194     (with-collectors ((slots collect-slot)
 195                       (forms collect-form))
 196       (dolist (field fields)
 197         (case (car field)
 198           ((define-enum define-message define-extend define-extension define-group)
 199            (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
 200                (macroexpand-1 field env)
 201              (assert (eq progn 'progn) ()
 202                      "The macroexpansion for ~S failed" field)
 203              (map () #'collect-form definers)
 204              (ecase model-type
 205                ((define-enum)
 206                 (setf (proto-enums message) (nconc (proto-enums message) (list model))))
 207                ((define-message define-extend)
 208                 (setf (proto-parent model) message)
 209                 (setf (proto-messages message) (nconc (proto-messages message) (list model)))
 210                 (when (eq (proto-message-type model) :extends)
 211                   (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
 212                ((define-group)
 213                 (setf (proto-parent model) message)
 214                 (setf (proto-messages message) (nconc (proto-messages message) (list model)))
 215                 (when extra-slot
 216                   (collect-slot extra-slot))
 217                 (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
 218                ((define-extension)
 219                 (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
 220           (otherwise
 221            (multiple-value-bind (field slot idx)
 222                (process-field field index :conc-name conc-name :alias-for alias-for)
 223              (assert (not (find (proto-index field) (proto-fields message) :key #'proto-index)) ()
 224                      "The field ~S overlaps with another field in ~S"
 225                      (proto-value field) (proto-class message))
 226              (setq index idx)
 227              (when slot
 228                (collect-slot slot))
 229              (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
 230       (if alias-for
 231         ;; If we've got an alias, define a a type that is the subtype of
 232         ;; the Lisp class that typep and subtypep work
 233         (unless (or (eq type alias-for) (find-class type nil))
 234           (collect-form `(deftype ,type () ',alias-for)))
 235         ;; If no alias, define the class now
 236         (collect-form `(defclass ,type () (,@slots)
 237                          ,@(and documentation `((:documentation ,documentation))))))
 238       `(progn
 239          define-message
 240          ,message
 241          ,forms))))
 242
 243 (defmacro define-extension (from to)
 244   "Define an extension range within a message.
 245    The \"body\" is the start and end of the range, both inclusive."
 246   `(progn
 247      define-extension
 248      ,(make-instance 'protobuf-extension
 249         :from from
 250         :to   (if (eq to 'max) #.(1- (ash 1 29)) to))
 251      ()))
 252
 253 (defmacro define-extend (type (&key name options documentation)
 254                          &body fields &environment env)
 255   "Define an extension to the message named 'type'.
 256    'name' can be used to override the defaultly generated Protobufs message name.
 257    The body consists only  of fields.
 258    'options' is a set of keyword/value pairs, both of which are strings.
 259
 260    Fields take the form (slot &key type name default reader)
 261    'slot' can be either a symbol giving the field name, or a list whose
 262    first element is the slot name and whose second element is the index.
 263    'type' is the type of the slot.
 264    'name' can be used to override the defaultly generated Protobufs field name.
 265    'default' is the default value for the slot.
 266    'reader' is a Lisp slot reader function to use to get the value, instead of
 267    using 'slot-value'; this is often used when aliasing an existing class.
 268    'writer' is a Lisp slot writer function to use to set the value."
 269   (let* ((name    (or name (class-name->proto type)))
 270          (options (loop for (key val) on options by #'cddr
 271                         collect (make-instance 'protobuf-option
 272                                   :name  key
 273                                   :value val)))
 274          (message   (find-message *protobuf* name))
 275          (conc-name (and message (proto-conc-name message)))
 276          (alias-for (and message (proto-alias-for message)))
 277          (extends (and message
 278                        (make-instance 'protobuf-message
 279                          :class  type
 280                          :name   name
 281                          :parent (proto-parent message)
 282                          :conc-name conc-name
 283                          :alias-for alias-for
 284                          :enums    (copy-list (proto-enums message))
 285                          :messages (copy-list (proto-messages message))
 286                          :fields   (copy-list (proto-fields message))
 287                          :options  (or options (copy-list (proto-options message)))
 288                          :extensions (copy-list (proto-extensions message))
 289                          :message-type :extends         ;this message is an extension
 290                          :documentation documentation)))
 291          (*protobuf* extends)
 292          (index 0))
 293     (assert message ()
 294             "There is no message named ~A to extend" name)
 295     (assert (eq type (proto-class message)) ()
 296             "The type ~S doesn't match the type of the message being extended ~S"
 297             type message)
 298     (with-collectors ((forms collect-form))
 299       (dolist (field fields)
 300         (assert (not (member (car field)
 301                              '(define-enum define-message define-extend define-extension))) ()
 302                 "The body of ~S can only contain field and group definitions" 'define-extend)
 303         (case (car field)
 304           ((define-group)
 305            (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
 306                (macroexpand-1 field env)
 307              (assert (eq progn 'progn) ()
 308                      "The macroexpansion for ~S failed" field)
 309              (map () #'collect-form definers)
 310              (ecase model-type
 311                ((define-group)
 312                 (setf (proto-parent model) extends)
 313                 (setf (proto-messages extends) (nconc (proto-messages extends) (list model)))
 314                 (when extra-slot
 315                   ;;--- Fix all this duplicated code!
 316                   (let* ((inits  (cdr extra-slot))
 317                          (sname  (car extra-slot))
 318                          (stable (fintern "~A-VALUES" sname))
 319                          (stype  (getf inits :type))
 320                          (reader (or (getf inits :accessor)
 321                                      (getf inits :reader)
 322                                      (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
 323                                              (symbol-package sname))))
 324                          (writer (or (getf inits :writer)
 325                                      (intern (format nil "~A-~A" reader 'setter)
 326                                              (symbol-package sname))))
 327                          (default (getf inits :initform)))
 328                     (collect-form `(without-redefinition-warnings ()
 329                                      (let ((,stable (make-hash-table :test #'eq :weak t)))
 330                                        ,@(and reader `((defmethod ,reader ((object ,type))
 331                                                          (gethash object ,stable ,default))))
 332                                        ,@(and writer `((defmethod ,writer ((object ,type) value)
 333                                                          (declare (type ,stype value))
 334                                                          (setf (gethash object ,stable) value))))
 335                                        ;; For Python compatibility
 336                                        (defmethod get-extension ((object ,type) (slot (eql ',sname)))
 337                                          (values (gethash object ,stable ,default)))
 338                                        (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
 339                                          (setf (gethash object ,stable) value))
 340                                        (defmethod has-extension ((object ,type) (slot (eql ',sname)))
 341                                          (multiple-value-bind (value foundp)
 342                                              (gethash object ,stable ,default)
 343                                            (declare (ignore value))
 344                                            foundp))
 345                                        (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
 346                                          (remhash object ,stable))
 347                                        ,@(and writer `((defsetf ,reader ,writer))))))))
 348                 (setf (proto-message-type extra-field) :extends) ;this field is an extension
 349                 (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field)))
 350                 (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list extra-field)))))))
 351           (otherwise
 352            (multiple-value-bind (field slot idx)
 353                (process-field field index :conc-name conc-name :alias-for alias-for)
 354              (assert (not (find (proto-index field) (proto-fields extends) :key #'proto-index)) ()
 355                      "The field ~S overlaps with another field in ~S"
 356                      (proto-value field) (proto-class extends))
 357              (assert (index-within-extensions-p idx message) ()
 358                      "The index ~D is not in range for extending ~S"
 359                      idx (proto-class message))
 360              (setq index idx)
 361              (when slot
 362                (let* ((inits  (cdr slot))
 363                       (sname  (car slot))
 364                       (stable (fintern "~A-VALUES" sname))
 365                       (stype  (getf inits :type))
 366                       (reader (or (getf inits :accessor)
 367                                   (getf inits :reader)
 368                                   (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
 369                                           (symbol-package sname))))
 370                       (writer (or (getf inits :writer)
 371                                   (intern (format nil "~A-~A" reader 'setter)
 372                                           (symbol-package sname))))
 373                       (default (getf inits :initform)))
 374                  ;; For the extended slots, each slot gets its own table
 375                  ;; keyed by the object, which lets us avoid having a slot in each
 376                  ;; instance that holds a table keyed by the slot name
 377                  ;; Multiple 'define-extends' on the same class in the same image
 378                  ;; will result in harmless redefinitions, so squelch the warnings
 379                  ;;--- Maybe these methods need to be defined in 'define-message'?
 380                  (collect-form `(without-redefinition-warnings ()
 381                                   (let ((,stable (make-hash-table :test #'eq :weak t)))
 382                                     ,@(and reader `((defmethod ,reader ((object ,type))
 383                                                       (gethash object ,stable ,default))))
 384                                     ,@(and writer `((defmethod ,writer ((object ,type) value)
 385                                                       (declare (type ,stype value))
 386                                                       (setf (gethash object ,stable) value))))
 387                                     ;; For Python compatibility
 388                                     (defmethod get-extension ((object ,type) (slot (eql ',sname)))
 389                                       (values (gethash object ,stable ,default)))
 390                                     (defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
 391                                       (setf (gethash object ,stable) value))
 392                                     (defmethod has-extension ((object ,type) (slot (eql ',sname)))
 393                                       (multiple-value-bind (value foundp)
 394                                           (gethash object ,stable ,default)
 395                                         (declare (ignore value))
 396                                         foundp))
 397                                     (defmethod clear-extension ((object ,type) (slot (eql ',sname)))
 398                                       (remhash object ,stable))
 399                                     ,@(and writer `((defsetf ,reader ,writer))))))
 400                  ;; This so that (de)serialization works
 401                  (setf (proto-reader field) reader
 402                        (proto-writer field) writer)))
 403              (setf (proto-message-type field) :extends)         ;this field is an extension
 404              (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))
 405              (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))))
 406       `(progn
 407          define-extend
 408          ,extends
 409          ,forms))))
 410
 411 (defun index-within-extensions-p (index message)
 412   (let ((extensions (proto-extensions message)))
 413     (some #'(lambda (ext)
 414               (and (i>= index (proto-extension-from ext))
 415                    (i<= index (proto-extension-to ext))))
 416           extensions)))
 417
 418 (defmacro define-group (type (&key index arity name conc-name alias-for options documentation)
 419                         &body fields &environment env)
 420   "Define a message named 'type' and a Lisp 'defclass', *and* a field named type.
 421    This is deprecated in Protobufs, but if you have to use it, you must give
 422    'index' as the field index and 'arity' of :required, :optional or :repeated.
 423    'name' can be used to override the defaultly generated Protobufs message name.
 424    The body consists of fields, or 'define-enum' or 'define-message' forms.
 425    'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
 426    If 'alias-for' is given, no Lisp class is defined. Instead, the message will be
 427    used as an alias for a class that already exists in Lisp. This feature is intended
 428    to be used to define messages that will be serialized from existing Lisp classes;
 429    unless you get the slot names or readers exactly right for each field, it will be
 430    the case that trying to (de)serialize into a Lisp object won't work.
 431    'options' is a set of keyword/value pairs, both of which are strings.
 432
 433    Fields take the form (slot &key type name default reader)
 434    'slot' can be either a symbol giving the field name, or a list whose
 435    first element is the slot name and whose second element is the index.
 436    'type' is the type of the slot.
 437    'name' can be used to override the defaultly generated Protobufs field name.
 438    'default' is the default value for the slot.
 439    'reader' is a Lisp slot reader function to use to get the value, instead of
 440    using 'slot-value'; this is often used when aliasing an existing class.
 441    'writer' is a Lisp slot writer function to use to set the value."
 442   (check-type index integer)
 443   (check-type arity (member :required :optional :repeated))
 444   (let* ((slot    (or (and name (proto->slot-name name)) type))
 445          (name    (or name (class-name->proto type)))
 446          (options (loop for (key val) on options by #'cddr
 447                         collect (make-instance 'protobuf-option
 448                                   :name  key
 449                                   :value val)))
 450          (mslot   (unless alias-for
 451                     `(,slot ,@(case arity
 452                                 (:required
 453                                  `(:type ,type))
 454                                 (:optional
 455                                  `(:type (or ,type null)
 456                                    :initform nil))
 457                                 (:repeated
 458                                  `(:type (list-of ,type)
 459                                    :initform ())))
 460                             :initarg ,(kintern (symbol-name slot)))))
 461          (mfield  (make-instance 'protobuf-field
 462                     :name  (slot-name->proto slot)
 463                     :value slot
 464                     :type  name
 465                     :class type
 466                     ;; One of :required, :optional or :repeated
 467                     :required arity
 468                     :index index
 469                     :message-type :group))
 470          (message (make-instance 'protobuf-message
 471                     :class type
 472                     :name  name
 473                     :alias-for alias-for
 474                     :conc-name (and conc-name (string conc-name))
 475                     :options  options
 476                     :message-type :group                ;this message is a group
 477                     :documentation documentation))
 478          (index 0)
 479          (*protobuf* message))
 480     (with-collectors ((slots collect-slot)
 481                       (forms collect-form))
 482       (dolist (field fields)
 483         (case (car field)
 484           ((define-enum define-message define-extend define-extension define-group)
 485            (destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
 486                (macroexpand-1 field env)
 487              (assert (eq progn 'progn) ()
 488                      "The macroexpansion for ~S failed" field)
 489              (map () #'collect-form definers)
 490              (ecase model-type
 491                ((define-enum)
 492                 (setf (proto-enums message) (nconc (proto-enums message) (list model))))
 493                ((define-message define-extend)
 494                 (setf (proto-parent model) message)
 495                 (setf (proto-messages message) (nconc (proto-messages message) (list model)))
 496                 (when (eq (proto-message-type model) :extends)
 497                   (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
 498                ((define-group)
 499                 (setf (proto-parent model) message)
 500                 (setf (proto-messages message) (nconc (proto-messages message) (list model)))
 501                 (when extra-slot
 502                   (collect-slot extra-slot))
 503                 (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
 504                ((define-extension)
 505                 (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
 506           (otherwise
 507            (multiple-value-bind (field slot idx)
 508                (process-field field index :conc-name conc-name :alias-for alias-for)
 509              (assert (not (find (proto-index field) (proto-fields message) :key #'proto-index)) ()
 510                      "The field ~S overlaps with another field in ~S"
 511                      (proto-value field) (proto-class message))
 512              (setq index idx)
 513              (when slot
 514                (collect-slot slot))
 515              (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
 516       (if alias-for
 517         ;; If we've got an alias, define a a type that is the subtype of
 518         ;; the Lisp class that typep and subtypep work
 519         (unless (or (eq type alias-for) (find-class type nil))
 520           (collect-form `(deftype ,type () ',alias-for)))
 521         ;; If no alias, define the class now
 522         (collect-form `(defclass ,type () (,@slots)
 523                          ,@(and documentation `((:documentation ,documentation))))))
 524       `(progn
 525          define-group
 526          ,message
 527          ,forms
 528          ,mfield
 529          ,mslot))))
 530
 531 (defun process-field (field index &key conc-name alias-for)
 532   "Process one field descriptor within 'define-message' or 'define-extend'.
 533    Returns a 'proto-field' object, a CLOS slot form and the incremented field index."
 534   (when (i= index 18999)                                ;skip over the restricted range
 535     (setq index 19999))
 536   (destructuring-bind (slot &key type (default nil default-p) reader writer name documentation) field
 537     (let* ((idx  (if (listp slot) (second slot) (iincf index)))
 538            (slot (if (listp slot) (first slot) slot))
 539            (reqd (clos-type-to-protobuf-required type))
 540            (reader (if (eq reader 't)
 541                      (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 542                              (symbol-package slot))
 543                      reader)))
 544       (multiple-value-bind (ptype pclass)
 545           (clos-type-to-protobuf-type type)
 546         (let ((slot (unless alias-for
 547                       `(,slot :type ,type
 548                               ,@(and reader
 549                                      (if writer
 550                                        `(:reader ,reader)
 551                                        `(:accessor ,reader)))
 552                               ,@(and writer
 553                                      `(:writer ,writer))
 554                               :initarg ,(kintern (symbol-name slot))
 555                               ,@(cond ((and (not default-p)
 556                                             (eq reqd :repeated))
 557                                        `(:initform ()))
 558                                       ((and (not default-p)
 559                                             (eq reqd :optional)
 560                                             ;; Use unbound for booleans only
 561                                             (not (eq pclass :bool)))
 562                                        `(:initform nil))
 563                                       (default-p
 564                                         `(:initform ,(protobuf-default-to-clos-init default type)))))))
 565               (field (make-instance 'protobuf-field
 566                        :name  (or name (slot-name->proto slot))
 567                        :type  ptype
 568                        :class pclass
 569                        :required reqd
 570                        :index  idx
 571                        :value  slot
 572                        :reader reader
 573                        :writer writer
 574                        :default default
 575                        :packed  (and (eq reqd :repeated)
 576                                      (packed-type-p pclass))
 577                        :documentation documentation)))
 578           (values field slot idx))))))
 579
 580 ;; Define a service named 'type' with generic functions declared for
 581 ;; each of the methods within the service
 582 (defmacro define-service (type (&key name options documentation)
 583                           &body method-specs)
 584   "Define a service named 'type' and Lisp 'defgeneric' for all its methods.
 585    'name' can be used to override the defaultly generated Protobufs service name.
 586    'options' is a set of keyword/value pairs, both of which are strings.
 587
 588    The body is a set of method specs of the form (name (input-type output-type) &key options).
 589    'input-type' and 'output-type' may also be of the form (type &key name)."
 590   (let* ((name    (or name (class-name->proto type)))
 591          (options (loop for (key val) on options by #'cddr
 592                         collect (make-instance 'protobuf-option
 593                                   :name  key
 594                                   :value val)))
 595          (service (make-instance 'protobuf-service
 596                     :class type
 597                     :name  name
 598                     :options options
 599                     :documentation documentation)))
 600     (with-collectors ((forms collect-form))
 601       (dolist (method method-specs)
 602         (destructuring-bind (function (input-type output-type) &key name options documentation) method
 603           (let* ((input-name (and (listp input-type)
 604                                   (getf (cdr input-type) :name)))
 605                  (input-type (if (listp input-type) (car input-type) input-type))
 606                  (output-name (and (listp output-type)
 607                                    (getf (cdr output-type) :name)))
 608                  (output-type (if (listp output-type) (car output-type) output-type))
 609                  (options (loop for (key val) on options by #'cddr
 610                                 collect (make-instance 'protobuf-option
 611                                           :name  key
 612                                           :value val)))
 613                  (method  (make-instance 'protobuf-method
 614                             :class function
 615                             :name  (or name (class-name->proto function))
 616                             :input-type  input-type
 617                             :input-name  (or input-name (class-name->proto input-type))
 618                             :output-type output-type
 619                             :output-name (or output-name (class-name->proto output-type))
 620                             :options options
 621                             :documentation documentation)))
 622             (setf (proto-methods service) (nconc (proto-methods service) (list method)))
 623             ;; The following are the hooks to CL-Stubby
 624             (let* ((package   (symbol-package function))
 625                    (client-fn function)
 626                    (server-fn (intern (format nil "~A-~A" 'do function) package))
 627                    (vinput    (intern (format nil "~A-~A" (symbol-name input-type) 'in) package))
 628                    (voutput   (intern (format nil "~A-~A" (symbol-name output-type) 'out) package))
 629                    (vchannel  (intern (symbol-name 'channel) package))
 630                    (vcallback (intern (symbol-name 'callback) package)))
 631               ;; The client side stub, e.g., 'read-air-reservation'.
 632               ;; The expectation is that CL-Stubby will provide macrology to make it
 633               ;; easy to implement a method for this on each kind of channel (HTTP, TCP socket,
 634               ;; IPC, etc). Unlike C++/Java/Python, we don't need a client-side subclass,
 635               ;; because we can just use multi-methods.
 636               ;; The CL-Stubby macros take care of serializing the input, transmitting the
 637               ;; request over the wire, waiting for input (or not if it's asynchronous),
 638               ;; filling in the output, and calling the callback (if it's synchronous).
 639               ;; It's not very Lispy to side-effect an output object, but it makes
 640               ;; asynchronous calls simpler.
 641               (collect-form `(defgeneric ,client-fn (,vchannel ,vinput ,voutput &key ,vcallback)
 642                                ,@(and documentation `((:documentation ,documentation)))
 643                                (declare (values ,output-type))))
 644               ;; The server side stub, e.g., 'do-read-air-reservation'.
 645               ;; The expectation is that the server-side program will implement
 646               ;; a method with the business logic for this on each kind of channel
 647               ;; (HTTP, TCP socket, IPC, etc), possibly on a server-side subclass
 648               ;; of the input class
 649               ;; The business logic is expected to perform the correct operations on
 650               ;; the input object, which arrived via Protobufs, and produce an output
 651               ;; of the given type, which will be serialized as a result.
 652               ;; The channel objects hold client identity information, deadline info,
 653               ;; etc, and can be side-effected to indicate success or failure
 654               ;; CL-Stubby provides the channel classes and does (de)serialization, etc
 655               (collect-form `(defgeneric ,server-fn (,vchannel ,vinput ,voutput &key ,vcallback)
 656                                ,@(and documentation `((:documentation ,documentation)))
 657                                (declare (values ,output-type))))))))
 658       `(progn
 659          define-service
 660          ,service
 661          ,forms))))
 662
 663 \f
 664 ;;; Ensure everything in a Protobufs schema is defined
 665
 666 (defvar *undefined-messages*)
 667
 668 ;; A very useful tool during development...
 669 (defun ensure-all-protobufs ()
 670   (let ((protos (sort
 671                  (delete-duplicates
 672                   (loop for p being the hash-values of *all-protobufs*
 673                         collect p))
 674                  #'string< :key #'proto-name)))
 675     (mapcan #'ensure-protobuf protos)))
 676
 677 (defmethod ensure-protobuf ((proto protobuf))
 678   "Ensure that all of the types are defined in the Protobufs schema 'proto'.
 679    This returns two values:
 680     - A list whose elements are (<undefined-type> \"message:field\" ...)
 681     - The accumulated warnings table that has the same information as objects."
 682   (let ((*undefined-messages* (make-hash-table))
 683         (trace (list proto)))
 684     (map () (curry #'ensure-message trace) (proto-messages proto))
 685     (map () (curry #'ensure-service trace) (proto-services proto))
 686     (loop for type being the hash-keys of *undefined-messages*
 687             using (hash-value things)
 688           collect (list* type
 689                          (mapcar #'(lambda (thing)
 690                                      (format nil "~A:~A" (proto-name (car thing)) (proto-name (cdr thing))))
 691                                  things)) into warnings
 692           finally (return (values warnings *undefined-messages*)))))
 693
 694 (defmethod ensure-message (trace (message protobuf-message))
 695   (let ((trace (cons message trace)))
 696     (map () (curry #'ensure-message trace) (proto-messages message))
 697     (map () (curry #'ensure-field trace message) (proto-fields message))))
 698
 699 (defmethod ensure-field (trace message (field protobuf-field))
 700   (ensure-type trace message field (proto-class field)))
 701
 702 (defmethod ensure-service (trace (service protobuf-service))
 703   (map () (curry #'ensure-method trace service) (proto-methods service)))
 704
 705 (defmethod ensure-method (trace service (method protobuf-method))
 706   (ensure-type trace service method (proto-input-type method))
 707   (ensure-type trace service method (proto-output-type method)))
 708
 709 ;; 'message' and 'field' can be a message and a field or a service and a method
 710 (defun ensure-type (trace message field type)
 711   (unless (keywordp type)
 712     (let ((msg (loop for p in trace
 713                      thereis (or (find-message p type)
 714                                  (find-enum p type)))))
 715       (unless msg
 716         (push (cons message field) (gethash type *undefined-messages*))))))