model-classes.lisp

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