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 (defun option-name= (name1 name2)
 235   (let* ((name1  (string name1))
 236          (name2  (string name2))
 237          (start1 (if (eql (char name1 0) #\() 1 0))
 238          (start2 (if (eql (char name2 0) #\() 1 0))
 239          (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 240          (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 241     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 242
 243
 244 ;; A protobuf enumeration
 245 (defclass protobuf-enum (base-protobuf)
 246   ((alias :type (or null symbol)                ;use this if you want to make this enum
 247           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 248           :initarg :alias-for
 249           :initform nil)
 250    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 251            :accessor proto-values
 252            :initarg :values
 253            :initform ()))
 254   (:documentation
 255    "The model class that represents a Protobufs enumeration type."))
 256
 257 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 258   (make-load-form-saving-slots e :environment environment))
 259
 260 (defmethod print-object ((e protobuf-enum) stream)
 261   (print-unreadable-object (e stream :type t :identity t)
 262     (format stream "~S~@[ (alias for ~S)~]"
 263             (proto-class e) (proto-alias-for e))))
 264
 265
 266 ;; A protobuf value within an enumeration
 267 (defclass protobuf-enum-value (base-protobuf)
 268   ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
 269           :accessor proto-index                 ;the index of the enum value
 270           :initarg :index)
 271    (value :type (or null symbol)
 272           :accessor proto-value                 ;the Lisp value of the enum
 273           :initarg :value
 274           :initform nil))
 275   (:documentation
 276    "The model class that represents a Protobufs enumeration value."))
 277
 278 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 279   (make-load-form-saving-slots v :environment environment))
 280
 281 (defmethod print-object ((v protobuf-enum-value) stream)
 282   (print-unreadable-object (v stream :type t :identity t)
 283     (format stream "~A = ~D"
 284             (proto-name v) (proto-index v))))
 285
 286
 287 ;; A protobuf message
 288 (defclass protobuf-message (base-protobuf)
 289   ((parent :type (or protobuf-schema protobuf-message)
 290            :accessor proto-parent
 291            :initarg :parent)
 292    (conc :type (or null string)                 ;the conc-name used for Lisp accessors
 293          :accessor proto-conc-name
 294          :initarg :conc-name
 295          :initform nil)
 296    (alias :type (or null symbol)                ;use this if you want to make this message
 297           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 298           :initarg :alias-for
 299           :initform nil)
 300    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 301           :accessor proto-enums
 302           :initarg :enums
 303           :initform ())
 304    (messages :type (list-of protobuf-message)   ;all the messages embedded in this one
 305              :accessor proto-messages
 306              :initarg :messages
 307              :initform ())
 308    (extenders :type (list-of protobuf-message)  ;the 'extend' messages embedded in this one
 309               :accessor proto-extenders         ;these precede unextended messages in 'find-message'
 310               :initarg :extenders
 311               :initform ())
 312    (fields :type (list-of protobuf-field)       ;all the fields of this message
 313            :accessor proto-fields               ;this includes local ones and extended ones
 314            :initarg :fields
 315            :initform ())
 316    (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
 317                     :accessor proto-extended-fields
 318                     :initform ())
 319    (extensions :type (list-of protobuf-extension) ;any extension ranges
 320                :accessor proto-extensions
 321                :initarg :extensions
 322                :initform ())
 323    ;; :message is an ordinary message
 324    ;; :group is a (deprecated) group (kind of an "implicit" message)
 325    ;; :extends is an 'extends' to an existing message
 326    (message-type :type (member :message :group :extends)
 327                  :accessor proto-message-type
 328                  :initarg :message-type
 329                  :initform :message))
 330     (:documentation
 331    "The model class that represents a Protobufs message."))
 332
 333 (defmethod make-load-form ((m protobuf-message) &optional environment)
 334   (with-slots (class name message-type) m
 335     (multiple-value-bind (constructor initializer)
 336         (make-load-form-saving-slots m :environment environment)
 337       (values (if (eq message-type :extends)
 338                 constructor
 339                 `(let ((m ,constructor))
 340                    (record-protobuf m ',class ',name ',message-type)
 341                    m))
 342               initializer))))
 343
 344 (defmethod record-protobuf ((message protobuf-message) &optional class name type)
 345   ;; No need to record an extension, it's already been recorded
 346   (let ((class (or class (proto-class message)))
 347         (name  (or name (proto-name message)))
 348         (type  (or type (proto-message-type message))))
 349     (unless (eq type :extends)
 350       (when class
 351         (setf (gethash class *all-messages*) message))
 352       (when name
 353         (setf (gethash name *all-messages*) message)))))
 354
 355 (defmethod print-object ((m protobuf-message) stream)
 356   (print-unreadable-object (m stream :type t :identity t)
 357     (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 358             (proto-class m) (proto-alias-for m)
 359             (eq (proto-message-type m) :group)
 360             (eq (proto-message-type m) :extends))))
 361
 362 (defmethod find-message ((message protobuf-message) (type symbol))
 363   ;; Extended messages "shadow" non-extended ones
 364   (or (find type (proto-extenders message) :key #'proto-class)
 365       (find type (proto-messages message) :key #'proto-class)
 366       (find-message (proto-parent message) type)))
 367
 368 (defmethod find-message ((message protobuf-message) (type class))
 369   (find-message message (class-name type)))
 370
 371 (defmethod find-message ((message protobuf-message) (name string))
 372   (or (find name (proto-extenders message) :key #'proto-name :test #'string=)
 373       (find name (proto-messages message) :key #'proto-name :test #'string=)
 374       (find-message (proto-parent message) name)))
 375
 376 (defmethod find-enum ((message protobuf-message) type)
 377   (or (find type (proto-enums message) :key #'proto-class)
 378       (find-enum (proto-parent message) type)))
 379
 380 (defmethod find-enum ((message protobuf-message) (name string))
 381   (or (find name (proto-enums message) :key #'proto-name :test #'string=)
 382       (find-enum (proto-parent message) name)))
 383
 384 (defgeneric find-field (message name)
 385   (:documentation
 386    "Given a protobuf message and a slot name or field name,
 387     returns the Protobufs field having that name."))
 388
 389 (defmethod find-field ((message protobuf-message) (name symbol))
 390   (find name (proto-fields message) :key #'proto-value))
 391
 392 (defmethod find-field ((message protobuf-message) (name string))
 393   (find name (proto-fields message) :key #'proto-name :test #'string=))
 394
 395 ;; Extensions protocol
 396 (defgeneric get-extension (object slot)
 397   (:documentation
 398    "Returns the value of the extended slot 'slot' in 'object'"))
 399
 400 (defgeneric set-extension (object slot value)
 401   (:documentation
 402    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 403
 404 (defgeneric has-extension (object slot)
 405   (:documentation
 406    "Returns true iff the there is an extended slot named 'slot' in 'object'")
 407   ;; The only default method is for 'has-extension'
 408   ;; It's an error to call the other three functions on a non-extendable object
 409   (:method ((object standard-object) slot)
 410     (declare (ignore slot))
 411     nil))
 412
 413 (defgeneric clear-extension (object slot)
 414   (:documentation
 415    "Clears the value of the extended slot 'slot' from 'object'"))
 416
 417
 418 ;; A protobuf field within a message
 419 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 420 (defclass protobuf-field (base-protobuf)
 421   ((type :type string                           ;the name of the Protobuf type for the field
 422          :accessor proto-type
 423          :initarg :type)
 424    (required :type (member :required :optional :repeated)
 425              :accessor proto-required
 426              :initarg :required)
 427    (index :type (integer 1 #.(1- (ash 1 29)))   ;the index number for this field
 428           :accessor proto-index
 429           :initarg :index)
 430    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 431           :accessor proto-value                 ;this also serves as the Lisp field name
 432           :initarg :value
 433           :initform nil)
 434    (reader :type (or null symbol)               ;a reader that is used to access the value
 435            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 436            :initarg :reader
 437            :initform nil)
 438    (writer :type (or null symbol list)          ;a writer that is used to set the value
 439            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 440            :initarg :writer
 441            :initform nil)
 442    (default :accessor proto-default             ;default value (untyped), pulled out of the options
 443             :initarg :default
 444             :initform nil)
 445    (packed :type (member t nil)                 ;packed, pulled out of the options
 446            :accessor proto-packed
 447            :initarg :packed
 448            :initform nil)
 449    ;; Copied from 'proto-message-type' of the field
 450    (message-type :type (member :message :group :extends)
 451                  :accessor proto-message-type
 452                  :initarg :message-type
 453                  :initform :message))
 454   (:documentation
 455    "The model class that represents one field within a Protobufs message."))
 456
 457 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 458   (declare (ignore initargs))
 459   (when (slot-boundp field 'index)
 460     (assert (not (<= 19000 (proto-index field) 19999)) ()
 461             "Protobuf field indexes between 19000 and 19999 are not allowed")))
 462
 463 (defmethod make-load-form ((f protobuf-field) &optional environment)
 464   (make-load-form-saving-slots f :environment environment))
 465
 466 (defmethod print-object ((f protobuf-field) stream)
 467   (print-unreadable-object (f stream :type t :identity t)
 468     (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 469             (proto-value f) (proto-class f) (proto-index f)
 470             (eq (proto-message-type f) :group)
 471             (eq (proto-message-type f) :extends))))
 472
 473
 474 ;; An extension range within a message
 475 (defclass protobuf-extension (abstract-protobuf)
 476   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 477          :accessor proto-extension-from
 478          :initarg :from)
 479    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 480        :accessor proto-extension-to
 481        :initarg :to))
 482   (:documentation
 483    "The model class that represents an extension range within a Protobufs message."))
 484
 485 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 486   (make-load-form-saving-slots e :environment environment))
 487
 488 (defmethod print-object ((e protobuf-extension) stream)
 489   (print-unreadable-object (e stream :type t :identity t)
 490     (format stream "~D - ~D"
 491             (proto-extension-from e) (proto-extension-from e))))
 492
 493
 494 ;; A protobuf service
 495 (defclass protobuf-service (base-protobuf)
 496   ((methods :type (list-of protobuf-method)     ;the methods in the service
 497             :accessor proto-methods
 498             :initarg :methods
 499             :initform ()))
 500   (:documentation
 501    "The model class that represents a Protobufs service."))
 502
 503 (defmethod make-load-form ((s protobuf-service) &optional environment)
 504   (make-load-form-saving-slots s :environment environment))
 505
 506 (defmethod print-object ((s protobuf-service) stream)
 507   (print-unreadable-object (s stream :type t :identity t)
 508     (format stream "~A"
 509             (proto-name s))))
 510
 511
 512 ;; A protobuf method within a service
 513 (defclass protobuf-method (base-protobuf)
 514   ((itype :type (or null symbol)                ;the Lisp type name of the input
 515            :accessor proto-input-type
 516            :initarg :input-type
 517            :initform nil)
 518    (iname :type (or null string)                ;the Protobufs name of the input
 519           :accessor proto-input-name
 520           :initarg :input-name
 521           :initform nil)
 522    (otype :type (or null symbol)                ;the Lisp type name of the output
 523            :accessor proto-output-type
 524            :initarg :output-type
 525            :initform nil)
 526    (oname :type (or null string)                ;the Protobufs name of the output
 527           :accessor proto-output-name
 528           :initarg :output-name
 529           :initform nil))
 530   (:documentation
 531    "The model class that represents one method with a Protobufs service."))
 532
 533 (defmethod make-load-form ((m protobuf-method) &optional environment)
 534   (make-load-form-saving-slots m :environment environment))
 535
 536 (defmethod print-object ((m protobuf-method) stream)
 537   (print-unreadable-object (m stream :type t :identity t)
 538     (format stream "~S (~S) => (~S)"
 539             (proto-function m) (proto-input-type m) (proto-output-type m))))
 540
 541 ;; The 'class' slot really holds the name of the function,
 542 ;; so let's give it a better name
 543 (defmethod proto-function ((method protobuf-method))
 544   (proto-class method))
 545
 546 (defmethod (setf proto-function) (function (method protobuf-method))
 547   (setf (proto-function method) function))