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 (defgeneric find-option (protobuf name)
 310   (:documentation
 311    "Given a Protobufs schema, message, enum, etc and the name of an option,
 312     returns the value of the option and its (Lisp) type. The third value is
 313     true if an option was found, otherwise it is false."))
 314
 315 (defmethod find-option ((protobuf base-protobuf) (name string))
 316   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 317     (if option
 318       (values (proto-value option) (proto-type option) t)
 319       (values nil nil nil))))
 320
 321 (defmethod find-option ((options list) (name string))
 322   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 323     (if option
 324       (values (proto-value option) (proto-type option) t)
 325       (values nil nil nil))))
 326
 327 (defgeneric remove-options (protobuf &rest names)
 328   (:documentation
 329    "Given a Protobufs schema, message, enum, etc and a set of option names,
 330     remove all of those options from the set of options."))
 331
 332 (defmethod remove-options ((protobuf base-protobuf) &rest names)
 333   (dolist (name names (proto-options protobuf))
 334     (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 335       (when option
 336         ;; This side-effects 'proto-options'
 337         (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
 338
 339 (defmethod remove-options ((options list) &rest names)
 340   (dolist (name names options)
 341     (let ((option (find name options :key #'proto-name :test #'option-name=)))
 342       (when option
 343         ;; This does not side-effect the list of options
 344         (setq options (remove option options))))))
 345
 346 (defun option-name= (name1 name2)
 347   (let* ((name1  (string name1))
 348          (name2  (string name2))
 349          (start1 (if (eql (char name1 0) #\() 1 0))
 350          (start2 (if (eql (char name2 0) #\() 1 0))
 351          (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 352          (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 353     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 354
 355
 356 ;; A Protobufs enumeration
 357 (defclass protobuf-enum (base-protobuf)
 358   ((alias :type (or null symbol)                ;use this if you want to make this enum
 359           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 360           :initarg :alias-for
 361           :initform nil)
 362    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 363            :accessor proto-values
 364            :initarg :values
 365            :initform ()))
 366   (:documentation
 367    "The model class that represents a Protobufs enumeration type."))
 368
 369 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 370   (make-load-form-saving-slots e :environment environment))
 371
 372 (defmethod print-object ((e protobuf-enum) stream)
 373   (if *print-escape*
 374     (print-unreadable-object (e stream :type t :identity t)
 375       (format stream "~S~@[ (alias for ~S)~]"
 376               (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))
 377     (format stream "~S"
 378             (and (slot-boundp e 'class) (proto-class e)))))
 379
 380 (defmethod make-qualified-name ((enum protobuf-enum) name)
 381   ;; The qualified name is the enum name "dot" the name
 382   (let ((qual-name (strcat (proto-name enum) "." name)))
 383     (if (proto-parent enum)
 384       ;; If there's a parent for this enum (either a message or
 385       ;; the schema), prepend the name (or package) of the parent
 386       (make-qualified-name (proto-parent enum) qual-name)
 387       ;; Guard against a message in the middle of nowhere
 388       qual-name)))
 389
 390
 391 ;; A Protobufs value within an enumeration
 392 (defclass protobuf-enum-value (base-protobuf)
 393   ((index :type (signed-byte 32)                ;the numeric value of the enum
 394           :accessor proto-index
 395           :initarg :index)
 396    (value :type (or null symbol)                ;the Lisp value of the enum
 397           :accessor proto-value
 398           :initarg :value
 399           :initform nil))
 400   (:documentation
 401    "The model class that represents a Protobufs enumeration value."))
 402
 403 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 404   (make-load-form-saving-slots v :environment environment))
 405
 406 (defmethod print-object ((v protobuf-enum-value) stream)
 407   (if *print-escape*
 408     (print-unreadable-object (v stream :type t :identity t)
 409       (format stream "~A = ~D"
 410               (proto-name v) (proto-index v)))
 411     (format stream "~A" (proto-name v))))
 412
 413
 414 ;; A Protobufs message
 415 (defclass protobuf-message (base-protobuf)
 416   ((conc :type (or null string)                 ;the conc-name used for Lisp accessors
 417          :accessor proto-conc-name
 418          :initarg :conc-name
 419          :initform nil)
 420    (alias :type (or null symbol)                ;use this if you want to make this message
 421           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 422           :initarg :alias-for
 423           :initform nil)
 424    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 425           :accessor proto-enums
 426           :initarg :enums
 427           :initform ())
 428    (messages :type (list-of protobuf-message)   ;all the messages embedded in this one
 429              :accessor proto-messages
 430              :initarg :messages
 431              :initform ())
 432    (extenders :type (list-of protobuf-message)  ;the 'extend' messages embedded in this one
 433               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 434               :initarg :extenders
 435               :initform ())
 436    (fields :type (list-of protobuf-field)       ;all the fields of this message
 437            :accessor proto-fields               ;this includes local ones and extended ones
 438            :initarg :fields
 439            :initform ())
 440    (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
 441                     :accessor proto-extended-fields
 442                     :initform ())
 443    (extensions :type (list-of protobuf-extension) ;any extension ranges
 444                :accessor proto-extensions
 445                :initarg :extensions
 446                :initform ())
 447    ;; :message is an ordinary message
 448    ;; :group is a (deprecated) group (kind of an "implicit" message)
 449    ;; :extends is an 'extends' to an existing message
 450    (message-type :type (member :message :group :extends)
 451                  :accessor proto-message-type
 452                  :initarg :message-type
 453                  :initform :message)
 454    (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
 455             :accessor proto-type-aliases
 456             :initarg :type-aliases
 457             :initform ()))
 458   (:documentation
 459    "The model class that represents a Protobufs message."))
 460
 461 (defmethod make-load-form ((m protobuf-message) &optional environment)
 462   (with-slots (class name message-type) m
 463     (multiple-value-bind (constructor initializer)
 464         (make-load-form-saving-slots m :environment environment)
 465       (values (if (eq message-type :extends)
 466                 constructor
 467                 `(let ((m ,constructor))
 468                    (record-protobuf m ',class ',name ',message-type)
 469                    m))
 470               initializer))))
 471
 472 (defmethod record-protobuf ((message protobuf-message) &optional class name type)
 473   ;; No need to record an extension, it's already been recorded
 474   (let ((class (or class (proto-class message)))
 475         (name  (or name (proto-name message)))
 476         (type  (or type (proto-message-type message))))
 477     (unless (eq type :extends)
 478       (when class
 479         (setf (gethash class *all-messages*) message))
 480       (when name
 481         (setf (gethash name *all-messages*) message)))))
 482
 483 (defmethod print-object ((m protobuf-message) stream)
 484   (if *print-escape*
 485     (print-unreadable-object (m stream :type t :identity t)
 486       (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 487               (and (slot-boundp m 'class) (proto-class m))
 488               (proto-alias-for m)
 489               (eq (proto-message-type m) :group)
 490               (eq (proto-message-type m) :extends)))
 491     (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
 492
 493 (defmethod proto-package ((message protobuf-message))
 494   (and (proto-parent message)
 495        (proto-package (proto-parent message))))
 496
 497 (defmethod proto-lisp-package ((message protobuf-message))
 498   (and (proto-parent message)
 499        (proto-lisp-package (proto-parent message))))
 500
 501 (defmethod make-qualified-name ((message protobuf-message) name)
 502   ;; The qualified name is the message name "dot" the name
 503   (let ((qual-name (strcat (proto-name message) "." name)))
 504     (if (proto-parent message)
 505       ;; If there's a parent for this message (either a message or
 506       ;; the schema), prepend the name (or package) of the parent
 507       (make-qualified-name (proto-parent message) qual-name)
 508       ;; Guard against a message in the middle of nowhere
 509       qual-name)))
 510
 511 (defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
 512   ;; Extended messages "shadow" non-extended ones
 513   (or (find type (proto-extenders message) :key #'proto-class)
 514       (find type (proto-messages message) :key #'proto-class)
 515       (find-message (proto-parent message) type (or relative-to message))))
 516
 517 (defmethod find-message ((message protobuf-message) (type class) &optional relative-to)
 518   (find-message message (class-name type) (or relative-to message)))
 519
 520 (defmethod find-message ((message protobuf-message) (name string) &optional relative-to)
 521   (let ((relative-to (or relative-to message)))
 522     (or (find-qualified-name name (proto-extenders message)
 523                              :relative-to relative-to)
 524         (find-qualified-name name (proto-messages message)
 525                              :relative-to relative-to)
 526         (find-message (proto-parent message) name relative-to))))
 527
 528 (defmethod find-enum ((message protobuf-message) type &optional relative-to)
 529   (or (find type (proto-enums message) :key #'proto-class)
 530       (find-enum (proto-parent message) type (or relative-to message))))
 531
 532 (defmethod find-enum ((message protobuf-message) (name string) &optional relative-to)
 533   (let ((relative-to (or relative-to message)))
 534     (or (find-qualified-name name (proto-enums message)
 535                              :relative-to relative-to)
 536         (find-enum (proto-parent message) name relative-to))))
 537
 538 (defgeneric find-field (message name &optional relative-to)
 539   (:documentation
 540    "Given a Protobufs message and a slot name, field name or index,
 541     returns the Protobufs field having that name."))
 542
 543 (defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to)
 544   (declare (ignore relative-to))
 545   (find name (proto-fields message) :key #'proto-value))
 546
 547 (defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
 548   (find-qualified-name name (proto-fields message)
 549                        :relative-to (or relative-to message)))
 550
 551 (defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
 552   (declare (ignore relative-to))
 553   (find index (proto-fields message) :key #'proto-index))
 554
 555
 556 ;; Extensions protocol
 557 (defgeneric get-extension (object slot)
 558   (:documentation
 559    "Returns the value of the extended slot 'slot' in 'object'"))
 560
 561 (defgeneric set-extension (object slot value)
 562   (:documentation
 563    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 564
 565 (defgeneric has-extension (object slot)
 566   (:documentation
 567    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 568   ;; The only default method is for 'has-extension'
 569   ;; It's an error to call the other three functions on a non-extendable object
 570   (:method ((object standard-object) slot)
 571     (declare (ignore slot))
 572     nil))
 573
 574 (defgeneric clear-extension (object slot)
 575   (:documentation
 576    "Clears the value of the extended slot 'slot' from 'object'"))
 577
 578
 579 (defconstant $empty-default 'empty-default
 580   "The marker used in 'proto-default' used to indicate that there is no default value.")
 581 (defconstant $empty-list    'empty-list)
 582 (defconstant $empty-vector  'empty-vector)
 583
 584 ;; A Protobufs field within a message
 585 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 586 (defclass protobuf-field (base-protobuf)
 587   ((type :type string                           ;the name of the Protobuf type for the field
 588          :accessor proto-type
 589          :initarg :type)
 590    (required :type (member :required :optional :repeated)
 591              :accessor proto-required
 592              :initarg :required)
 593    (index :type (unsigned-byte 29)              ;the index number for this field
 594           :accessor proto-index                 ; which must be strictly positive
 595           :initarg :index)
 596    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 597           :accessor proto-value                 ;this also serves as the Lisp field name
 598           :initarg :value
 599           :initform nil)
 600    (reader :type (or null symbol)               ;a reader that is used to access the value
 601            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 602            :initarg :reader
 603            :initform nil)
 604    (writer :type (or null symbol list)          ;a writer that is used to set the value
 605            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 606            :initarg :writer
 607            :initform nil)
 608    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 609             :initarg :default
 610             :initform $empty-default)
 611    (packed :type (member t nil)                 ;packed, pulled out of the options
 612            :accessor proto-packed
 613            :initarg :packed
 614            :initform nil)
 615    ;; Copied from 'proto-message-type' of the field
 616    (message-type :type (member :message :group :extends)
 617                  :accessor proto-message-type
 618                  :initarg :message-type
 619                  :initform :message))
 620   (:documentation
 621    "The model class that represents one field within a Protobufs message."))
 622
 623 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 624   (declare (ignore initargs))
 625   (when (slot-boundp field 'index)
 626     (assert (and (plusp (proto-index field))
 627                  (not (<= 19000 (proto-index field) 19999))) ()
 628             "Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
 629
 630 (defmethod make-load-form ((f protobuf-field) &optional environment)
 631   (make-load-form-saving-slots f :environment environment))
 632
 633 (defmethod print-object ((f protobuf-field) stream)
 634   (if *print-escape*
 635     (print-unreadable-object (f stream :type t :identity t)
 636       (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 637               (proto-value f)
 638               (and (slot-boundp f 'class) (proto-class f))
 639               (proto-index f)
 640               (eq (proto-message-type f) :group)
 641               (eq (proto-message-type f) :extends)))
 642     (format stream "~S" (proto-value f))))
 643
 644 ;; The 'value' slot really holds the name of the slot,
 645 ;; so let's give it a better name
 646 (defmethod proto-slot ((field protobuf-field))
 647   (proto-value field))
 648
 649 (defmethod (setf proto-slot) (slot (field protobuf-field))
 650   (setf (proto-value field) slot))
 651
 652 (defgeneric empty-default-p (field)
 653   (:documentation
 654    "Returns true iff the default for the field is empty, ie, was not supplied.")
 655   (:method ((field protobuf-field))
 656     (let ((default (proto-default field)))
 657       (or (eq default $empty-default)
 658           (eq default $empty-list)
 659           (eq default $empty-vector)
 660           ;; Special handling for imported CLOS classes
 661           (and (not (eq (proto-required field) :optional))
 662                (or (null default) (equalp default #())))))))
 663
 664 (defgeneric vector-field-p (field)
 665   (:documentation
 666    "Returns true if the storage for a 'repeated' field is a vector,
 667     returns false if the storage is a list.")
 668   (:method ((field protobuf-field))
 669     (let ((default (proto-default field)))
 670       (or (eq default $empty-vector)
 671           (and (vectorp default) (not (stringp default)))))))
 672
 673
 674 ;; An extension range within a message
 675 (defclass protobuf-extension (abstract-protobuf)
 676   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 677          :accessor proto-extension-from
 678          :initarg :from)
 679    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 680        :accessor proto-extension-to
 681        :initarg :to))
 682   (:documentation
 683    "The model class that represents an extension range within a Protobufs message."))
 684
 685 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 686   (make-load-form-saving-slots e :environment environment))
 687
 688 (defmethod print-object ((e protobuf-extension) stream)
 689   (print-unreadable-object (e stream :type t :identity t)
 690     (format stream "~D - ~D"
 691             (proto-extension-from e) (proto-extension-to e))))
 692
 693
 694 ;; A Protobufs service
 695 (defclass protobuf-service (base-protobuf)
 696   ((methods :type (list-of protobuf-method)     ;the methods in the service
 697             :accessor proto-methods
 698             :initarg :methods
 699             :initform ()))
 700   (:documentation
 701    "The model class that represents a Protobufs service."))
 702
 703 (defmethod make-load-form ((s protobuf-service) &optional environment)
 704   (make-load-form-saving-slots s :environment environment))
 705
 706 (defmethod print-object ((s protobuf-service) stream)
 707   (if *print-escape*
 708     (print-unreadable-object (s stream :type t :identity t)
 709       (format stream "~S" (proto-name s)))
 710     (format stream "~S" (proto-name s))))
 711
 712 (defgeneric find-method (service name)
 713   (:documentation
 714    "Given a Protobufs service and a method name,
 715     returns the Protobufs method having that name."))
 716
 717 (defmethod find-method ((service protobuf-service) (name symbol))
 718   (find name (proto-methods service) :key #'proto-class))
 719
 720 (defmethod find-method ((service protobuf-service) (name string))
 721   (find-qualified-name name (proto-methods service)))
 722
 723 (defmethod find-method ((service protobuf-service) (index integer))
 724   (find index (proto-methods service) :key #'proto-index))
 725
 726
 727 ;; A Protobufs method within a service
 728 (defclass protobuf-method (base-protobuf)
 729   ((client-fn :type symbol                      ;the Lisp name of the client stb
 730               :accessor proto-client-stub
 731               :initarg :client-stub)
 732    (server-fn :type symbol                      ;the Lisp name of the server stb
 733               :accessor proto-server-stub
 734               :initarg :server-stub)
 735    (itype :type symbol                          ;the Lisp type name of the input
 736           :accessor proto-input-type
 737           :initarg :input-type)
 738    (iname :type (or null string)                ;the Protobufs name of the input
 739           :accessor proto-input-name
 740           :initarg :input-name
 741           :initform nil)
 742    (otype :type symbol                          ;the Lisp type name of the output
 743           :accessor proto-output-type
 744           :initarg :output-type)
 745    (oname :type (or null string)                ;the Protobufs name of the output
 746           :accessor proto-output-name
 747           :initarg :output-name
 748           :initform nil)
 749    (stype :type (or symbol null)                ;the Lisp type name of the "streams" type
 750           :accessor proto-streams-type
 751           :initarg :streams-type
 752           :initform nil)
 753    (sname :type (or null string)                ;the Protobufs name of the "streams" type
 754           :accessor proto-streams-name
 755           :initarg :streams-name
 756           :initform nil)
 757    (index :type (unsigned-byte 32)              ;an identifying index for this method
 758           :accessor proto-index                 ; (used by the RPC implementation)
 759           :initarg :index))
 760   (:documentation
 761    "The model class that represents one method with a Protobufs service."))
 762
 763 (defmethod make-load-form ((m protobuf-method) &optional environment)
 764   (make-load-form-saving-slots m :environment environment))
 765
 766 (defmethod print-object ((m protobuf-method) stream)
 767   (if *print-escape*
 768     (print-unreadable-object (m stream :type t :identity t)
 769       (format stream "~S (~S) => (~S)"
 770               (proto-class m)
 771               (and (slot-boundp m 'itype) (proto-input-type m))
 772               (and (slot-boundp m 'otype) (proto-output-type m))))
 773     (format stream "~S" (proto-class m))))
 774
 775
 776 ;;; Lisp-only extensions
 777
 778 ;; A Protobufs message
 779 (defclass protobuf-type-alias (base-protobuf)
 780   ((lisp-type :reader proto-lisp-type           ;a Lisp type specifier
 781               :initarg :lisp-type)
 782    (proto-type :reader proto-proto-type         ;a .proto type specifier
 783                :initarg :proto-type)
 784    (proto-type-str :reader proto-proto-type-str
 785                :initarg :proto-type-str)
 786    (serializer :reader proto-serializer         ;Lisp -> Protobufs conversion function
 787                :initarg :serializer)
 788    (deserializer :reader proto-deserializer     ;Protobufs -> Lisp conversion function
 789                  :initarg :deserializer))
 790   (:documentation
 791    "The model class that represents a Protobufs type alias."))
 792
 793 (defmethod make-load-form ((m protobuf-type-alias) &optional environment)
 794   (make-load-form-saving-slots m :environment environment))
 795
 796 (defmethod print-object ((m protobuf-type-alias) stream)
 797   (if *print-escape*
 798     (print-unreadable-object (m stream :type t :identity t)
 799       (format stream "~S (maps ~S to ~S)"
 800               (proto-class m)
 801               (proto-lisp-type m) (proto-proto-type m)))
 802     (format stream "~S" (proto-class m))))
 803
 804 (defgeneric find-type-alias (protobuf type)
 805   (:documentation
 806    "Given a Protobufs schema or message and the name of a type alias,
 807     returns the Protobufs type alias corresponding to the name."))
 808
 809 (defmethod find-type-alias ((schema protobuf-schema) (type symbol))
 810   (labels ((find-it (schema)
 811              (let ((alias (find type (proto-type-aliases schema) :key #'proto-class)))
 812                (when alias
 813                  (return-from find-type-alias alias))
 814                (map () #'find-it (proto-imported-schemas schema)))))
 815     (find-it schema)))
 816
 817 (defmethod find-type-alias ((message protobuf-message) type)
 818   (or (find type (proto-type-aliases message) :key #'proto-class)
 819       (find-type-alias (proto-parent message) type)))