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