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