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-protobufs* (make-hash-table :test #'equal)
  17   "A table mapping names to 'protobuf' schemas.")
  18
  19 (defun find-protobuf (name)
  20   "Given a name (a symbol or string), return the 'protobuf' schema having that name."
  21   (values (gethash name *all-protobufs*)))
  22
  23
  24 (defvar *all-messages* (make-hash-table :test #'equal)
  25   "A table mapping Lisp class names to 'protobuf' messages.")
  26
  27 (defmethod find-message-for-class (class)
  28   "Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
  29   (values (gethash class *all-messages*)))
  30
  31 (defmethod find-message-for-class ((class class))
  32   (values (gethash (class-name class) *all-messages*)))
  33
  34
  35 ;; A few things (the pretty printer) want to keep track of the current schema
  36 (defvar *protobuf* nil)
  37 (defvar *protobuf-package* nil)
  38
  39
  40 ;;; The model classes
  41
  42 (defclass abstract-protobuf () ())
  43
  44 (defclass base-protobuf (abstract-protobuf)
  45   ((class :type (or null symbol)                ;the Lisp name for this object
  46           :accessor proto-class                 ;this often names a type or class
  47           :initarg :class
  48           :initform nil)
  49    (name :type (or null string)                 ;the Protobufs name for this enum, message, etc
  50          :reader proto-name
  51          :initarg :name
  52          :initform nil)
  53    (options :type (list-of protobuf-option)     ;options, mostly just passed along
  54             :accessor proto-options
  55             :initarg :options
  56             :initform ())
  57    (doc :type (or null string)                  ;documentation for this object
  58         :accessor proto-documentation
  59         :initarg :documentation
  60         :initform nil))
  61   (:documentation
  62    "The base class for all Protobufs model classes."))
  63
  64
  65 ;; The protobuf, corresponds to one .proto file
  66 (defclass protobuf (base-protobuf)
  67   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
  68            :accessor proto-syntax
  69            :initarg :syntax
  70            :initform "proto2")
  71    (package :type (or null string)              ;the Protobufs package
  72             :accessor proto-package
  73             :initarg :package
  74             :initform nil)
  75    (lisp-pkg :type (or null string)              ;the Lisp package, from 'option lisp_package = ...'
  76              :accessor proto-lisp-package
  77              :initarg :lisp-package
  78              :initform nil)
  79    (imports :type (list-of string)              ;any imports
  80             :accessor proto-imports
  81             :initarg :imports
  82             :initform ())
  83    (enums :type (list-of protobuf-enum)         ;the set of enum types
  84           :accessor proto-enums
  85           :initarg :enums
  86           :initform ())
  87    (messages :type (list-of protobuf-message)   ;the set of messages
  88              :accessor proto-messages
  89              :initarg :messages
  90              :initform ())
  91    (extenders :type (list-of protobuf-message)  ;the set of extended messages
  92               :accessor proto-extenders
  93               :initarg :extenders
  94               :initform ())
  95    (services :type (list-of protobuf-service)
  96              :accessor proto-services
  97              :initarg :services
  98              :initform ()))
  99   (:documentation
 100    "The model class that represents a Protobufs schema, i.e., one .proto file."))
 101
 102 (defmethod initialize-instance :after ((protobuf protobuf) &rest initargs)
 103   (declare (ignore initargs))
 104   ;; Record this schema under both its Lisp and its Protobufs name
 105   (with-slots (class name) protobuf
 106     (record-protobuf protobuf class name)))
 107
 108 (defmethod record-protobuf ((protobuf protobuf) class name)
 109   (when class
 110     (setf (gethash class *all-protobufs*) protobuf))
 111   (when name
 112     (setf (gethash name *all-protobufs*) protobuf)))
 113
 114 (defmethod make-load-form ((p protobuf) &optional environment)
 115   (with-slots (class name) p
 116     (multiple-value-bind (constructor initializer)
 117         (make-load-form-saving-slots p :environment environment)
 118       (values `(let ((p ,constructor))
 119                   (record-protobuf p ',class ',name)
 120                   p)
 121               initializer))))
 122
 123 (defmethod print-object ((p protobuf) stream)
 124   (print-unreadable-object (p stream :type t :identity t)
 125     (format stream "~@[~S~]~@[ (package ~A)~]"
 126             (proto-class p) (proto-package p))))
 127
 128 (defgeneric find-message (protobuf type)
 129   (:documentation
 130    "Given a protobuf schema or message and a type name or class name,
 131     returns the Protobufs message corresponding to the type."))
 132
 133 (defmethod find-message ((protobuf protobuf) (type symbol))
 134   ;; Extended messages "shadow" non-extended ones
 135   (or (find type (proto-extenders protobuf) :key #'proto-class)
 136       (find type (proto-messages protobuf) :key #'proto-class)))
 137
 138 (defmethod find-message ((protobuf protobuf) (type class))
 139   (find-message protobuf (class-name type)))
 140
 141 (defmethod find-message ((protobuf protobuf) (type string))
 142   (or (find type (proto-extenders protobuf) :key #'proto-name :test #'string=)
 143       (find type (proto-messages protobuf) :key #'proto-name :test #'string=)))
 144
 145 (defgeneric find-enum (protobuf type)
 146   (:documentation
 147    "Given a protobuf schema or message and the name of an enum type,
 148     returns the Protobufs enum corresponding to the type."))
 149
 150 (defmethod find-enum ((protobuf protobuf) type)
 151   (find type (proto-enums protobuf) :key #'proto-class))
 152
 153 (defmethod find-enum ((protobuf protobuf) (type string))
 154   (find type (proto-enums protobuf) :key #'proto-name :test #'string=))
 155
 156
 157 ;; We accept and store any option, but only act on a few: default, packed,
 158 ;; optimize_for, lisp_package, lisp_name, lisp_alias
 159 (defclass protobuf-option (abstract-protobuf)
 160   ((name :type string                           ;the key
 161          :reader proto-name
 162          :initarg :name)
 163    (value :type (or null string)                ;the value
 164           :accessor proto-value
 165           :initarg :value
 166           :initform nil)
 167    (type :type (or null symbol)                 ;(optional) Lisp type,
 168          :reader proto-type                     ;  one of string, integer, sybol (for now)
 169          :initarg :type
 170          :initform 'string))
 171   (:documentation
 172    "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
 173
 174 (defmethod make-load-form ((o protobuf-option) &optional environment)
 175   (make-load-form-saving-slots o :environment environment))
 176
 177 (defmethod print-object ((o protobuf-option) stream)
 178   (print-unreadable-object (o stream :type t :identity t)
 179     (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
 180
 181 (defgeneric find-option (protobuf name)
 182   (:documentation
 183    "Given a protobuf schema, message, enum, etc and the name of an option,
 184     returns the value of the option and its (Lisp) type."))
 185
 186 (defmethod find-option ((protobuf base-protobuf) (name string))
 187   (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
 188     (and option
 189          (values (proto-value option) (proto-type option)))))
 190
 191 (defmethod find-option ((options list) (name string))
 192   (let ((option (find name options :key #'proto-name :test #'option-name=)))
 193     (and option
 194          (values (proto-value option) (proto-type option)))))
 195
 196 (defun option-name= (name1 name2)
 197   (let ((start1 (if (eql (char name1 0) #\() 1 0))
 198         (start2 (if (eql (char name2 0) #\() 1 0))
 199         (end1   (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
 200         (end2   (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
 201     (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
 202
 203
 204 ;; A protobuf enumeration
 205 (defclass protobuf-enum (base-protobuf)
 206   ((alias :type (or null symbol)                ;use this if you want to make this enum
 207           :accessor proto-alias-for             ;  be an alias for an existing Lisp enum
 208           :initarg :alias-for
 209           :initform nil)
 210    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 211            :accessor proto-values
 212            :initarg :values
 213            :initform ()))
 214   (:documentation
 215    "The model class that represents a Protobufs enumeration type."))
 216
 217 (defmethod make-load-form ((e protobuf-enum) &optional environment)
 218   (make-load-form-saving-slots e :environment environment))
 219
 220 (defmethod print-object ((e protobuf-enum) stream)
 221   (print-unreadable-object (e stream :type t :identity t)
 222     (format stream "~S~@[ (alias for ~S)~]"
 223             (proto-class e) (proto-alias-for e))))
 224
 225
 226 ;; A protobuf value within an enumeration
 227 (defclass protobuf-enum-value (base-protobuf)
 228   ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
 229           :accessor proto-index                 ;the index of the enum value
 230           :initarg :index)
 231    (value :type (or null symbol)
 232           :accessor proto-value                 ;the Lisp value of the enum
 233           :initarg :value
 234           :initform nil))
 235   (:documentation
 236    "The model class that represents a Protobufs enumeration value."))
 237
 238 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
 239   (make-load-form-saving-slots v :environment environment))
 240
 241 (defmethod print-object ((v protobuf-enum-value) stream)
 242   (print-unreadable-object (v stream :type t :identity t)
 243     (format stream "~A = ~D"
 244             (proto-name v) (proto-index v))))
 245
 246
 247 ;; A protobuf message
 248 (defclass protobuf-message (base-protobuf)
 249   ((parent :type (or protobuf protobuf-message)
 250            :accessor proto-parent
 251            :initarg :parent)
 252    (conc :type (or null string)                 ;the conc-name used for Lisp accessors
 253          :accessor proto-conc-name
 254          :initarg :conc-name
 255          :initform nil)
 256    (alias :type (or null symbol)                ;use this if you want to make this message
 257           :accessor proto-alias-for             ;  be an alias for an existing Lisp class
 258           :initarg :alias-for
 259           :initform nil)
 260    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 261           :accessor proto-enums
 262           :initarg :enums
 263           :initform ())
 264    (messages :type (list-of protobuf-message)   ;the embedded messages
 265              :accessor proto-messages
 266              :initarg :messages
 267              :initform ())
 268    (extenders :type (list-of protobuf-message)  ;the set of extended messages
 269               :accessor proto-extenders
 270               :initarg :extenders
 271               :initform ())
 272    (fields :type (list-of protobuf-field)       ;the fields
 273            :accessor proto-fields
 274            :initarg :fields
 275            :initform ())
 276    (extensions :type (list-of protobuf-extension) ;any extensions
 277                :accessor proto-extensions
 278                :initarg :extensions
 279                :initform ())
 280    ;; :message is an ordinary message
 281    ;; :group is a (deprecated) group (kind of an "implicit" message)
 282    ;; :extends is an 'extends' to an existing message
 283    (message-type :type (member :message :group :extends)
 284                  :accessor proto-message-type
 285                  :initarg :message-type
 286                  :initform :message))
 287     (:documentation
 288    "The model class that represents a Protobufs message."))
 289
 290 (defmethod initialize-instance :after ((message protobuf-message) &rest initargs)
 291   (declare (ignore initargs))
 292   ;; Record this message under just its Lisp class name
 293   (with-slots (class name message-type) message
 294     ;; No need to record an extension, it's already been recorded
 295     (when (not (eq message-type :extends))
 296       (record-protobuf message class name))))
 297
 298 (defmethod record-protobuf ((message protobuf-message) class name)
 299   (when class
 300     (setf (gethash class *all-messages*) message))
 301   (when name
 302     (setf (gethash name *all-messages*) message)))
 303
 304 (defmethod make-load-form ((m protobuf-message) &optional environment)
 305   (with-slots (class name message-type) m
 306     (multiple-value-bind (constructor initializer)
 307         (make-load-form-saving-slots m :environment environment)
 308       (values (if (eq message-type :extends)
 309                 constructor
 310                 `(let ((m ,constructor))
 311                    (record-protobuf m ',class ',name)
 312                    m))
 313               initializer))))
 314
 315 (defmethod print-object ((m protobuf-message) stream)
 316   (print-unreadable-object (m stream :type t :identity t)
 317     (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
 318             (proto-class m) (proto-alias-for m)
 319             (eq (proto-message-type m) :group)
 320             (eq (proto-message-type m) :extends))))
 321
 322 (defmethod find-message ((message protobuf-message) (type symbol))
 323   ;; Extended messages "shadow" non-extended ones
 324   (or (find type (proto-extenders message) :key #'proto-class)
 325       (find type (proto-messages message) :key #'proto-class)
 326       (find-message (proto-parent message) type)))
 327
 328 (defmethod find-message ((message protobuf-message) (type class))
 329   (find-message message (class-name type)))
 330
 331 (defmethod find-message ((message protobuf-message) (type string))
 332   (or (find type (proto-extenders message) :key #'proto-name :test #'string=)
 333       (find type (proto-messages message) :key #'proto-name :test #'string=)
 334       (find-message (proto-parent message) type)))
 335
 336 (defmethod find-enum ((message protobuf-message) type)
 337   (or (find type (proto-enums message) :key #'proto-class)
 338       (find-enum (proto-parent message) type)))
 339
 340 (defmethod find-enum ((message protobuf-message) (type string))
 341   (or (find type (proto-enums message) :key #'proto-name :test #'string=)
 342       (find-enum (proto-parent message) type)))
 343
 344 (defgeneric find-field (message name)
 345   (:documentation
 346    "Given a protobuf message and a slot name or field name,
 347     returns the Protobufs field having that name."))
 348
 349 (defmethod find-field ((message protobuf-message) (name symbol))
 350   (find name (proto-fields message) :key #'proto-value))
 351
 352 (defmethod find-field ((message protobuf-message) (name string))
 353   (find name (proto-fields message) :key #'proto-name :test #'string=))
 354
 355 ;; Extensions protocol
 356 (defgeneric get-extension (object slot)
 357   (:documentation
 358    "Returns the value of the extended slot 'slot' in 'object'"))
 359
 360 (defgeneric set-extension (object slot value)
 361   (:documentation
 362    "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
 363
 364 (defgeneric has-extension (object slot)
 365   (:documentation
 366    "Returns true iff the there is an extended slot named 'slot' in 'object'"))
 367
 368 (defgeneric clear-extension (object slot)
 369   (:documentation
 370    "Clears the value of the extended slot 'slot' from 'object'"))
 371
 372
 373 ;; A protobuf field within a message
 374 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
 375 (defclass protobuf-field (base-protobuf)
 376   ((type :type string                           ;the name of the Protobuf type for the field
 377          :accessor proto-type
 378          :initarg :type)
 379    (required :type (member :required :optional :repeated)
 380              :accessor proto-required
 381              :initarg :required)
 382    (index :type (integer 1 #.(1- (ash 1 29)))   ;the index number for this field
 383           :accessor proto-index
 384           :initarg :index)
 385    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 386           :accessor proto-value                 ;this also serves as the Lisp field name
 387           :initarg :value
 388           :initform nil)
 389    (reader :type (or null symbol)               ;a reader that is used to access the value
 390            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 391            :initarg :reader
 392            :initform nil)
 393    (writer :type (or null symbol list)          ;a writer that is used to set the value
 394            :accessor proto-writer               ;when it's a list, it's something like '(setf title)'
 395            :initarg :writer
 396            :initform nil)
 397    (default :type (or null string)              ;default value, pulled out of the options
 398             :accessor proto-default
 399             :initarg :default
 400             :initform nil)
 401    (packed :type (member t nil)                 ;packed, pulled out of the options
 402            :accessor proto-packed
 403            :initarg :packed
 404            :initform nil)
 405    ;; Copied from 'proto-message-type' of the field
 406    (message-type :type (member :message :group :extends)
 407                  :accessor proto-message-type
 408                  :initarg :message-type
 409                  :initform :message))
 410   (:documentation
 411    "The model class that represents one field within a Protobufs message."))
 412
 413 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 414   (declare (ignore initargs))
 415   (when (slot-boundp field 'index)
 416     (assert (not (<= 19000 (proto-index field) 19999)) ()
 417             "Protobuf field indexes between 19000 and 19999 are not allowed")))
 418
 419 (defmethod make-load-form ((f protobuf-field) &optional environment)
 420   (make-load-form-saving-slots f :environment environment))
 421
 422 (defmethod print-object ((f protobuf-field) stream)
 423   (print-unreadable-object (f stream :type t :identity t)
 424     (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
 425             (proto-value f) (proto-class f) (proto-index f)
 426             (eq (proto-message-type f) :group)
 427             (eq (proto-message-type f) :extends))))
 428
 429
 430 ;; An extension within a message
 431 (defclass protobuf-extension (abstract-protobuf)
 432   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 433          :accessor proto-extension-from
 434          :initarg :from)
 435    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 436        :accessor proto-extension-to
 437        :initarg :to))
 438   (:documentation
 439    "The model class that represents an extension with a Protobufs message."))
 440
 441 (defmethod make-load-form ((e protobuf-extension) &optional environment)
 442   (make-load-form-saving-slots e :environment environment))
 443
 444 (defmethod print-object ((e protobuf-extension) stream)
 445   (print-unreadable-object (e stream :type t :identity t)
 446     (format stream "~D - ~D"
 447             (proto-extension-from e) (proto-extension-from e))))
 448
 449
 450 ;; A protobuf service
 451 (defclass protobuf-service (base-protobuf)
 452   ((methods :type (list-of protobuf-method)     ;the methods in the service
 453             :accessor proto-methods
 454             :initarg :methods
 455             :initform ()))
 456   (:documentation
 457    "The model class that represents a Protobufs service."))
 458
 459 (defmethod make-load-form ((s protobuf-service) &optional environment)
 460   (make-load-form-saving-slots s :environment environment))
 461
 462 (defmethod print-object ((s protobuf-service) stream)
 463   (print-unreadable-object (s stream :type t :identity t)
 464     (format stream "~A"
 465             (proto-name s))))
 466
 467
 468 ;; A protobuf method within a service
 469 (defclass protobuf-method (base-protobuf)
 470   ((itype :type (or null symbol)                ;the Lisp type name of the input
 471            :accessor proto-input-type
 472            :initarg :input-type
 473            :initform nil)
 474    (iname :type (or null string)                ;the Protobufs name of the input
 475           :accessor proto-input-name
 476           :initarg :input-name
 477           :initform nil)
 478    (otype :type (or null symbol)                ;the Lisp type name of the output
 479            :accessor proto-output-type
 480            :initarg :output-type
 481            :initform nil)
 482    (oname :type (or null string)                ;the Protobufs name of the output
 483           :accessor proto-output-name
 484           :initarg :output-name
 485           :initform nil))
 486   (:documentation
 487    "The model class that represents one method with a Protobufs service."))
 488
 489 (defmethod make-load-form ((m protobuf-method) &optional environment)
 490   (make-load-form-saving-slots m :environment environment))
 491
 492 (defmethod print-object ((m protobuf-method) stream)
 493   (print-unreadable-object (m stream :type t :identity t)
 494     (format stream "~S (~S) => (~S)"
 495             (proto-function m) (proto-input-type m) (proto-output-type m))))
 496
 497 ;; The 'class' slot really holds the name of the function,
 498 ;; so let's give it a better name
 499 (defmethod proto-function ((method protobuf-method))
 500   (proto-class method))
 501
 502 (defmethod (setf proto-function) (function (method protobuf-method))
 503   (setf (proto-function method) function))