model-classes.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protol 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 (truename 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)                         ;this can be schema, a message, ...
  51 (defvar *protobuf-package* nil)
  52
  53
  54 ;;; The model classes
  55
  56 (defclass abstract-protobuf () ())
  57
  58 (defclass base-protobuf (abstract-protobuf)
  59   ((class :type (or null symbol)                ;the Lisp name for this object
  60           :accessor proto-class                 ;this often names a type or class
  61           :initarg :class
  62           :initform nil)
  63    (name :type (or null string)                 ;the Protobufs name for this enum, message, etc
  64          :reader proto-name
  65          :initarg :name
  66          :initform nil)
  67    (options :type (list-of protobuf-option)     ;options, mostly just passed along
  68             :accessor proto-options
  69             :initarg :options
  70             :initform ())
  71    (doc :type (or null string)                  ;documentation for this object
  72         :accessor proto-documentation
  73         :initarg :documentation
  74         :initform nil))
  75   (:documentation
  76    "The base class for all Protobufs model classes."))
  77
  78
  79 ;; A protobuf schema, corresponds to one .proto file
  80 (defclass protobuf-schema (base-protobuf)
  81   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
  82            :accessor proto-syntax
  83            :initarg :syntax
  84            :initform "proto2")
  85    (package :type (or null string)              ;the Protobufs package
  86             :accessor proto-package
  87             :initarg :package
  88             :initform nil)
  89    (lisp-pkg :type (or null string)              ;the Lisp package, from 'option lisp_package = ...'
  90              :accessor proto-lisp-package
  91              :initarg :lisp-package
  92              :initform nil)
  93    (imports :type (list-of string)              ;the names of schemas to be imported
  94             :accessor proto-imports
  95             :initarg :imports
  96             :initform ())
  97    (schemas :type (list-of protobuf-schema)     ;the schemas that were successfully imported
  98             :accessor proto-imported-schemas    ;this gets used for chasing namespaces
  99             :initform ())
 100    (enums :type (list-of protobuf-enum)         ;the set of enum types
 101           :accessor proto-enums
 102           :initarg :enums
 103           :initform ())
 104    (messages :type (list-of protobuf-message)   ;all the messages within this protobuf
 105              :accessor proto-messages
 106              :initarg :messages
 107              :initform ())
 108    (extenders :type (list-of protobuf-message)  ;the 'extend' messages in this protobuf
 109               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 110               :initarg :extenders
 111               :initform ())
 112    (services :type (list-of protobuf-service)
 113              :accessor proto-services
 114              :initarg :services
 115              :initform ()))
 116   (:documentation
 117    "The model class that represents a Protobufs schema, i.e., one .proto file."))
 118
 119 (defmethod make-load-form ((s protobuf-schema) &optional environment)
 120   (with-slots (class name) s
 121     (multiple-value-bind (constructor initializer)
 122         (make-load-form-saving-slots s :environment environment)
 123       (values `(let ((s ,constructor))
 124                   (record-protobuf s ',class ',name nil)
 125                   s)
 126               initializer))))
 127
 128 (defmethod record-protobuf ((schema protobuf-schema) &optional symbol name type)
 129   "Record all the names by which the Protobufs schema might be known."
 130   (declare (ignore type))
 131   (let ((symbol (or symbol (proto-class schema)))
 132         (name   (or name (proto-name schema))))
 133     (when symbol
 134       (setf (gethash (keywordify symbol) *all-schemas*) schema))
 135     (when name
 136       (setf (gethash (string-upcase name) *all-schemas*) schema))
 137     (let ((path (or *compile-file-pathname* *load-pathname*)))
 138       (when path
 139         ;; Record the file from which the Protobufs schema came, sans file type
 140         (setf (gethash (make-pathname :type nil :defaults (truename path)) *all-schemas*) schema)))))
 141
 142 (defmethod print-object ((s protobuf-schema) stream)
 143   (print-unreadable-object (s stream :type t :identity t)
 144     (format stream "~@[~S~]~@[ (package ~A)~]"
 145             (proto-class s) (proto-package s))))
 146
 147 (defgeneric find-message (protobuf type)
 148   (:documentation
 149    "Given a protobuf schema or message and a type name or class name,
 150     returns the Protobufs message corresponding to the type."))
 151
 152 (defmethod find-message ((schema protobuf-schema) (type symbol))
 153   ;; Extended messages "shadow" non-extended ones
 154   (labels ((find-it (schema)
 155              (let ((message (or (find type (proto-extenders schema) :key #'proto-class)
 156                                 (find type (proto-messages  schema) :key #'proto-class))))
 157                (when message
 158                  (return-from find-message message))
 159                (map () #'find-it (proto-imported-schemas schema)))))
 160     (find-it schema)))
 161
 162 (defmethod find-message ((schema protobuf-schema) (type class))
 163   (find-message schema (class-name type)))
 164
 165 (defmethod find-message ((schema protobuf-schema) (name string))
 166   (labels ((find-it (schema)
 167              (let ((message (or (find name (proto-extenders schema) :key #'proto-name :test #'string=)
 168                                 (find name (proto-messages  schema) :key #'proto-name :test #'string=))))
 169                (when message
 170                  (return-from find-message message))
 171                (map () #'find-it (proto-imported-schemas schema)))))
 172     (find-it schema)))
 173
 174 (defgeneric find-enum (protobuf type)
 175   (:documentation
 176    "Given a protobuf schema or message and the name of an enum type,
 177     returns the Protobufs enum corresponding to the type."))
 178
 179 (defmethod find-enum ((schema protobuf-schema) type)
 180   (labels ((find-it (schema)
 181              (let ((enum (find type (proto-enums schema) :key #'proto-class)))
 182                (when enum
 183                  (return-from find-enum enum))
 184                (map () #'find-it (proto-imported-schemas schema)))))
 185     (find-it schema)))
 186
 187 (defmethod find-enum ((schema protobuf-schema) (name string))
 188   (labels ((find-it (schema)
 189              (let ((enum (find name (proto-enums schema) :key #'proto-name :test #'string=)))
 190                (when enum
 191                  (return-from find-enum enum))
 192                (map () #'find-it (proto-imported-schemas schema)))))
 193     (find-it schema)))
 194
 195
 196 ;; We accept and store any option, but only act on a few: default, packed,
 197 ;; optimize_for, lisp_package, lisp_name, lisp_alias
 198 (defclass protobuf-option (abstract-protobuf)
 199   ((name :type string                           ;the key
 200          :reader proto-name
 201          :initarg :name)
 202    (value :accessor proto-value                 ;the (untyped) value
 203           :initarg :value
 204           :initform nil)
 205    (type :type (or null symbol)                 ;(optional) Lisp type,
 206          :reader proto-type                     ;  one of string, integer, sybol (for now)
 207          :initarg :type
 208          :initform 'string))
 209   (:documentation
 210    "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
 211
 212 (defmethod make-load-form ((o protobuf-option) &optional environment)
 213   (make-load-form-saving-slots o :environment environment))
 214
 215 (defmethod print-object ((o protobuf-option) stream)
 216   (print-unreadable-object (o stream :type t :identity t)
 217     (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
 218
 219 (defgeneric find-option (protobuf name)
 220   (:documentation
 221    "Given a protobuf schema, message, enum, etc and the name of an option,
 222     returns the value of the option and its (Lisp) type."))
 223
 224 (defmethod find-option ((protobuf base-protobuf) (name string))
 225   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 226     (and option
 227          (values (proto-value option) (proto-type option)))))
 228
 229 (defmethod find-option ((options list) (name string))
 230   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 231     (and option
 232          (values (proto-value option) (proto-type option)))))
 233
 234 (defgeneric remove-option (protobuf names)
 235   (:documentation
 236    "Given a protobuf schema, message, enum, etc and a set of option names,
 237     remove all of those options from the set of options."))
 238
 239 (defmethod remove-options ((protobuf base-protobuf) &rest names)
 240   (dolist (name names)
 241     (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 242       (when option
 243         ;; This side-effects 'proto-options'
 244         (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
 245
 246 (defmethod remove-options ((options list) &rest names)
 247   (dolist (name names)
 248     (let ((option (find name options :key #'proto-name :test #'option-name=)))
 249       (when option
 250         ;; This does not side-effect the list of options
 251         (remove option options)))))
 252
 253 (defun option-name= (name1 name2)
 254   (let* ((name1  (string name1))
 255          (name2  (string name2))
 256          (start1 (if (eql (char name1 0) #\() 1 0))
 257          (start2 (if (eql (char name2 0) #\() 1 0))
 258          (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 259          (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 260     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 261
 262
 263 ;; A protobuf enumeration
 264 (defclass protobuf-enum (base-protobuf)
 265   ((alias :type (or null symbol)                ;use this if you want to make this enum
 266           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 267           :initarg :alias-for
 268           :initform nil)
 269    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 270            :accessor proto-values
 271            :initarg :values
 272            :initform ()))
 273   (:documentation
 274    "The model class that represents a Protobufs enumeration type."))
 275
 276 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 277   (make-load-form-saving-slots e :environment environment))
 278
 279 (defmethod print-object ((e protobuf-enum) stream)
 280   (print-unreadable-object (e stream :type t :identity t)
 281     (format stream "~S~@[ (alias for ~S)~]"
 282             (proto-class e) (proto-alias-for e))))
 283
 284
 285 ;; A protobuf value within an enumeration
 286 (defclass protobuf-enum-value (base-protobuf)
 287   ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
 288           :accessor proto-index                 ;the index of the enum value
 289           :initarg :index)
 290    (value :type (or null symbol)
 291           :accessor proto-value                 ;the Lisp value of the enum
 292           :initarg :value
 293           :initform nil))
 294   (:documentation
 295    "The model class that represents a Protobufs enumeration value."))
 296
 297 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 298   (make-load-form-saving-slots v :environment environment))
 299
 300 (defmethod print-object ((v protobuf-enum-value) stream)
 301   (print-unreadable-object (v stream :type t :identity t)
 302     (format stream "~A = ~D"
 303             (proto-name v) (proto-index v))))
 304
 305
 306 ;; A protobuf message
 307 (defclass protobuf-message (base-protobuf)
 308   ((parent :type (or protobuf-schema protobuf-message)
 309            :accessor proto-parent
 310            :initarg :parent)
 311    (conc :type (or null string)                 ;the conc-name used for Lisp accessors
 312          :accessor proto-conc-name
 313          :initarg :conc-name
 314          :initform nil)
 315    (alias :type (or null symbol)                ;use this if you want to make this message
 316           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 317           :initarg :alias-for
 318           :initform nil)
 319    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 320           :accessor proto-enums
 321           :initarg :enums
 322           :initform ())
 323    (messages :type (list-of protobuf-message)   ;all the messages embedded in this one
 324              :accessor proto-messages
 325              :initarg :messages
 326              :initform ())
 327    (extenders :type (list-of protobuf-message)  ;the 'extend' messages embedded in this one
 328               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 329               :initarg :extenders
 330               :initform ())
 331    (fields :type (list-of protobuf-field)       ;all the fields of this message
 332            :accessor proto-fields               ;this includes local ones and extended ones
 333            :initarg :fields
 334            :initform ())
 335    (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
 336                     :accessor proto-extended-fields
 337                     :initform ())
 338    (extensions :type (list-of protobuf-extension) ;any extension ranges
 339                :accessor proto-extensions
 340                :initarg :extensions
 341                :initform ())
 342    ;; :message is an ordinary message
 343    ;; :group is a (deprecated) group (kind of an "implicit" message)
 344    ;; :extends is an 'extends' to an existing message
 345    (message-type :type (member :message :group :extends)
 346                  :accessor proto-message-type
 347                  :initarg :message-type
 348                  :initform :message))
 349     (:documentation
 350    "The model class that represents a Protobufs message."))
 351
 352 (defmethod make-load-form ((m protobuf-message) &optional environment)
 353   (with-slots (class name message-type) m
 354     (multiple-value-bind (constructor initializer)
 355         (make-load-form-saving-slots m :environment environment)
 356       (values (if (eq message-type :extends)
 357                 constructor
 358                 `(let ((m ,constructor))
 359                    (record-protobuf m ',class ',name ',message-type)
 360                    m))
 361               initializer))))
 362
 363 (defmethod record-protobuf ((message protobuf-message) &optional class name type)
 364   ;; No need to record an extension, it's already been recorded
 365   (let ((class (or class (proto-class message)))
 366         (name  (or name (proto-name message)))
 367         (type  (or type (proto-message-type message))))
 368     (unless (eq type :extends)
 369       (when class
 370         (setf (gethash class *all-messages*) message))
 371       (when name
 372         (setf (gethash name *all-messages*) message)))))
 373
 374 (defmethod print-object ((m protobuf-message) stream)
 375   (print-unreadable-object (m stream :type t :identity t)
 376     (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 377             (proto-class m) (proto-alias-for m)
 378             (eq (proto-message-type m) :group)
 379             (eq (proto-message-type m) :extends))))
 380
 381 (defmethod find-message ((message protobuf-message) (type symbol))
 382   ;; Extended messages "shadow" non-extended ones
 383   (or (find type (proto-extenders message) :key #'proto-class)
 384       (find type (proto-messages message) :key #'proto-class)
 385       (find-message (proto-parent message) type)))
 386
 387 (defmethod find-message ((message protobuf-message) (type class))
 388   (find-message message (class-name type)))
 389
 390 (defmethod find-message ((message protobuf-message) (name string))
 391   (or (find name (proto-extenders message) :key #'proto-name :test #'string=)
 392       (find name (proto-messages message) :key #'proto-name :test #'string=)
 393       (find-message (proto-parent message) name)))
 394
 395 (defmethod find-enum ((message protobuf-message) type)
 396   (or (find type (proto-enums message) :key #'proto-class)
 397       (find-enum (proto-parent message) type)))
 398
 399 (defmethod find-enum ((message protobuf-message) (name string))
 400   (or (find name (proto-enums message) :key #'proto-name :test #'string=)
 401       (find-enum (proto-parent message) name)))
 402
 403 (defgeneric find-field (message name)
 404   (:documentation
 405    "Given a protobuf message and a slot name or field name,
 406     returns the Protobufs field having that name."))
 407
 408 (defmethod find-field ((message protobuf-message) (name symbol))
 409   (find name (proto-fields message) :key #'proto-value))
 410
 411 (defmethod find-field ((message protobuf-message) (name string))
 412   (find name (proto-fields message) :key #'proto-name :test #'string=))
 413
 414 ;; Extensions protocol
 415 (defgeneric get-extension (object slot)
 416   (:documentation
 417    "Returns the value of the extended slot 'slot' in 'object'"))
 418
 419 (defgeneric set-extension (object slot value)
 420   (:documentation
 421    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 422
 423 (defgeneric has-extension (object slot)
 424   (:documentation
 425    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 426   ;; The only default method is for 'has-extension'
 427   ;; It's an error to call the other three functions on a non-extendable object
 428   (:method ((object standard-object) slot)
 429     (declare (ignore slot))
 430     nil))
 431
 432 (defgeneric clear-extension (object slot)
 433   (:documentation
 434    "Clears the value of the extended slot 'slot' from 'object'"))
 435
 436
 437 ;; A protobuf field within a message
 438 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 439 (defclass protobuf-field (base-protobuf)
 440   ((type :type string                           ;the name of the Protobuf type for the field
 441          :accessor proto-type
 442          :initarg :type)
 443    (required :type (member :required :optional :repeated)
 444              :accessor proto-required
 445              :initarg :required)
 446    (index :type (integer 1 #.(1- (ash 1 29)))   ;the index number for this field
 447           :accessor proto-index
 448           :initarg :index)
 449    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 450           :accessor proto-value                 ;this also serves as the Lisp field name
 451           :initarg :value
 452           :initform nil)
 453    (reader :type (or null symbol)               ;a reader that is used to access the value
 454            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 455            :initarg :reader
 456            :initform nil)
 457    (writer :type (or null symbol list)          ;a writer that is used to set the value
 458            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 459            :initarg :writer
 460            :initform nil)
 461    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 462             :initarg :default
 463             :initform nil)
 464    (packed :type (member t nil)                 ;packed, pulled out of the options
 465            :accessor proto-packed
 466            :initarg :packed
 467            :initform nil)
 468    ;; Copied from 'proto-message-type' of the field
 469    (message-type :type (member :message :group :extends)
 470                  :accessor proto-message-type
 471                  :initarg :message-type
 472                  :initform :message))
 473   (:documentation
 474    "The model class that represents one field within a Protobufs message."))
 475
 476 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 477   (declare (ignore initargs))
 478   (when (slot-boundp field 'index)
 479     (assert (not (<= 19000 (proto-index field) 19999)) ()
 480             "Protobuf field indexes between 19000 and 19999 are not allowed")))
 481
 482 (defmethod make-load-form ((f protobuf-field) &optional environment)
 483   (make-load-form-saving-slots f :environment environment))
 484
 485 (defmethod print-object ((f protobuf-field) stream)
 486   (print-unreadable-object (f stream :type t :identity t)
 487     (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 488             (proto-value f) (proto-class f) (proto-index f)
 489             (eq (proto-message-type f) :group)
 490             (eq (proto-message-type f) :extends))))
 491
 492
 493 ;; An extension range within a message
 494 (defclass protobuf-extension (abstract-protobuf)
 495   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 496          :accessor proto-extension-from
 497          :initarg :from)
 498    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 499        :accessor proto-extension-to
 500        :initarg :to))
 501   (:documentation
 502    "The model class that represents an extension range within a Protobufs message."))
 503
 504 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 505   (make-load-form-saving-slots e :environment environment))
 506
 507 (defmethod print-object ((e protobuf-extension) stream)
 508   (print-unreadable-object (e stream :type t :identity t)
 509     (format stream "~D - ~D"
 510             (proto-extension-from e) (proto-extension-from e))))
 511
 512
 513 ;; A protobuf service
 514 (defclass protobuf-service (base-protobuf)
 515   ((methods :type (list-of protobuf-method)     ;the methods in the service
 516             :accessor proto-methods
 517             :initarg :methods
 518             :initform ()))
 519   (:documentation
 520    "The model class that represents a Protobufs service."))
 521
 522 (defmethod make-load-form ((s protobuf-service) &optional environment)
 523   (make-load-form-saving-slots s :environment environment))
 524
 525 (defmethod print-object ((s protobuf-service) stream)
 526   (print-unreadable-object (s stream :type t :identity t)
 527     (format stream "~A"
 528             (proto-name s))))
 529
 530
 531 ;; A protobuf method within a service
 532 (defclass protobuf-method (base-protobuf)
 533   ((itype :type (or null symbol)                ;the Lisp type name of the input
 534            :accessor proto-input-type
 535            :initarg :input-type
 536            :initform nil)
 537    (iname :type (or null string)                ;the Protobufs name of the input
 538           :accessor proto-input-name
 539           :initarg :input-name
 540           :initform nil)
 541    (otype :type (or null symbol)                ;the Lisp type name of the output
 542            :accessor proto-output-type
 543            :initarg :output-type
 544            :initform nil)
 545    (oname :type (or null string)                ;the Protobufs name of the output
 546           :accessor proto-output-name
 547           :initarg :output-name
 548           :initform nil))
 549   (:documentation
 550    "The model class that represents one method with a Protobufs service."))
 551
 552 (defmethod make-load-form ((m protobuf-method) &optional environment)
 553   (make-load-form-saving-slots m :environment environment))
 554
 555 (defmethod print-object ((m protobuf-method) stream)
 556   (print-unreadable-object (m stream :type t :identity t)
 557     (format stream "~S (~S) => (~S)"
 558             (proto-function m) (proto-input-type m) (proto-output-type m))))
 559
 560 ;; The 'class' slot really holds the name of the function,
 561 ;; so let's give it a better name
 562 (defmethod proto-function ((method protobuf-method))
 563   (proto-class method))
 564
 565 (defmethod (setf proto-function) (function (method protobuf-method))
 566   (setf (proto-function method) function))