1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protol buffers model classes
16 (defvar *all-protobufs* (make-hash-table :test #'equal)
17 "A table mapping names to 'protobuf' schemas.")
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*))
23 (defvar *all-messages* (make-hash-table)
24 "A table mapping Lisp class names to 'protobuf' messages.")
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*))
30 (defmethod find-message-for-class ((class class))
31 (gethash (class-name class) *all-messages*))
33 ;; A few things (the pretty printer) want to keep track of the current schema
34 (defvar *protobuf* nil)
35 (defvar *protobuf-package* nil)
40 (defclass abstract-protobuf () ())
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
47 (name :type (or null string) ;the Protobufs name for this enum, message, etc
51 (options :type (list-of protobuf-option) ;options, mostly just passed along
52 :accessor proto-options
55 (doc :type (or null string) ;documentation for this object
56 :accessor proto-documentation
57 :initarg :documentation
60 "The base class for all Protobufs model classes."))
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
69 (package :type (or null string) ;the Protobufs package
70 :accessor proto-package
73 (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...'
74 :accessor proto-lisp-package
75 :initarg :lisp-package
77 (imports :type (list-of string) ;any imports
78 :accessor proto-imports
81 (optimize :type (member nil :space :speed)
82 :accessor proto-optimize
85 (enums :type (list-of protobuf-enum) ;the set of enum types
89 (messages :type (list-of protobuf-message) ;the set of messages
90 :accessor proto-messages
93 (extenders :type (list-of protobuf-message) ;the set of extended messages
94 :accessor proto-extenders
97 (services :type (list-of protobuf-service)
98 :accessor proto-services
102 "The model class that represents a Protobufs schema, i.e., one .proto file."))
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
109 (setf (gethash class *all-protobufs*) protobuf))
111 (setf (gethash name *all-protobufs*) protobuf))))
113 (defmethod make-load-form ((p protobuf) &optional environment)
114 (make-load-form-saving-slots p :environment environment))
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))))
121 (defgeneric find-message (protobuf type)
123 "Given a protobuf schema or message and a type name or class name,
124 returns the protobuf message corresponding to the type."))
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)))
131 (defmethod find-message ((protobuf protobuf) (type class))
132 (find-message protobuf (class-name type)))
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=)))
138 (defgeneric find-enum (protobuf type)
140 "Given a protobuf schema or message and the name of an enum type,
141 returns the protobuf enum corresponding to the type."))
143 (defmethod find-enum ((protobuf protobuf) type)
144 (find type (proto-enums protobuf) :key #'proto-class))
146 (defmethod find-enum ((protobuf protobuf) (type string))
147 (find type (proto-enums protobuf) :key #'proto-name :test #'string=))
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
156 (value :type (or null string) ;the value
157 :accessor proto-value
161 "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
163 (defmethod make-load-form ((o protobuf-option) &optional environment)
164 (make-load-form-saving-slots o :environment environment))
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))))
170 (defmethod find-option ((protobuf base-protobuf) (name string))
171 (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'string=)))
172 (and option (proto-value option))))
174 (defmethod find-option ((options list) (name string))
175 (let ((option (find name options :key #'proto-name :test #'string=)))
176 (and option (proto-value option))))
179 ;; A protobuf enumeration
180 (defclass protobuf-enum (base-protobuf)
181 ((alias :type (or null symbol) ;use this if you want to make this enum
182 :accessor proto-alias-for ; be an alias for an existing Lisp enum
185 (values :type (list-of protobuf-enum-value) ;all the values for this enum type
186 :accessor proto-values
190 "The model class that represents a Protobufs enumeration type."))
192 (defmethod make-load-form ((e protobuf-enum) &optional environment)
193 (make-load-form-saving-slots e :environment environment))
195 (defmethod print-object ((e protobuf-enum) stream)
196 (print-unreadable-object (e stream :type t :identity t)
197 (format stream "~S~@[ (alias for ~S)~]"
198 (proto-class e) (proto-alias-for e))))
201 ;; A protobuf value within an enumeration
202 (defclass protobuf-enum-value (base-protobuf)
203 ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
204 :accessor proto-index ;the index of the enum value
206 (value :type (or null symbol)
207 :accessor proto-value ;the Lisp value of the enum
211 "The model class that represents a Protobufs enumeration value."))
213 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
214 (make-load-form-saving-slots v :environment environment))
216 (defmethod print-object ((v protobuf-enum-value) stream)
217 (print-unreadable-object (v stream :type t :identity t)
218 (format stream "~A = ~D"
219 (proto-name v) (proto-index v))))
222 ;; A protobuf message
223 (defclass protobuf-message (base-protobuf)
224 ((parent :type (or protobuf protobuf-message)
225 :accessor proto-parent
227 (conc :type (or null string) ;the conc-name used for Lisp accessors
228 :accessor proto-conc-name
231 (alias :type (or null symbol) ;use this if you want to make this message
232 :accessor proto-alias-for ; be an alias for an existing Lisp class
235 (enums :type (list-of protobuf-enum) ;the embedded enum types
236 :accessor proto-enums
239 (messages :type (list-of protobuf-message) ;the embedded messages
240 :accessor proto-messages
243 (extenders :type (list-of protobuf-message) ;the set of extended messages
244 :accessor proto-extenders
247 (fields :type (list-of protobuf-field) ;the fields
248 :accessor proto-fields
251 (extensions :type (list-of protobuf-extension) ;any extensions
252 :accessor proto-extensions
255 (extension-p :type (member t nil) ;true iff this message extends another message
256 :accessor proto-extension-p
257 :initarg :extension-p
260 "The model class that represents a Protobufs message."))
262 (defmethod initialize-instance :after ((message protobuf-message) &rest initargs)
263 (declare (ignore initargs))
264 ;; Record this message under just its Lisp class name
265 (with-slots (class extension-p) message
266 (when (and class (not extension-p))
267 (setf (gethash class *all-messages*) message))))
269 (defmethod make-load-form ((m protobuf-message) &optional environment)
270 (make-load-form-saving-slots m :environment environment))
272 (defmethod print-object ((m protobuf-message) stream)
273 (print-unreadable-object (m stream :type t :identity t)
274 (format stream "~S~@[ (alias for ~S)~]~@[ (extended~*)~]"
275 (proto-class m) (proto-alias-for m) (proto-extension-p m))))
277 (defmethod find-message ((message protobuf-message) (type symbol))
278 ;; Extended messages "shadow" non-extended ones
279 (or (find type (proto-extenders message) :key #'proto-class)
280 (find type (proto-messages message) :key #'proto-class)
281 (find-message (proto-parent message) type)))
283 (defmethod find-message ((message protobuf-message) (type class))
284 (find-message message (class-name type)))
286 (defmethod find-message ((message protobuf-message) (type string))
287 (or (find type (proto-extenders message) :key #'proto-name :test #'string=)
288 (find type (proto-messages message) :key #'proto-name :test #'string=)
289 (find-message (proto-parent message) type)))
291 (defmethod find-enum ((message protobuf-message) type)
292 (or (find type (proto-enums message) :key #'proto-class)
293 (find-enum (proto-parent message) type)))
295 (defmethod find-enum ((message protobuf-message) (type string))
296 (or (find type (proto-enums message) :key #'proto-name :test #'string=)
297 (find-enum (proto-parent message) type)))
300 ;; A protobuf field within a message
301 ;;---*** Support the 'deprecated' option (should serialization ignore such fields?)
302 (defclass protobuf-field (base-protobuf)
303 ((type :type string ;the name of the Protobuf type for the field
306 (required :type (member :required :optional :repeated)
307 :accessor proto-required
309 (index :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
310 :accessor proto-index
312 (value :type (or null symbol) ;the Lisp slot holding the value within an object
313 :accessor proto-value
316 (reader :type (or null symbol) ;a reader that is used to access the value
317 :accessor proto-reader ;if it's supplied, it's used instead of 'value'
320 (writer :type (or null symbol list) ;a writer that is used to set the value
321 :accessor proto-writer ;when it's a list, it's something like '(setf title)'
324 (default :type (or null string) ;default value, pulled out of the options
325 :accessor proto-default
328 (packed :type (member t nil) ;packed, pulled out of the options
329 :accessor proto-packed
332 (extension-p :type (member t nil) ;true iff this field is an extension
333 :accessor proto-extension-p
334 :initarg :extension-p
337 "The model class that represents one field within a Protobufs message."))
339 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
340 (declare (ignore initargs))
341 (when (slot-boundp field 'index)
342 (assert (not (<= 19000 (proto-index field) 19999)) ()
343 "Protobuf field indexes between 19000 and 19999 are not allowed")))
345 (defmethod make-load-form ((f protobuf-field) &optional environment)
346 (make-load-form-saving-slots f :environment environment))
348 (defmethod print-object ((f protobuf-field) stream)
349 (print-unreadable-object (f stream :type t :identity t)
350 (format stream "~S :: ~S = ~D~@[ (extended~*)~]"
351 (proto-value f) (proto-class f) (proto-index f) (proto-extension-p f))))
354 ;; An extension within a message
355 (defclass protobuf-extension (abstract-protobuf)
356 ((from :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
357 :accessor proto-extension-from
359 (to :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
360 :accessor proto-extension-to
363 "The model class that represents an extension with a Protobufs message."))
365 (defmethod make-load-form ((e protobuf-extension) &optional environment)
366 (make-load-form-saving-slots e :environment environment))
368 (defmethod print-object ((e protobuf-extension) stream)
369 (print-unreadable-object (e stream :type t :identity t)
370 (format stream "~D - ~D"
371 (proto-extension-from e) (proto-extension-from e))))
374 ;; A protobuf service
375 (defclass protobuf-service (base-protobuf)
376 ((methods :type (list-of protobuf-method) ;the methods in the service
377 :accessor proto-methods
381 "The model class that represents a Protobufs service."))
383 (defmethod make-load-form ((s protobuf-service) &optional environment)
384 (make-load-form-saving-slots s :environment environment))
386 (defmethod print-object ((s protobuf-service) stream)
387 (print-unreadable-object (s stream :type t :identity t)
392 ;; A protobuf method within a service
393 (defclass protobuf-method (base-protobuf)
394 ((itype :type (or null symbol) ;the Lisp type name of the input
395 :accessor proto-input-type
398 (iname :type (or null string) ;the Protobufs name of the input
399 :accessor proto-input-name
402 (otype :type (or null symbol) ;the Lisp type name of the output
403 :accessor proto-output-type
404 :initarg :output-type
406 (oname :type (or null string) ;the Protobufs name of the output
407 :accessor proto-output-name
408 :initarg :output-name
411 "The model class that represents one method with a Protobufs service."))
413 (defmethod make-load-form ((m protobuf-method) &optional environment)
414 (make-load-form-saving-slots m :environment environment))
416 (defmethod print-object ((m protobuf-method) stream)
417 (print-unreadable-object (m stream :type t :identity t)
418 (format stream "~S (~S) => (~S)"
419 (proto-function m) (proto-input-type m) (proto-output-type m))))
421 ;; The 'class' slot really holds the name of the function,
422 ;; so let's give it a better name
423 (defmethod proto-function ((method protobuf-method))
424 (proto-class method))
426 (defmethod (setf proto-function) (function (method protobuf-method))
427 (setf (proto-function method) function))
430 ;; Better type checking for these guys
433 (quux:declare-list-of protobuf-option)
434 (quux:declare-list-of protobuf-enum)
435 (quux:declare-list-of protobuf-enum-value)
436 (quux:declare-list-of protobuf-message)
437 (quux:declare-list-of protobuf-extension)
438 (quux:declare-list-of protobuf-field)
439 (quux:declare-list-of protobuf-service)
440 (quux:declare-list-of protobuf-method)