model-classes.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, Inc.  All rights reserved.       ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protocol buffers model classes
  15
  16 (defvar *all-schemas* (make-hash-table :test #'equal)
  17   "A global table mapping names to 'protobuf-schema' objects.")
  18
  19 (defgeneric find-schema (name)
  20   (:documentation
  21    "Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
  22
  23 (defmethod find-schema ((name symbol))
  24   (assert (not (keywordp name)))
  25   (values (gethash name *all-schemas*)))
  26
  27 (defmethod find-schema ((path pathname))
  28   "Given a pathname, return the 'protobuf-schema' object that came from that path."
  29   (values (gethash path *all-schemas*)))
  30
  31
  32 (defvar *all-messages* (make-hash-table :test #'equal)
  33   "A global table mapping Lisp class names to 'protobuf-message' objects.")
  34
  35 (defgeneric find-message-for-class (class)
  36   (:documentation
  37    "Given a class or class name, return the message that globally has that name."))
  38
  39 (defmethod find-message-for-class (class)
  40   "Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
  41   (values (gethash class *all-messages*)))
  42
  43 (defmethod find-message-for-class ((class class))
  44   (values (gethash (class-name class) *all-messages*)))
  45
  46
  47 ;;; "Thread-local" variables
  48
  49 ;; Parsing (and even pretty printing schemas) want to keep track of the current schema
  50 (defvar *protobuf* nil
  51   "Bound to the Protobufs object currently being defined, either a schema or a message.")
  52
  53 (defvar *protobuf-package* nil
  54   "Bound to the Lisp package in which the Protobufs schema is being defined.")
  55
  56 (defvar *protobuf-rpc-package* nil
  57   "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
  58
  59 (defvar *protobuf-conc-name* nil
  60   "Bound to a conc-name to use for all the messages in the schema being defined.
  61    This controls the name of the accessors the fields of each message.
  62    When it's nil, there is no \"global\" conc-name.
  63    When it's t, each message will use the message name as the conc-name.
  64    When it's a string, that string will be used as the conc-name for each message.
  65    'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
  66    every message has an accessor whose name is the name of the field.")
  67
  68 (defvar *protobuf-pathname* nil
  69   "Bound to he name of the file from where the .proto file is being parsed.")
  70
  71 (defvar *protobuf-search-path* ()
  72   "Bound to the search-path to use to resolve any relative pathnames.")
  73
  74 (defvar *protobuf-output-path* ()
  75   "Bound to the path to use to direct output during imports, etc.")
  76
  77
  78 ;;; The model classes
  79
  80 (defclass abstract-protobuf () ())
  81
  82 ;; It would be nice if most of the slots had only reader functions, but
  83 ;; that makes writing the Protobufs parser a good deal more complicated.
  84 ;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
  85 (defclass base-protobuf (abstract-protobuf)
  86   ((class :type (or null symbol)                ;the Lisp name for this object
  87           :accessor proto-class                 ;this often names a type or class
  88           :initarg :class
  89           :initform nil)
  90    (name :type (or null string)                 ;the Protobufs name for this enum, message, etc
  91          :reader proto-name
  92          :initarg :name
  93          :initform nil)
  94    (qual-name :type string                      ;the fully qualified name, e.g., "proto2.MessageSet"
  95               :accessor proto-qualified-name
  96               :initarg :qualified-name
  97               :initform "")
  98    (parent :type (or null base-protobuf)        ;this object's parent
  99            :accessor proto-parent
 100            :initarg :parent)
 101    (options :type (list-of protobuf-option)     ;options, mostly just passed along
 102             :accessor proto-options
 103             :initarg :options
 104             :initform ())
 105    (doc :type (or null string)                  ;documentation for this object
 106         :accessor proto-documentation
 107         :initarg :documentation
 108         :initform nil)
 109    (location :accessor proto-source-location    ;a list of (pathname start-pos end-pos)
 110              :initarg :source-location
 111              :initform nil))
 112   (:documentation
 113    "The base class for all Protobufs model classes."))
 114
 115 (defun find-qualified-name (name protos
 116                             &key (proto-key #'proto-name) (full-key #'proto-qualified-name)
 117                                  relative-to)
 118   "Find something by its string name, first doing a simple name match,
 119    and, if that fails, exhaustively searching qualified names."
 120   (declare (ignore relative-to))
 121   (or (find name protos :key proto-key :test #'string=)
 122       ;;--- This needs more sophisticated search, e.g., relative to current namespace
 123       (find name protos :key full-key  :test #'string=)))
 124
 125
 126 ;; A Protobufs schema, corresponds to one .proto file
 127 (defclass protobuf-schema (base-protobuf)
 128   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
 129            :accessor proto-syntax
 130            :initarg :syntax
 131            :initform "proto2")
 132    (package :type (or null string)              ;the Protobufs package
 133             :accessor proto-package
 134             :initarg :package
 135             :initform nil)
 136    (lisp-pkg :type (or null string)             ;the Lisp package, from 'option lisp_package = ...'
 137              :accessor proto-lisp-package
 138              :initarg :lisp-package
 139              :initform nil)
 140    (imports :type (list-of string)              ;the names of schemas to be imported
 141             :accessor proto-imports
 142             :initarg :imports
 143             :initform ())
 144    (schemas :type (list-of protobuf-schema)     ;the schemas that were successfully imported
 145             :accessor proto-imported-schemas    ;this gets used for chasing namespaces
 146             :initform ())
 147    (enums :type (list-of protobuf-enum)         ;the set of enum types
 148           :accessor proto-enums
 149           :initarg :enums
 150           :initform ())
 151    (messages :type (list-of protobuf-message)   ;all the messages within this protobuf
 152              :accessor proto-messages
 153              :initarg :messages
 154              :initform ())
 155    (extenders :type (list-of protobuf-message)  ;the 'extend' messages in this protobuf
 156               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 157               :initarg :extenders
 158               :initform ())
 159    (services :type (list-of protobuf-service)
 160              :accessor proto-services
 161              :initarg :services
 162              :initform ())
 163    (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
 164             :accessor proto-type-aliases
 165             :initarg :type-aliases
 166             :initform ()))
 167   (:documentation
 168    "The model class that represents a Protobufs schema, i.e., one .proto file."))
 169
 170 (defmethod make-load-form ((s protobuf-schema) &optional environment)
 171   (with-slots (class) s
 172     (multiple-value-bind (constructor initializer)
 173         (make-load-form-saving-slots s :environment environment)
 174       (values `(let ((s ,constructor))
 175                   (record-protobuf s ',class nil)
 176                   s)
 177               initializer))))
 178
 179 (defgeneric record-protobuf (schema &optional symbol type)
 180   (:documentation
 181    "Record all the names by which the Protobufs schema might be known.")
 182   (:method ((schema protobuf-schema) &optional symbol type)
 183     (declare (ignore type))
 184     (let ((symbol (or symbol (proto-class schema))))
 185       (when symbol
 186         (setf (gethash symbol *all-schemas*) schema))
 187       (let ((path (or *protobuf-pathname* *compile-file-pathname*)))
 188         (when path
 189           ;; Record the file from which the Protobufs schema came
 190           (setf (gethash 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 name :value value :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 name value 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     (append (remove option options)
 352             (list (make-option name value 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 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 ',message-type)
 496                    m))
 497               initializer))))
 498
 499 (defmethod record-protobuf ((message protobuf-message) &optional class type)
 500   ;; No need to record an extension, it's already been recorded
 501   (let ((class (or class (proto-class message)))
 502         (type  (or type (proto-message-type message))))
 503     (unless (eq type :extends)
 504       (when class
 505         (setf (gethash class *all-messages*) message)))))
 506
 507 (defmethod print-object ((m protobuf-message) stream)
 508   (if *print-escape*
 509     (print-unreadable-object (m stream :type t :identity t)
 510       (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 511               (and (slot-boundp m 'class) (proto-class m))
 512               (proto-alias-for m)
 513               (eq (proto-message-type m) :group)
 514               (eq (proto-message-type m) :extends)))
 515     (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
 516
 517 (defmethod proto-package ((message protobuf-message))
 518   (and (proto-parent message)
 519        (proto-package (proto-parent message))))
 520
 521 (defmethod proto-lisp-package ((message protobuf-message))
 522   (and (proto-parent message)
 523        (proto-lisp-package (proto-parent message))))
 524
 525 (defmethod make-qualified-name ((message protobuf-message) name)
 526   ;; The qualified name is the message name "dot" the name
 527   (let ((qual-name (strcat (proto-name message) "." name)))
 528     (if (proto-parent message)
 529       ;; If there's a parent for this message (either a message or
 530       ;; the schema), prepend the name (or package) of the parent
 531       (make-qualified-name (proto-parent message) qual-name)
 532       ;; Guard against a message in the middle of nowhere
 533       qual-name)))
 534
 535 (defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
 536   ;; Extended messages "shadow" non-extended ones
 537   (or (find type (proto-extenders message) :key #'proto-class)
 538       (find type (proto-messages message) :key #'proto-class)
 539       (find-message (proto-parent message) type (or relative-to message))))
 540
 541 (defmethod find-message ((message protobuf-message) (type class) &optional relative-to)
 542   (find-message message (class-name type) (or relative-to message)))
 543
 544 (defmethod find-message ((message protobuf-message) (name string) &optional relative-to)
 545   (let ((relative-to (or relative-to message)))
 546     (or (find-qualified-name name (proto-extenders message)
 547                              :relative-to relative-to)
 548         (find-qualified-name name (proto-messages message)
 549                              :relative-to relative-to)
 550         (find-message (proto-parent message) name relative-to))))
 551
 552 (defmethod find-enum ((message protobuf-message) type &optional relative-to)
 553   (or (find type (proto-enums message) :key #'proto-class)
 554       (find-enum (proto-parent message) type (or relative-to message))))
 555
 556 (defmethod find-enum ((message protobuf-message) (name string) &optional relative-to)
 557   (let ((relative-to (or relative-to message)))
 558     (or (find-qualified-name name (proto-enums message)
 559                              :relative-to relative-to)
 560         (find-enum (proto-parent message) name relative-to))))
 561
 562 (defgeneric find-field (message name &optional relative-to)
 563   (:documentation
 564    "Given a Protobufs message and a slot name, field name or index,
 565     returns the Protobufs field having that name."))
 566
 567 (defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to)
 568   (declare (ignore relative-to))
 569   (find name (proto-fields message) :key #'proto-value))
 570
 571 (defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
 572   (find-qualified-name name (proto-fields message)
 573                        :relative-to (or relative-to message)))
 574
 575 (defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
 576   (declare (ignore relative-to))
 577   (find index (proto-fields message) :key #'proto-index))
 578
 579
 580 ;; Extensions protocol
 581 (defgeneric get-extension (object slot)
 582   (:documentation
 583    "Returns the value of the extended slot 'slot' in 'object'"))
 584
 585 (defgeneric set-extension (object slot value)
 586   (:documentation
 587    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 588
 589 (defgeneric has-extension (object slot)
 590   (:documentation
 591    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 592   ;; The only default method is for 'has-extension'
 593   ;; It's an error to call the other three functions on a non-extendable object
 594   (:method ((object standard-object) slot)
 595     (declare (ignore slot))
 596     nil))
 597
 598 (defgeneric clear-extension (object slot)
 599   (:documentation
 600    "Clears the value of the extended slot 'slot' from 'object'"))
 601
 602
 603 (defconstant $empty-default 'empty-default
 604   "The marker used in 'proto-default' used to indicate that there is no default value.")
 605 (defconstant $empty-list    'empty-list)
 606 (defconstant $empty-vector  'empty-vector)
 607
 608 ;; A Protobufs field within a message
 609 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 610 (defclass protobuf-field (base-protobuf)
 611   ((type :type string                           ;the name of the Protobuf type for the field
 612          :accessor proto-type
 613          :initarg :type)
 614    (required :type (member :required :optional :repeated)
 615              :accessor proto-required
 616              :initarg :required)
 617    (index :type (unsigned-byte 29)              ;the index number for this field
 618           :accessor proto-index                 ; which must be strictly positive
 619           :initarg :index)
 620    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 621           :accessor proto-value                 ;this also serves as the Lisp field name
 622           :initarg :value
 623           :initform nil)
 624    (reader :type (or null symbol)               ;a reader that is used to access the value
 625            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 626            :initarg :reader
 627            :initform nil)
 628    (writer :type (or null symbol list)          ;a writer that is used to set the value
 629            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 630            :initarg :writer
 631            :initform nil)
 632    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 633             :initarg :default
 634             :initform $empty-default)
 635    (packed :type (member t nil)                 ;packed, pulled out of the options
 636            :accessor proto-packed
 637            :initarg :packed
 638            :initform nil)
 639    ;; Copied from 'proto-message-type' of the field
 640    (message-type :type (member :message :group :extends)
 641                  :accessor proto-message-type
 642                  :initarg :message-type
 643                  :initform :message))
 644   (:documentation
 645    "The model class that represents one field within a Protobufs message."))
 646
 647 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 648   (declare (ignore initargs))
 649   (when (slot-boundp field 'index)
 650     (assert (and (plusp (proto-index field))
 651                  (not (<= 19000 (proto-index field) 19999))) ()
 652             "Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
 653
 654 (defmethod make-load-form ((f protobuf-field) &optional environment)
 655   (make-load-form-saving-slots f :environment environment))
 656
 657 (defmethod print-object ((f protobuf-field) stream)
 658   (if *print-escape*
 659     (print-unreadable-object (f stream :type t :identity t)
 660       (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 661               (proto-value f)
 662               (and (slot-boundp f 'class) (proto-class f))
 663               (proto-index f)
 664               (eq (proto-message-type f) :group)
 665               (eq (proto-message-type f) :extends)))
 666     (format stream "~S" (proto-value f))))
 667
 668 ;; The 'value' slot really holds the name of the slot,
 669 ;; so let's give it a better name
 670 (defmethod proto-slot ((field protobuf-field))
 671   (proto-value field))
 672
 673 (defmethod (setf proto-slot) (slot (field protobuf-field))
 674   (setf (proto-value field) slot))
 675
 676 (defgeneric empty-default-p (field)
 677   (:documentation
 678    "Returns true iff the default for the field is empty, ie, was not supplied.")
 679   (:method ((field protobuf-field))
 680     (let ((default (proto-default field)))
 681       (or (eq default $empty-default)
 682           (eq default $empty-list)
 683           (eq default $empty-vector)
 684           ;; Special handling for imported CLOS classes
 685           (and (not (eq (proto-required field) :optional))
 686                (or (null default) (equalp default #())))))))
 687
 688 (defgeneric vector-field-p (field)
 689   (:documentation
 690    "Returns true if the storage for a 'repeated' field is a vector,
 691     returns false if the storage is a list.")
 692   (:method ((field protobuf-field))
 693     (let ((default (proto-default field)))
 694       (or (eq default $empty-vector)
 695           (and (vectorp default) (not (stringp default)))))))
 696
 697
 698 ;; An extension range within a message
 699 (defclass protobuf-extension (abstract-protobuf)
 700   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 701          :accessor proto-extension-from
 702          :initarg :from)
 703    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 704        :accessor proto-extension-to
 705        :initarg :to))
 706   (:documentation
 707    "The model class that represents an extension range within a Protobufs message."))
 708
 709 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 710   (make-load-form-saving-slots e :environment environment))
 711
 712 (defmethod print-object ((e protobuf-extension) stream)
 713   (print-unreadable-object (e stream :type t :identity t)
 714     (format stream "~D - ~D"
 715             (proto-extension-from e) (proto-extension-to e))))
 716
 717
 718 ;; A Protobufs service
 719 (defclass protobuf-service (base-protobuf)
 720   ((methods :type (list-of protobuf-method)     ;the methods in the service
 721             :accessor proto-methods
 722             :initarg :methods
 723             :initform ()))
 724   (:documentation
 725    "The model class that represents a Protobufs service."))
 726
 727 (defmethod make-load-form ((s protobuf-service) &optional environment)
 728   (make-load-form-saving-slots s :environment environment))
 729
 730 (defmethod print-object ((s protobuf-service) stream)
 731   (if *print-escape*
 732     (print-unreadable-object (s stream :type t :identity t)
 733       (format stream "~S" (proto-name s)))
 734     (format stream "~S" (proto-name s))))
 735
 736 (defgeneric find-method (service name)
 737   (:documentation
 738    "Given a Protobufs service and a method name,
 739     returns the Protobufs method having that name."))
 740
 741 (defmethod find-method ((service protobuf-service) (name symbol))
 742   (find name (proto-methods service) :key #'proto-class))
 743
 744 (defmethod find-method ((service protobuf-service) (name string))
 745   (find-qualified-name name (proto-methods service)))
 746
 747 (defmethod find-method ((service protobuf-service) (index integer))
 748   (find index (proto-methods service) :key #'proto-index))
 749
 750
 751 ;; A Protobufs method within a service
 752 (defclass protobuf-method (base-protobuf)
 753   ((client-fn :type symbol                      ;the Lisp name of the client stb
 754               :accessor proto-client-stub
 755               :initarg :client-stub)
 756    (server-fn :type symbol                      ;the Lisp name of the server stb
 757               :accessor proto-server-stub
 758               :initarg :server-stub)
 759    (itype :type symbol                          ;the Lisp type name of the input
 760           :accessor proto-input-type
 761           :initarg :input-type)
 762    (iname :type (or null string)                ;the Protobufs name of the input
 763           :accessor proto-input-name
 764           :initarg :input-name
 765           :initform nil)
 766    (otype :type symbol                          ;the Lisp type name of the output
 767           :accessor proto-output-type
 768           :initarg :output-type)
 769    (oname :type (or null string)                ;the Protobufs name of the output
 770           :accessor proto-output-name
 771           :initarg :output-name
 772           :initform nil)
 773    (stype :type (or symbol null)                ;the Lisp type name of the "streams" type
 774           :accessor proto-streams-type
 775           :initarg :streams-type
 776           :initform nil)
 777    (sname :type (or null string)                ;the Protobufs name of the "streams" type
 778           :accessor proto-streams-name
 779           :initarg :streams-name
 780           :initform nil)
 781    (index :type (unsigned-byte 32)              ;an identifying index for this method
 782           :accessor proto-index                 ; (used by the RPC implementation)
 783           :initarg :index))
 784   (:documentation
 785    "The model class that represents one method with a Protobufs service."))
 786
 787 (defmethod make-load-form ((m protobuf-method) &optional environment)
 788   (make-load-form-saving-slots m :environment environment))
 789
 790 (defmethod print-object ((m protobuf-method) stream)
 791   (if *print-escape*
 792     (print-unreadable-object (m stream :type t :identity t)
 793       (format stream "~S (~S) => (~S)"
 794               (proto-class m)
 795               (and (slot-boundp m 'itype) (proto-input-type m))
 796               (and (slot-boundp m 'otype) (proto-output-type m))))
 797     (format stream "~S" (proto-class m))))
 798
 799
 800 ;;; Lisp-only extensions
 801
 802 ;; A Protobufs message
 803 (defclass protobuf-type-alias (base-protobuf)
 804   ((lisp-type :reader proto-lisp-type           ;a Lisp type specifier
 805               :initarg :lisp-type)
 806    (proto-type :reader proto-proto-type         ;a .proto type specifier
 807                :initarg :proto-type)
 808    (proto-type-str :reader proto-proto-type-str
 809                :initarg :proto-type-str)
 810    (serializer :reader proto-serializer         ;Lisp -> Protobufs conversion function
 811                :initarg :serializer)
 812    (deserializer :reader proto-deserializer     ;Protobufs -> Lisp conversion function
 813                  :initarg :deserializer))
 814   (:documentation
 815    "The model class that represents a Protobufs type alias."))
 816
 817 (defmethod make-load-form ((m protobuf-type-alias) &optional environment)
 818   (make-load-form-saving-slots m :environment environment))
 819
 820 (defmethod print-object ((m protobuf-type-alias) stream)
 821   (if *print-escape*
 822     (print-unreadable-object (m stream :type t :identity t)
 823       (format stream "~S (maps ~S to ~S)"
 824               (proto-class m)
 825               (proto-lisp-type m) (proto-proto-type m)))
 826     (format stream "~S" (proto-class m))))
 827
 828 (defgeneric find-type-alias (protobuf type)
 829   (:documentation
 830    "Given a Protobufs schema or message and the name of a type alias,
 831     returns the Protobufs type alias corresponding to the name."))
 832
 833 (defmethod find-type-alias ((schema protobuf-schema) (type symbol))
 834   (labels ((find-it (schema)
 835              (let ((alias (find type (proto-type-aliases schema) :key #'proto-class)))
 836                (when alias
 837                  (return-from find-type-alias alias))
 838                (map () #'find-it (proto-imported-schemas schema)))))
 839     (find-it schema)))
 840
 841 (defmethod find-type-alias ((message protobuf-message) type)
 842   (or (find type (proto-type-aliases message) :key #'proto-class)
 843       (find-type-alias (proto-parent message) type)))