model-classes.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, Inc.  All rights reserved.       ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protocol buffers model classes
  15
  16 (defvar *all-schemas* (make-hash-table :test #'equal)
  17   "A global table mapping names to 'protobuf-schema' objects.")
  18
  19 (defgeneric find-schema (name)
  20   (:documentation
  21    "Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
  22
  23 (defmethod find-schema ((name symbol))
  24   (assert (not (keywordp name)))
  25   (values (gethash name *all-schemas*)))
  26
  27 (defmethod find-schema ((path pathname))
  28   "Given a pathname, return the 'protobuf-schema' object that came from that path."
  29   (values (gethash path *all-schemas*)))
  30
  31
  32 (defvar *all-messages* (make-hash-table :test #'equal)
  33   "A global table mapping Lisp class names to 'protobuf-message' objects.")
  34
  35 (defgeneric find-message-for-class (class)
  36   (:documentation
  37    "Given a class or class name, return the message that globally has that name."))
  38
  39 (defmethod find-message-for-class (class)
  40   "Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
  41   (values (gethash class *all-messages*)))
  42
  43 (defmethod find-message-for-class ((class class))
  44   (values (gethash (class-name class) *all-messages*)))
  45
  46
  47 ;;; "Thread-local" variables
  48
  49 ;; Parsing (and even pretty printing schemas) want to keep track of the current schema
  50 (defvar *protobuf* nil
  51   "Bound to the Protobufs object currently being defined, either a schema or a message.")
  52
  53 (defvar *protobuf-package* nil
  54   "Bound to the Lisp package in which the Protobufs schema is being defined.")
  55
  56 (defvar *protobuf-rpc-package* nil
  57   "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
  58
  59 (defvar *protobuf-conc-name* nil
  60   "Bound to a conc-name to use for all the messages in the schema being defined.
  61    This controls the name of the accessors the fields of each message.
  62    When it's nil, there is no \"global\" conc-name.
  63    When it's t, each message will use the message name as the conc-name.
  64    When it's a string, that string will be used as the conc-name for each message.
  65    'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
  66    every message has an accessor whose name is the name of the field.")
  67
  68 (defvar *protobuf-pathname* nil
  69   "Bound to he name of the file from where the .proto file is being parsed.")
  70
  71 (defvar *protobuf-search-path* ()
  72   "Bound to the search-path to use to resolve any relative pathnames.")
  73
  74 (defvar *protobuf-output-path* ()
  75   "Bound to the path to use to direct output during imports, etc.")
  76
  77
  78 ;;; The model classes
  79
  80 (defclass abstract-protobuf () ())
  81
  82 ;; It would be nice if most of the slots had only reader functions, but
  83 ;; that makes writing the Protobufs parser a good deal more complicated.
  84 ;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
  85 (defclass base-protobuf (abstract-protobuf)
  86   ((class :type (or null symbol)                ;the Lisp name for this object
  87           :accessor proto-class                 ;this often names a type or class
  88           :initarg :class
  89           :initform nil)
  90    (name :type (or null string)                 ;the Protobufs name for this enum, message, etc
  91          :reader proto-name
  92          :initarg :name
  93          :initform nil)
  94    (qual-name :type string                      ;the fully qualified name, e.g., "proto2.MessageSet"
  95               :accessor proto-qualified-name
  96               :initarg :qualified-name
  97               :initform "")
  98    (parent :type (or null base-protobuf)        ;this object's parent
  99            :accessor proto-parent
 100            :initarg :parent)
 101    (options :type (list-of protobuf-option)     ;options, mostly just passed along
 102             :accessor proto-options
 103             :initarg :options
 104             :initform ())
 105    (doc :type (or null string)                  ;documentation for this object
 106         :accessor proto-documentation
 107         :initarg :documentation
 108         :initform nil)
 109    (location :accessor proto-source-location    ;a list of (pathname start-pos end-pos)
 110              :initarg :source-location
 111              :initform nil))
 112   (:documentation
 113    "The base class for all Protobufs model classes."))
 114
 115 (defun find-qualified-name (name protos
 116                             &key (proto-key #'proto-name) (full-key #'proto-qualified-name)
 117                                  relative-to)
 118   "Find something by its string name, first doing a simple name match,
 119    and, if that fails, exhaustively searching qualified names."
 120   (declare (ignore relative-to))
 121   (or (find name protos :key proto-key :test #'string=)
 122       ;;--- This needs more sophisticated search, e.g., relative to current namespace
 123       (find name protos :key full-key  :test #'string=)))
 124
 125
 126 ;; A Protobufs schema, corresponds to one .proto file
 127 (defclass protobuf-schema (base-protobuf)
 128   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
 129            :accessor proto-syntax
 130            :initarg :syntax
 131            :initform "proto2")
 132    (package :type (or null string)              ;the Protobufs package
 133             :accessor proto-package
 134             :initarg :package
 135             :initform nil)
 136    (lisp-pkg :type (or null string)             ;the Lisp package, from 'option lisp_package = ...'
 137              :accessor proto-lisp-package
 138              :initarg :lisp-package
 139              :initform nil)
 140    (imports :type (list-of string)              ;the names of schemas to be imported
 141             :accessor proto-imports
 142             :initarg :imports
 143             :initform ())
 144    (schemas :type (list-of protobuf-schema)     ;the schemas that were successfully imported
 145             :accessor proto-imported-schemas    ;this gets used for chasing namespaces
 146             :initform ())
 147    (enums :type (list-of protobuf-enum)         ;the set of enum types
 148           :accessor proto-enums
 149           :initarg :enums
 150           :initform ())
 151    (messages :type (list-of protobuf-message)   ;all the messages within this protobuf
 152              :accessor proto-messages
 153              :initarg :messages
 154              :initform ())
 155    (extenders :type (list-of protobuf-message)  ;the 'extend' messages in this protobuf
 156               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 157               :initarg :extenders
 158               :initform ())
 159    (services :type (list-of protobuf-service)
 160              :accessor proto-services
 161              :initarg :services
 162              :initform ())
 163    (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
 164             :accessor proto-type-aliases
 165             :initarg :type-aliases
 166             :initform ()))
 167   (:documentation
 168    "The model class that represents a Protobufs schema, i.e., one .proto file."))
 169
 170 (defmethod make-load-form ((s protobuf-schema) &optional environment)
 171   (with-slots (class) s
 172     (multiple-value-bind (constructor initializer)
 173         (make-load-form-saving-slots s :environment environment)
 174       (values `(let ((s ,constructor))
 175                   (record-protobuf s ',class nil)
 176                   s)
 177               initializer))))
 178
 179 (defgeneric record-protobuf (schema &optional symbol type)
 180   (:documentation
 181    "Record all the names by which the Protobufs schema might be known.")
 182   (:method ((schema protobuf-schema) &optional symbol type)
 183     (declare (ignore type))
 184     (let ((symbol (or symbol (proto-class schema))))
 185       (when symbol
 186         (setf (gethash symbol *all-schemas*) schema))
 187       (when *protobuf-pathname*
 188         ;; Record the file from which the Protobufs schema came
 189         (setf (gethash *protobuf-pathname* *all-schemas*) schema)))))
 190
 191 (defmethod print-object ((s protobuf-schema) stream)
 192   (if *print-escape*
 193     (print-unreadable-object (s stream :type t :identity t)
 194       (format stream "~@[~S~]~@[ (package ~A)~]"
 195               (and (slot-boundp s 'class) (proto-class s)) (proto-package s)))
 196     (format stream "~S" (and (slot-boundp s 'class) (proto-class s)))))
 197
 198 (defgeneric make-qualified-name (proto name)
 199   (:documentation
 200    "Give a schema or message and a name,
 201     generate a fully qualified name string for the name."))
 202
 203 (defmethod make-qualified-name ((schema protobuf-schema) name)
 204   ;; If we're at the schema, the qualified name is the schema's
 205   ;; package "dot" the name
 206   (if (proto-package schema)
 207     (strcat (proto-package schema) "." name)
 208     name))
 209
 210 (defgeneric find-enum (protobuf type &optional relative-to)
 211   (:documentation
 212    "Given a Protobufs schema or message and the name of an enum type,
 213     returns the Protobufs enum corresponding to the type."))
 214
 215 (defmethod find-enum ((schema protobuf-schema) (type symbol) &optional relative-to)
 216   (declare (ignore relative-to))
 217   (labels ((find-it (schema)
 218              (let ((enum (find type (proto-enums schema) :key #'proto-class)))
 219                (when enum
 220                  (return-from find-enum enum))
 221                (map () #'find-it (proto-imported-schemas schema)))))
 222     (find-it schema)))
 223
 224 (defmethod find-enum ((schema protobuf-schema) (name string) &optional relative-to)
 225   (let ((relative-to (or relative-to schema)))
 226     (labels ((find-it (schema)
 227                (let ((enum (find-qualified-name name (proto-enums schema)
 228                                                 :relative-to relative-to)))
 229                  (when enum
 230                    (return-from find-enum enum))
 231                  (map () #'find-it (proto-imported-schemas schema)))))
 232       (find-it schema))))
 233
 234 (defgeneric find-message (protobuf type &optional relative-to)
 235   (:documentation
 236    "Given a Protobufs schema or message and a type name or class name,
 237     returns the Protobufs message corresponding to the type."))
 238
 239 (defmethod find-message ((schema protobuf-schema) (type symbol) &optional relative-to)
 240   (declare (ignore relative-to))
 241   ;; Extended messages "shadow" non-extended ones
 242   (labels ((find-it (schema)
 243              (let ((message (or (find type (proto-extenders schema) :key #'proto-class)
 244                                 (find type (proto-messages  schema) :key #'proto-class))))
 245                (when message
 246                  (return-from find-message message))
 247                (map () #'find-it (proto-imported-schemas schema)))))
 248     (find-it schema)))
 249
 250 (defmethod find-message ((schema protobuf-schema) (type class) &optional relative-to)
 251   (find-message schema (class-name type) (or relative-to schema)))
 252
 253 (defmethod find-message ((schema protobuf-schema) (name string) &optional relative-to)
 254   (let ((relative-to (or relative-to schema)))
 255     (labels ((find-it (schema)
 256                (let ((message (or (find-qualified-name name (proto-extenders schema)
 257                                                        :relative-to relative-to)
 258                                   (find-qualified-name name (proto-messages  schema)
 259                                                        :relative-to relative-to))))
 260                  (when message
 261                    (return-from find-message message))
 262                  (map () #'find-it (proto-imported-schemas schema)))))
 263       (find-it schema))))
 264
 265 (defgeneric find-service (protobuf name)
 266   (:documentation
 267    "Given a Protobufs schema,returns the Protobufs service of the given name."))
 268
 269 (defmethod find-service ((schema protobuf-schema) (name symbol))
 270   (find name (proto-services schema) :key #'proto-class))
 271
 272 (defmethod find-service ((schema protobuf-schema) (name string))
 273   (find-qualified-name name (proto-services schema)))
 274
 275 ;; Convenience function that accepts a schema name
 276 (defmethod find-service (schema-name name)
 277   (let ((schema (find-schema schema-name)))
 278     (assert schema ()
 279             "There is no schema named ~A" schema-name)
 280     (find-service schema name)))
 281
 282
 283 ;; We accept and store any option, but only act on a few: default, packed,
 284 ;; optimize_for, lisp_package, lisp_name, lisp_alias
 285 (defclass protobuf-option (abstract-protobuf)
 286   ((name :type string                           ;the key
 287          :reader proto-name
 288          :initarg :name)
 289    (value :accessor proto-value                 ;the (untyped) value
 290           :initarg :value
 291           :initform nil)
 292    (type :type (or null symbol)                 ;(optional) Lisp type,
 293          :reader proto-type                     ;  one of string, integer, float, symbol (for now)
 294          :initarg :type
 295          :initform 'string))
 296   (:documentation
 297    "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
 298
 299 (defmethod make-load-form ((o protobuf-option) &optional environment)
 300   (make-load-form-saving-slots o :environment environment))
 301
 302 (defmethod print-object ((o protobuf-option) stream)
 303   (if *print-escape*
 304     (print-unreadable-object (o stream :type t :identity t)
 305       (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o)))
 306     (format stream "~A" (proto-name o))))
 307
 308 (defun make-option (name value &optional (type 'string))
 309   (check-type name string)
 310   (make-instance 'protobuf-option
 311     :name name :value value :type type))
 312
 313 (defgeneric find-option (protobuf name)
 314   (:documentation
 315    "Given a Protobufs schema, message, enum, etc and the name of an option,
 316     returns the value of the option and its (Lisp) type. The third value is
 317     true if an option was found, otherwise it is false."))
 318
 319 (defmethod find-option ((protobuf base-protobuf) (name string))
 320   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 321     (if option
 322       (values (proto-value option) (proto-type option) t)
 323       (values nil nil nil))))
 324
 325 (defmethod find-option ((options list) (name string))
 326   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 327     (if option
 328       (values (proto-value option) (proto-type option) t)
 329       (values nil nil nil))))
 330
 331 (defgeneric add-option (protobuf name value &optional type)
 332   (:documentation
 333    "Given a Protobufs schema, message, enum, etc
 334     add the option called 'name' with the value 'value' and type 'type'.
 335     If the option was previoously present, it is replaced."))
 336
 337 (defmethod add-option ((protobuf base-protobuf) (name string) value &optional (type 'string))
 338   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 339     (if option
 340       ;; This side-effects the old option
 341       (setf (proto-value option) value
 342             (proto-type option)  type)
 343       ;; This side-effects 'proto-options'
 344       (setf (proto-options protobuf)
 345             (append (proto-options protobuf)
 346                     (list (make-option name value type)))))))
 347
 348 (defmethod add-option ((options list) (name string) value &optional (type 'string))
 349   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 350     (append (remove option options)
 351             (list (make-option name value type)))))
 352
 353 (defgeneric remove-options (protobuf &rest names)
 354   (:documentation
 355    "Given a Protobufs schema, message, enum, etc and a set of option names,
 356     remove all of those options from the set of options."))
 357
 358 (defmethod remove-options ((protobuf base-protobuf) &rest names)
 359   (dolist (name names (proto-options protobuf))
 360     (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 361       (when option
 362         ;; This side-effects 'proto-options'
 363         (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
 364
 365 (defmethod remove-options ((options list) &rest names)
 366   (dolist (name names options)
 367     (let ((option (find name options :key #'proto-name :test #'option-name=)))
 368       (when option
 369         ;; This does not side-effect the list of options
 370         (setq options (remove option options))))))
 371
 372 (defun option-name= (name1 name2)
 373   (let* ((name1  (string name1))
 374          (name2  (string name2))
 375          (start1 (if (eql (char name1 0) #\() 1 0))
 376          (start2 (if (eql (char name2 0) #\() 1 0))
 377          (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 378          (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 379     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 380
 381
 382 ;; A Protobufs enumeration
 383 (defclass protobuf-enum (base-protobuf)
 384   ((alias :type (or null symbol)                ;use this if you want to make this enum
 385           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 386           :initarg :alias-for
 387           :initform nil)
 388    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 389            :accessor proto-values
 390            :initarg :values
 391            :initform ()))
 392   (:documentation
 393    "The model class that represents a Protobufs enumeration type."))
 394
 395 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 396   (make-load-form-saving-slots e :environment environment))
 397
 398 (defmethod print-object ((e protobuf-enum) stream)
 399   (if *print-escape*
 400     (print-unreadable-object (e stream :type t :identity t)
 401       (format stream "~S~@[ (alias for ~S)~]"
 402               (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))
 403     (format stream "~S"
 404             (and (slot-boundp e 'class) (proto-class e)))))
 405
 406 (defmethod make-qualified-name ((enum protobuf-enum) name)
 407   ;; The qualified name is the enum name "dot" the name
 408   (let ((qual-name (strcat (proto-name enum) "." name)))
 409     (if (proto-parent enum)
 410       ;; If there's a parent for this enum (either a message or
 411       ;; the schema), prepend the name (or package) of the parent
 412       (make-qualified-name (proto-parent enum) qual-name)
 413       ;; Guard against a message in the middle of nowhere
 414       qual-name)))
 415
 416
 417 ;; A Protobufs value within an enumeration
 418 (defclass protobuf-enum-value (base-protobuf)
 419   ((index :type (signed-byte 32)                ;the numeric value of the enum
 420           :accessor proto-index
 421           :initarg :index)
 422    (value :type (or null symbol)                ;the Lisp value of the enum
 423           :accessor proto-value
 424           :initarg :value
 425           :initform nil))
 426   (:documentation
 427    "The model class that represents a Protobufs enumeration value."))
 428
 429 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 430   (make-load-form-saving-slots v :environment environment))
 431
 432 (defmethod print-object ((v protobuf-enum-value) stream)
 433   (if *print-escape*
 434     (print-unreadable-object (v stream :type t :identity t)
 435       (format stream "~A = ~D"
 436               (proto-name v) (proto-index v)))
 437     (format stream "~A" (proto-name v))))
 438
 439
 440 ;; A Protobufs message
 441 (defclass protobuf-message (base-protobuf)
 442   ((conc :type (or null string)                 ;the conc-name used for Lisp accessors
 443          :accessor proto-conc-name
 444          :initarg :conc-name
 445          :initform nil)
 446    (alias :type (or null symbol)                ;use this if you want to make this message
 447           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 448           :initarg :alias-for
 449           :initform nil)
 450    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 451           :accessor proto-enums
 452           :initarg :enums
 453           :initform ())
 454    (messages :type (list-of protobuf-message)   ;all the messages embedded in this one
 455              :accessor proto-messages
 456              :initarg :messages
 457              :initform ())
 458    (extenders :type (list-of protobuf-message)  ;the 'extend' messages embedded in this one
 459               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 460               :initarg :extenders
 461               :initform ())
 462    (fields :type (list-of protobuf-field)       ;all the fields of this message
 463            :accessor proto-fields               ;this includes local ones and extended ones
 464            :initarg :fields
 465            :initform ())
 466    (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
 467                     :accessor proto-extended-fields
 468                     :initform ())
 469    (extensions :type (list-of protobuf-extension) ;any extension ranges
 470                :accessor proto-extensions
 471                :initarg :extensions
 472                :initform ())
 473    ;; :message is an ordinary message
 474    ;; :group is a (deprecated) group (kind of an "implicit" message)
 475    ;; :extends is an 'extends' to an existing message
 476    (message-type :type (member :message :group :extends)
 477                  :accessor proto-message-type
 478                  :initarg :message-type
 479                  :initform :message)
 480    (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
 481             :accessor proto-type-aliases
 482             :initarg :type-aliases
 483             :initform ()))
 484   (:documentation
 485    "The model class that represents a Protobufs message."))
 486
 487 (defmethod make-load-form ((m protobuf-message) &optional environment)
 488   (with-slots (class message-type) m
 489     (multiple-value-bind (constructor initializer)
 490         (make-load-form-saving-slots m :environment environment)
 491       (values (if (eq message-type :extends)
 492                 constructor
 493                 `(let ((m ,constructor))
 494                    (record-protobuf m ',class ',message-type)
 495                    m))
 496               initializer))))
 497
 498 (defmethod record-protobuf ((message protobuf-message) &optional class type)
 499   ;; No need to record an extension, it's already been recorded
 500   (let ((class (or class (proto-class message)))
 501         (type  (or type (proto-message-type message))))
 502     (unless (eq type :extends)
 503       (when class
 504         (setf (gethash class *all-messages*) message)))))
 505
 506 (defmethod print-object ((m protobuf-message) stream)
 507   (if *print-escape*
 508     (print-unreadable-object (m stream :type t :identity t)
 509       (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 510               (and (slot-boundp m 'class) (proto-class m))
 511               (proto-alias-for m)
 512               (eq (proto-message-type m) :group)
 513               (eq (proto-message-type m) :extends)))
 514     (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
 515
 516 (defmethod proto-package ((message protobuf-message))
 517   (and (proto-parent message)
 518        (proto-package (proto-parent message))))
 519
 520 (defmethod proto-lisp-package ((message protobuf-message))
 521   (and (proto-parent message)
 522        (proto-lisp-package (proto-parent message))))
 523
 524 (defmethod make-qualified-name ((message protobuf-message) name)
 525   ;; The qualified name is the message name "dot" the name
 526   (let ((qual-name (strcat (proto-name message) "." name)))
 527     (if (proto-parent message)
 528       ;; If there's a parent for this message (either a message or
 529       ;; the schema), prepend the name (or package) of the parent
 530       (make-qualified-name (proto-parent message) qual-name)
 531       ;; Guard against a message in the middle of nowhere
 532       qual-name)))
 533
 534 (defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
 535   ;; Extended messages "shadow" non-extended ones
 536   (or (find type (proto-extenders message) :key #'proto-class)
 537       (find type (proto-messages message) :key #'proto-class)
 538       (find-message (proto-parent message) type (or relative-to message))))
 539
 540 (defmethod find-message ((message protobuf-message) (type class) &optional relative-to)
 541   (find-message message (class-name type) (or relative-to message)))
 542
 543 (defmethod find-message ((message protobuf-message) (name string) &optional relative-to)
 544   (let ((relative-to (or relative-to message)))
 545     (or (find-qualified-name name (proto-extenders message)
 546                              :relative-to relative-to)
 547         (find-qualified-name name (proto-messages message)
 548                              :relative-to relative-to)
 549         (find-message (proto-parent message) name relative-to))))
 550
 551 (defmethod find-enum ((message protobuf-message) type &optional relative-to)
 552   (or (find type (proto-enums message) :key #'proto-class)
 553       (find-enum (proto-parent message) type (or relative-to message))))
 554
 555 (defmethod find-enum ((message protobuf-message) (name string) &optional relative-to)
 556   (let ((relative-to (or relative-to message)))
 557     (or (find-qualified-name name (proto-enums message)
 558                              :relative-to relative-to)
 559         (find-enum (proto-parent message) name relative-to))))
 560
 561 (defgeneric find-field (message name &optional relative-to)
 562   (:documentation
 563    "Given a Protobufs message and a slot name, field name or index,
 564     returns the Protobufs field having that name."))
 565
 566 (defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to)
 567   (declare (ignore relative-to))
 568   (find name (proto-fields message) :key #'proto-value))
 569
 570 (defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
 571   (find-qualified-name name (proto-fields message)
 572                        :relative-to (or relative-to message)))
 573
 574 (defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
 575   (declare (ignore relative-to))
 576   (find index (proto-fields message) :key #'proto-index))
 577
 578
 579 ;; Extensions protocol
 580 (defgeneric get-extension (object slot)
 581   (:documentation
 582    "Returns the value of the extended slot 'slot' in 'object'"))
 583
 584 (defgeneric set-extension (object slot value)
 585   (:documentation
 586    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 587
 588 (defgeneric has-extension (object slot)
 589   (:documentation
 590    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 591   ;; The only default method is for 'has-extension'
 592   ;; It's an error to call the other three functions on a non-extendable object
 593   (:method ((object standard-object) slot)
 594     (declare (ignore slot))
 595     nil))
 596
 597 (defgeneric clear-extension (object slot)
 598   (:documentation
 599    "Clears the value of the extended slot 'slot' from 'object'"))
 600
 601
 602 (defconstant $empty-default 'empty-default
 603   "The marker used in 'proto-default' used to indicate that there is no default value.")
 604 (defconstant $empty-list    'empty-list)
 605 (defconstant $empty-vector  'empty-vector)
 606
 607 ;; A Protobufs field within a message
 608 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 609 (defclass protobuf-field (base-protobuf)
 610   ((type :type string                           ;the name of the Protobuf type for the field
 611          :accessor proto-type
 612          :initarg :type)
 613    (required :type (member :required :optional :repeated)
 614              :accessor proto-required
 615              :initarg :required)
 616    (index :type (unsigned-byte 29)              ;the index number for this field
 617           :accessor proto-index                 ; which must be strictly positive
 618           :initarg :index)
 619    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 620           :accessor proto-value                 ;this also serves as the Lisp field name
 621           :initarg :value
 622           :initform nil)
 623    (reader :type (or null symbol)               ;a reader that is used to access the value
 624            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 625            :initarg :reader
 626            :initform nil)
 627    (writer :type (or null symbol list)          ;a writer that is used to set the value
 628            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 629            :initarg :writer
 630            :initform nil)
 631    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 632             :initarg :default
 633             :initform $empty-default)
 634    (packed :type (member t nil)                 ;packed, pulled out of the options
 635            :accessor proto-packed
 636            :initarg :packed
 637            :initform nil)
 638    ;; Copied from 'proto-message-type' of the field
 639    (message-type :type (member :message :group :extends)
 640                  :accessor proto-message-type
 641                  :initarg :message-type
 642                  :initform :message))
 643   (:documentation
 644    "The model class that represents one field within a Protobufs message."))
 645
 646 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 647   (declare (ignore initargs))
 648   (when (slot-boundp field 'index)
 649     (assert (and (plusp (proto-index field))
 650                  (not (<= 19000 (proto-index field) 19999))) ()
 651             "Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
 652
 653 (defmethod make-load-form ((f protobuf-field) &optional environment)
 654   (make-load-form-saving-slots f :environment environment))
 655
 656 (defmethod print-object ((f protobuf-field) stream)
 657   (if *print-escape*
 658     (print-unreadable-object (f stream :type t :identity t)
 659       (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 660               (proto-value f)
 661               (and (slot-boundp f 'class) (proto-class f))
 662               (proto-index f)
 663               (eq (proto-message-type f) :group)
 664               (eq (proto-message-type f) :extends)))
 665     (format stream "~S" (proto-value f))))
 666
 667 ;; The 'value' slot really holds the name of the slot,
 668 ;; so let's give it a better name
 669 (defmethod proto-slot ((field protobuf-field))
 670   (proto-value field))
 671
 672 (defmethod (setf proto-slot) (slot (field protobuf-field))
 673   (setf (proto-value field) slot))
 674
 675 (defgeneric empty-default-p (field)
 676   (:documentation
 677    "Returns true iff the default for the field is empty, ie, was not supplied.")
 678   (:method ((field protobuf-field))
 679     (let ((default (proto-default field)))
 680       (or (eq default $empty-default)
 681           (eq default $empty-list)
 682           (eq default $empty-vector)
 683           ;; Special handling for imported CLOS classes
 684           (and (not (eq (proto-required field) :optional))
 685                (or (null default) (equalp default #())))))))
 686
 687 (defgeneric vector-field-p (field)
 688   (:documentation
 689    "Returns true if the storage for a 'repeated' field is a vector,
 690     returns false if the storage is a list.")
 691   (:method ((field protobuf-field))
 692     (let ((default (proto-default field)))
 693       (or (eq default $empty-vector)
 694           (and (vectorp default) (not (stringp default)))))))
 695
 696
 697 ;; An extension range within a message
 698 (defclass protobuf-extension (abstract-protobuf)
 699   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 700          :accessor proto-extension-from
 701          :initarg :from)
 702    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 703        :accessor proto-extension-to
 704        :initarg :to))
 705   (:documentation
 706    "The model class that represents an extension range within a Protobufs message."))
 707
 708 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 709   (make-load-form-saving-slots e :environment environment))
 710
 711 (defmethod print-object ((e protobuf-extension) stream)
 712   (print-unreadable-object (e stream :type t :identity t)
 713     (format stream "~D - ~D"
 714             (proto-extension-from e) (proto-extension-to e))))
 715
 716
 717 ;; A Protobufs service
 718 (defclass protobuf-service (base-protobuf)
 719   ((methods :type (list-of protobuf-method)     ;the methods in the service
 720             :accessor proto-methods
 721             :initarg :methods
 722             :initform ()))
 723   (:documentation
 724    "The model class that represents a Protobufs service."))
 725
 726 (defmethod make-load-form ((s protobuf-service) &optional environment)
 727   (make-load-form-saving-slots s :environment environment))
 728
 729 (defmethod print-object ((s protobuf-service) stream)
 730   (if *print-escape*
 731     (print-unreadable-object (s stream :type t :identity t)
 732       (format stream "~S" (proto-name s)))
 733     (format stream "~S" (proto-name s))))
 734
 735 (defgeneric find-method (service name)
 736   (:documentation
 737    "Given a Protobufs service and a method name,
 738     returns the Protobufs method having that name."))
 739
 740 (defmethod find-method ((service protobuf-service) (name symbol))
 741   (find name (proto-methods service) :key #'proto-class))
 742
 743 (defmethod find-method ((service protobuf-service) (name string))
 744   (find-qualified-name name (proto-methods service)))
 745
 746 (defmethod find-method ((service protobuf-service) (index integer))
 747   (find index (proto-methods service) :key #'proto-index))
 748
 749
 750 ;; A Protobufs method within a service
 751 (defclass protobuf-method (base-protobuf)
 752   ((client-fn :type symbol                      ;the Lisp name of the client stb
 753               :accessor proto-client-stub
 754               :initarg :client-stub)
 755    (server-fn :type symbol                      ;the Lisp name of the server stb
 756               :accessor proto-server-stub
 757               :initarg :server-stub)
 758    (itype :type symbol                          ;the Lisp type name of the input
 759           :accessor proto-input-type
 760           :initarg :input-type)
 761    (iname :type (or null string)                ;the Protobufs name of the input
 762           :accessor proto-input-name
 763           :initarg :input-name
 764           :initform nil)
 765    (otype :type symbol                          ;the Lisp type name of the output
 766           :accessor proto-output-type
 767           :initarg :output-type)
 768    (oname :type (or null string)                ;the Protobufs name of the output
 769           :accessor proto-output-name
 770           :initarg :output-name
 771           :initform nil)
 772    (stype :type (or symbol null)                ;the Lisp type name of the "streams" type
 773           :accessor proto-streams-type
 774           :initarg :streams-type
 775           :initform nil)
 776    (sname :type (or null string)                ;the Protobufs name of the "streams" type
 777           :accessor proto-streams-name
 778           :initarg :streams-name
 779           :initform nil)
 780    (index :type (unsigned-byte 32)              ;an identifying index for this method
 781           :accessor proto-index                 ; (used by the RPC implementation)
 782           :initarg :index))
 783   (:documentation
 784    "The model class that represents one method with a Protobufs service."))
 785
 786 (defmethod make-load-form ((m protobuf-method) &optional environment)
 787   (make-load-form-saving-slots m :environment environment))
 788
 789 (defmethod print-object ((m protobuf-method) stream)
 790   (if *print-escape*
 791     (print-unreadable-object (m stream :type t :identity t)
 792       (format stream "~S (~S) => (~S)"
 793               (proto-class m)
 794               (and (slot-boundp m 'itype) (proto-input-type m))
 795               (and (slot-boundp m 'otype) (proto-output-type m))))
 796     (format stream "~S" (proto-class m))))
 797
 798
 799 ;;; Lisp-only extensions
 800
 801 ;; A Protobufs message
 802 (defclass protobuf-type-alias (base-protobuf)
 803   ((lisp-type :reader proto-lisp-type           ;a Lisp type specifier
 804               :initarg :lisp-type)
 805    (proto-type :reader proto-proto-type         ;a .proto type specifier
 806                :initarg :proto-type)
 807    (proto-type-str :reader proto-proto-type-str
 808                :initarg :proto-type-str)
 809    (serializer :reader proto-serializer         ;Lisp -> Protobufs conversion function
 810                :initarg :serializer)
 811    (deserializer :reader proto-deserializer     ;Protobufs -> Lisp conversion function
 812                  :initarg :deserializer))
 813   (:documentation
 814    "The model class that represents a Protobufs type alias."))
 815
 816 (defmethod make-load-form ((m protobuf-type-alias) &optional environment)
 817   (make-load-form-saving-slots m :environment environment))
 818
 819 (defmethod print-object ((m protobuf-type-alias) stream)
 820   (if *print-escape*
 821     (print-unreadable-object (m stream :type t :identity t)
 822       (format stream "~S (maps ~S to ~S)"
 823               (proto-class m)
 824               (proto-lisp-type m) (proto-proto-type m)))
 825     (format stream "~S" (proto-class m))))
 826
 827 (defgeneric find-type-alias (protobuf type)
 828   (:documentation
 829    "Given a Protobufs schema or message and the name of a type alias,
 830     returns the Protobufs type alias corresponding to the name."))
 831
 832 (defmethod find-type-alias ((schema protobuf-schema) (type symbol))
 833   (labels ((find-it (schema)
 834              (let ((alias (find type (proto-type-aliases schema) :key #'proto-class)))
 835                (when alias
 836                  (return-from find-type-alias alias))
 837                (map () #'find-it (proto-imported-schemas schema)))))
 838     (find-it schema)))
 839
 840 (defmethod find-type-alias ((message protobuf-message) type)
 841   (or (find type (proto-type-aliases message) :key #'proto-class)
 842       (find-type-alias (proto-parent message) type)))