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