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 ;; A few things (the pretty printer) want to keep track of the current schema
  24 (defvar *protobuf* nil)
  25 (defvar *protobuf-package* nil)
  26
  27
  28 ;;; The model classes
  29
  30 (defclass abstract-protobuf () ())
  31
  32 (defclass base-protobuf (abstract-protobuf)
  33   ((name :type (or null string)                 ;the name of this .proto file/enum/message, etc
  34          :reader proto-name
  35          :initarg :name
  36          :initform nil)
  37    (class :type (or null symbol)                ;a Lisp "class name" for this object
  38           :accessor proto-class
  39           :initarg :class
  40           :initform nil)
  41    (options :type (list-of protobuf-option)     ;options, mostly just passed along
  42             :accessor proto-options
  43             :initarg :options
  44             :initform ())
  45    (doc :type (or null string)                  ;documentation for this object
  46         :accessor proto-documentation
  47         :initarg :documentation
  48         :initform nil))
  49   (:documentation
  50    "The base class for all Protobufs model classes."))
  51
  52
  53 ;; The protobuf, corresponds to one .proto file
  54 (defclass protobuf (base-protobuf)
  55   ((syntax :type (or null string)               ;syntax, passed on but otherwise ignored
  56            :accessor proto-syntax
  57            :initarg :syntax
  58            :initform "proto2")
  59    (package :type (or null string)              ;the package
  60             :accessor proto-package
  61             :initarg :package
  62             :initform nil)
  63    ;;---*** We need to support 'import' properly
  64    (imports :type (list-of string)              ;any imports
  65             :accessor proto-imports
  66             :initarg :imports
  67             :initform ())
  68    (optimize :type (member nil :space :speed)
  69              :accessor proto-optimize
  70              :initarg :optimize
  71              :initform nil)
  72    (enums :type (list-of protobuf-enum)         ;the set of enum types
  73           :accessor proto-enums
  74           :initarg :enums
  75           :initform ())
  76    (messages :type (list-of protobuf-message)   ;the set of messages
  77              :accessor proto-messages
  78              :initarg :messages
  79              :initform ())
  80    (services :type (list-of protobuf-service)
  81              :accessor proto-services
  82              :initarg :services
  83              :initform ()))
  84   (:documentation
  85    "The model class that represents a Protobufs schema, i.e., one .proto file."))
  86
  87 (defmethod print-object ((p protobuf) stream)
  88   (print-unprintable-object (p stream :type t :identity t)
  89     (format stream "~@[~A~]~@[ (package ~A)~]"
  90             (proto-name p) (proto-package p))))
  91
  92 (defgeneric find-message-for-class (protobuf class)
  93   (:documentation
  94    "Given a protobuf schema or message and a class or class name,
  95     returns the protobuf message corresponding to the class."))
  96
  97 (defgeneric find-enum-for-type (protobuf type)
  98   (:documentation
  99    "Given a protobuf schema or message and the name of an enum type,
 100     returns the protobuf enum corresponding to the type."))
 101
 102 (defmethod find-message-for-class ((protobuf protobuf) (class symbol))
 103   (or (find class (proto-messages protobuf) :key #'proto-class)
 104       (find class (proto-messages protobuf) :key #'proto-class-override)
 105       (some #'(lambda (msg) (find-message-for-class msg class)) (proto-messages protobuf))))
 106
 107 (defmethod find-message-for-class ((protobuf protobuf) (class class))
 108   (find-message-for-class protobuf (class-name class)))
 109
 110 (defmethod find-message-for-class ((protobuf protobuf) (class string))
 111   (or (find class (proto-messages protobuf) :key #'proto-name :test #'string=)
 112       (some #'(lambda (msg) (find-message-for-class msg class)) (proto-messages protobuf))))
 113
 114 (defmethod find-enum-for-type ((protobuf protobuf) type)
 115   (or (find type (proto-enums protobuf) :key #'proto-class)
 116       (find type (proto-enums protobuf) :key #'proto-class-override)
 117       (some #'(lambda (msg) (find-enum-for-type msg type)) (proto-messages protobuf))))
 118
 119 (defmethod find-enum-for-type ((protobuf protobuf) (type string))
 120   (or (find type (proto-enums protobuf) :key #'proto-name :test #'string=)
 121       (some #'(lambda (msg) (find-enum-for-type msg type)) (proto-messages protobuf))))
 122
 123
 124 ;;--- For now, we support only the built-in options
 125 ;;--- We will want to extend this to customizable options as well
 126 (defclass protobuf-option (abstract-protobuf)
 127   ((name :type string                           ;the key
 128          :reader proto-name
 129          :initarg :name)
 130    (value :type (or null string)                ;the value
 131           :accessor proto-value
 132           :initarg :value
 133           :initform nil))
 134   (:documentation
 135    "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
 136
 137 (defmethod print-object ((o protobuf-option) stream)
 138   (print-unprintable-object (o stream :type t :identity t)
 139     (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
 140
 141 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
 142   (cond (colon-p                                ;~:/protobuf-option/ -- .proto format
 143          (format stream "~A~@[ = ~S~]" (proto-name option) (proto-value option)))
 144         (atsign-p                               ;~@/protobuf-option/ -- .lisp format
 145          (format stream "~S ~S" (proto-name option) (proto-value option)))
 146         (t                                      ;~/protobuf-option/  -- keyword/value format
 147          (format stream "~(:~A~) ~S" (proto-name option) (proto-value option)))))
 148
 149
 150 ;; A protobuf enumeration
 151 (defclass protobuf-enum (base-protobuf)
 152   ((class-override :type (or null symbol)       ;use this if you want to "overlay" an existing class
 153                    :accessor proto-class-override
 154                    :initarg :class-override
 155                    :initform nil)
 156    (values :type (list-of protobuf-enum-value)  ;all the values for this enum type
 157            :accessor proto-values
 158            :initarg :values
 159            :initform ()))
 160   (:documentation
 161    "The model class that represents a Protobufs enumeration type."))
 162
 163 (defmethod print-object ((e protobuf-enum) stream)
 164   (print-unprintable-object (e stream :type t :identity t)
 165     (format stream "~A~@[ (~S)~]"
 166             (proto-name e) (or (proto-class-override e) (proto-class e)))))
 167
 168
 169 ;; A protobuf value within an enumeration
 170 (defclass protobuf-enum-value (base-protobuf)
 171   ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
 172           :accessor proto-index                 ;the index of the enum value
 173           :initarg :index)
 174    (value :type (or null symbol)
 175           :accessor proto-value                 ;the Lisp value of the enum
 176           :initarg :value
 177           :initform nil))
 178   (:documentation
 179    "The model class that represents a Protobufs enumeration value."))
 180
 181 (defmethod print-object ((v protobuf-enum-value) stream)
 182   (print-unprintable-object (v stream :type t :identity t)
 183     (format stream "~A = ~D~@[ (~S)~]"
 184             (proto-name v) (proto-index v) (proto-value v))))
 185
 186
 187 ;; A protobuf message
 188 (defclass protobuf-message (base-protobuf)
 189   ((conc :type (or null string)                 ;the conc-name used for Lisp accessors
 190          :accessor proto-conc-name
 191          :initarg :conc-name
 192          :initform nil)
 193    (class-override :type (or null symbol)       ;use this if you want to "overlay" an existing class
 194                    :accessor proto-class-override
 195                    :initarg :class-override
 196                    :initform nil)
 197    (enums :type (list-of protobuf-enum)         ;the embedded enum types
 198           :accessor proto-enums
 199           :initarg :enums
 200           :initform ())
 201    (messages :type (list-of protobuf-message)   ;the embedded messages
 202              :accessor proto-messages
 203              :initarg :messages
 204              :initform ())
 205    (fields :type (list-of protobuf-field)       ;the fields
 206            :accessor proto-fields
 207            :initarg :fields
 208            :initform ())
 209    (extensions :type (list-of protobuf-extension) ;any extensions
 210                :accessor proto-extensions
 211                :initarg :extensions
 212                :initform ()))
 213     (:documentation
 214    "The model class that represents a Protobufs message."))
 215
 216 (defmethod print-object ((m protobuf-message) stream)
 217   (print-unprintable-object (m stream :type t :identity t)
 218     (format stream "~A~@[ (~S)~]"
 219             (proto-name m) (or (proto-class-override m) (proto-class m)))))
 220
 221 (defmethod find-message-for-class ((message protobuf-message) (class symbol))
 222   (or (find class (proto-messages message) :key #'proto-class)
 223       (find class (proto-messages message) :key #'proto-class-override)))
 224
 225 (defmethod find-message-for-class ((message protobuf-message) (class class))
 226   (find-message-for-class message (class-name class)))
 227
 228 (defmethod find-message-for-class ((message protobuf-message) (class string))
 229   (find class (proto-messages message) :key #'proto-name :test #'string=))
 230
 231 (defmethod find-enum-for-type ((message protobuf-message) type)
 232   (or (find type (proto-enums message) :key #'proto-class)
 233       (find type (proto-enums message) :key #'proto-class-override)))
 234
 235 (defmethod find-enum-for-type ((message protobuf-message) (type string))
 236   (find type (proto-enums message) :key #'proto-name :test #'string=))
 237
 238
 239 ;; A protobuf field within a message
 240 ;;--- Support the 'deprecated' option (should serialization ignore such fields?)
 241 (defclass protobuf-field (base-protobuf)
 242   ((type :type string                           ;the name of the Protobuf type for the field
 243          :accessor proto-type
 244          :initarg :type)
 245    (required :type (member :required :optional :repeated)
 246              :accessor proto-required
 247              :initarg :required)
 248    (index :type (integer 1 #.(1- (ash 1 29)))   ;the index number for this field
 249           :accessor proto-index
 250           :initarg :index)
 251    (value :type (or null symbol)                ;the Lisp slot holding the value within an object
 252           :accessor proto-value
 253           :initarg :value
 254           :initform nil)
 255    (reader :type (or null symbol)               ;a reader that is used to access the value
 256            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
 257            :initarg :reader
 258            :initform nil)
 259    (default :type (or null string)              ;default value, pulled out of the options
 260             :accessor proto-default
 261             :initarg :default
 262             :initform nil)
 263    (packed :type (member t nil)                 ;packed, pulled out of the options
 264            :accessor proto-packed
 265            :initarg :packed
 266            :initform nil))
 267   (:documentation
 268    "The model class that represents one field within a Protobufs message."))
 269
 270 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
 271   (declare (ignore initargs))
 272   (when (slot-boundp field 'index)
 273     (assert (not (<= 19000 (proto-index field) 19999)) ()
 274             "Protobuf field indexes between 19000 and 19999 are not allowed")))
 275
 276 (defmethod print-object ((f protobuf-field) stream)
 277   (print-unprintable-object (f stream :type t :identity t)
 278     (format stream "~A ~A~:[~*~*~; (~S~@[ :: ~S~])~] = ~D"
 279             (proto-type f) (proto-name f)
 280             (or (proto-value f) (proto-class f)) (proto-value f) (proto-class f)
 281             (proto-index f))))
 282
 283
 284 ;; An extension within a message
 285 ;;---*** We need to support 'extends', which depends on supporting 'import'
 286 (defclass protobuf-extension (abstract-protobuf)
 287   ((from :type (integer 1 #.(1- (ash 1 29)))    ;the index number for this field
 288          :accessor proto-extension-from
 289          :initarg :from)
 290    (to :type (integer 1 #.(1- (ash 1 29)))      ;the index number for this field
 291        :accessor proto-extension-to
 292        :initarg :to))
 293   (:documentation
 294    "The model class that represents an extension with a Protobufs message."))
 295
 296 (defmethod print-object ((e protobuf-extension) stream)
 297   (print-unprintable-object (e stream :type t :identity t)
 298     (format stream "~D - ~D"
 299             (proto-extension-from e) (proto-extension-from e))))
 300
 301
 302 ;; A protobuf service
 303 (defclass protobuf-service (base-protobuf)
 304   ((rpcs :type (list-of protobuf-rpc)           ;the RPCs in the service
 305          :accessor proto-rpcs
 306          :initarg :rpcs
 307          :initform ()))
 308   (:documentation
 309    "The model class that represents a Protobufs service."))
 310
 311 (defmethod print-object ((s protobuf-service) stream)
 312   (print-unprintable-object (s stream :type t :identity t)
 313     (format stream "~A"
 314             (proto-name s))))
 315
 316
 317 ;; A protobuf RPC within a service
 318 (defclass protobuf-rpc (base-protobuf)
 319   ((itype :type (or null string)                ;the name of the input message type
 320           :accessor proto-input-type
 321           :initarg :input-type
 322           :initform nil)
 323    (iclass :type (or null symbol)               ;the name of the input message Lisp class
 324            :accessor proto-input-class
 325            :initarg :input-class
 326            :initform nil)
 327    (otype :type (or null string)                ;the name of the output message type
 328           :accessor proto-output-type
 329           :initarg :output-type
 330           :initform nil)
 331    (oclass :type (or null symbol)               ;the name of the output message Lisp class
 332            :accessor proto-output-class
 333            :initarg :output-class
 334            :initform nil))
 335   (:documentation
 336    "The model class that represents one RPC with a Protobufs service."))
 337
 338 (defmethod print-object ((r protobuf-rpc) stream)
 339   (print-unprintable-object (r stream :type t :identity t)
 340     (format stream "~A (~@[~A~]) => (~@[~A~])"
 341             (or (proto-function r) (proto-name r))
 342             (or (proto-input-class r)  (proto-input-type r))
 343             (or (proto-output-class r) (proto-output-type r)))))
 344
 345 ;; The 'class' slot really holds the name of the function,
 346 ;; so let's give it a better name
 347 (defmethod proto-function ((rpc protobuf-rpc))
 348   (proto-class rpc))
 349
 350 (defmethod (setf proto-function) (function (rpc protobuf-rpc))
 351   (setf (proto-function rpc) function))