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 ;;; Protocol buffer generation from ordinary CLOS classes
16 ;; Doing this can't really work perfectly, there's not enough information
17 ;; - How do we decide if there's an ownership hierarchy that should produce embedded messages?
18 ;; - How do we decide if there are volatile slots that should not be included in the message?
19 (defun write-protobuf-schema-for-classes (classes
20 &key (stream *standard-output*) (type :proto)
21 name package lisp-package
22 slot-filter type-filter enum-filter value-filter)
23 "Given a set of CLOS classes, generates a Protobufs schema for the classes
24 and pretty prints the schema to the stream.
25 The return value is the schema."
26 (let ((protobuf (generate-protobuf-schema-for-classes classes
29 :lisp-package (or lisp-package package)
30 :slot-filter slot-filter
31 :type-filter type-filter
32 :enum-filter enum-filter
33 :value-filter value-filter)))
35 (write-protobuf protobuf :stream stream :type type)
39 (defun generate-protobuf-schema-for-classes (classes
40 &key name package lisp-package
41 slot-filter type-filter enum-filter value-filter)
42 "Given a set of CLOS classes, generates a Protobufs schema for the classes.
43 The return value is the schema."
44 (let* ((package (and package (if (stringp package) package (string-downcase (string package)))))
45 (lisp-pkg (string (or lisp-package package)))
46 (protobuf (make-instance 'protobuf
49 :lisp-package lisp-pkg
51 (messages (mapcar #'(lambda (c)
52 (class-to-protobuf-message c protobuf
53 :slot-filter slot-filter
54 :type-filter type-filter
55 :enum-filter enum-filter
56 :value-filter value-filter))
58 (setf (proto-messages protobuf) messages)
62 ;; Controls whether or not to use ':alias-for' for the generated Protobuf
63 ;; Bind this to 'true' when you plan to use the generated Protobufs code in
64 ;; a Lisp world that includes that classes from which the code was generated
65 (defvar *alias-existing-classes* nil)
67 (defun class-to-protobuf-message (class protobuf
68 &key slot-filter type-filter enum-filter value-filter)
69 (let* ((class (find-class class))
70 (slots (class-slots class)))
71 (with-collectors ((enums collect-enum)
73 (fields collect-field))
76 (multiple-value-bind (field msg enum)
77 (slot-to-protobuf-field class s index slots
78 :slot-filter slot-filter
79 :type-filter type-filter
80 :enum-filter enum-filter
81 :value-filter value-filter)
87 (incf index 1) ;don't worry about the 19000-19999 restriction
88 (collect-field field))))
89 (make-instance 'protobuf-message
90 :class (class-name class)
91 :name (class-name->proto (class-name class))
93 :alias-for (and *alias-existing-classes* (class-name class))
94 :enums (delete-duplicates enums :key #'proto-name :test #'string=)
95 :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
98 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
99 (defun slot-to-protobuf-field (class slot index slots
100 &key slot-filter type-filter enum-filter value-filter)
101 (when (or (null slot-filter)
102 (funcall slot-filter slot slots))
103 (multiple-value-bind (expanded-type unexpanded-type)
104 (find-slot-definition-type class slot)
105 (multiple-value-bind (type pclass packed enums)
106 (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
107 (let* ((ename (and enums
108 (if (and unexpanded-type (symbolp unexpanded-type))
109 (symbol-name unexpanded-type)
110 (format nil "~A-~A" 'enum (slot-definition-name slot)))))
112 (if (and unexpanded-type (symbolp unexpanded-type))
114 (intern ename (symbol-package (slot-definition-name slot))))))
116 (let* ((names (mapcar #'enum-name->proto enums))
117 (prefix (and (> (length names) 1)
118 (subseq (first names)
119 0 (mismatch (first names) (car (last names)))))))
120 (when (and prefix (> (length prefix) 2)
121 (every #'(lambda (name) (starts-with name prefix)) names))
122 (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
123 (unless (and unexpanded-type (symbolp unexpanded-type))
124 (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S" type))
125 (make-instance 'protobuf-enum
127 :name (class-name->proto ename)
128 :values (loop for name in names
131 collect (make-instance 'protobuf-enum-value
135 (reqd (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter))
136 (field (make-instance 'protobuf-field
137 :name (slot-name->proto (slot-definition-name slot))
138 :type (if enum (class-name->proto ename) type)
139 :class (if enum etype pclass)
142 :value (slot-definition-name slot)
143 :reader (let ((reader (find-slot-definition-reader class slot)))
144 ;; Only use the reader if it is "interesting"
145 (unless (string= (symbol-name reader)
147 (class-name class) (slot-definition-name slot)))
149 :default (clos-init-to-protobuf-default (slot-definition-initform slot) value-filter)
151 (values field nil enum))))))
153 ;; Given a class and a slot descriptor, find the "best" type definition for the slot
154 (defun find-slot-definition-type (class slotd)
155 (let* ((slot-name (slot-definition-name slotd))
156 (direct-slotd (some #'(lambda (c)
157 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
158 (class-precedence-list class))))
160 ;; The direct slotd will have an unexpanded definition
161 ;; Prefer it for 'list-of' so we can get the base type
162 (let ((type (slot-definition-type direct-slotd)))
163 (values (if (and (listp type) (member (car type) '(list-of #+quux quux:list-of)))
165 (slot-definition-type slotd))
168 (when (and (listp type)
170 (member 'null (cdr type)))
171 (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
172 (values (slot-definition-type slotd) nil))))
174 ;; Given a class and a slot descriptor, find the name of a reader method for the slot
175 (defun find-slot-definition-reader (class slotd)
176 (let* ((slot-name (slot-definition-name slotd))
177 (direct-slotd (some #'(lambda (c)
178 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
179 (class-precedence-list class))))
180 (and direct-slotd (first (slot-definition-readers direct-slotd)))))
182 ;; Returns Protobuf type, a class or primitive type, whether or not to pack the field,
183 ;; and (optionally) a set of enum values
184 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
185 (let ((type (if type-filter (funcall type-filter type) type)))
186 (flet ((type->protobuf-type (type)
189 (values "bool" :bool))
191 (values "int64" :int64))
193 (values "float" :float))
195 (values "double" :double))
197 (values "string" :symbol))
200 (subtypep type '(or string character)))
201 (values "string" :string)
202 (values (class-name->proto type) type))))))
204 (destructuring-bind (head &rest tail) type
207 (when (or (> (length tail) 2)
208 (not (member 'null tail)))
209 (protobufs-warn "Can't handle the complicated OR type ~S" type))
210 (if (eq (first tail) 'null)
211 (clos-type-to-protobuf-type (second tail))
212 (clos-type-to-protobuf-type (first tail))))
215 ((subtypep type '(quux:list-of t))
216 ;; Special knowledge of Quux 'list-of', which uses (and list (satisfies <t>))
217 (let* ((satisfies (find 'satisfies tail :key #'car))
218 (pred (second satisfies))
219 (type (if (starts-with (string pred) "LIST-OF-")
220 (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
222 (multiple-value-bind (type class)
223 (type->protobuf-type type)
224 (values type class (packed-type-p class)))))
226 (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
227 (assert (= (length new-tail) 1) ()
228 "Can't handle the complicated AND type ~S" type)
229 (type->protobuf-type (first tail))))))
230 ((member) ;maybe generate an enum type
231 (if (or (equal type '(member t nil))
232 (equal type '(member nil t)))
233 (values "bool" :bool)
234 (let ((values (if enum-filter (funcall enum-filter tail) tail)))
235 (cond ((every #'(lambda (x)
236 (or (null x) (characterp x) (stringp x))) values)
237 (values "string" :string))
238 ((every #'(lambda (x)
239 (or (null x) (and (integerp x) (>= x 0)))) values)
240 (values "uint32" :uint32))
241 ((every #'(lambda (x)
242 (or (null x) (integerp x))) values)
243 (values "int32" :int32))
245 (let ((values (remove-if #'null values)))
246 (values (class-name->proto type)
248 nil ;don't pack enums
249 (if enum-filter (funcall enum-filter values) values))))))))
250 ((list-of #+quux quux:list-of) ;special knowledge of 'list-of'
251 (multiple-value-bind (type class)
252 (type->protobuf-type (first tail))
253 (values type class (packed-type-p class))))
255 (let ((lo (or (first tail) '*))
256 (hi (or (second tail) '*)))
257 (if (or (eq lo '*) (< lo 0))
259 (values "int64" :int64)
260 (if (<= (integer-length hi) 32)
261 (values "int32" :int32)
262 (values "int64" :int64)))
264 (values "uint64" :uint64)
265 (if (<= (integer-length hi) 32)
266 (values "uint32" :uint32)
267 (values "uint64" :uint64))))))
269 (let ((len (first tail)))
271 (values "int32" :int32)
272 (values "int64" :int64))))
274 (let ((len (first tail)))
276 (values "uint32" :uint32)
277 (values "uint64" :uint64))))
278 ((float double-float)
279 (type->protobuf-type head))
281 (if (subtypep head '(or string character))
282 (values "string" :string)
283 (error "Don't know how to translate the type ~S" head)))))
284 (type->protobuf-type type)))))
286 (defun packed-type-p (class)
287 (not (null (member class '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
288 :fixed32 :fixed64 :sfixed32 :sfixed64
291 (defun clos-type-to-protobuf-required (type &optional type-filter)
292 (let ((type (if type-filter (funcall type-filter type) type)))
294 (destructuring-bind (head &rest tail) type
297 (let ((optional (member 'null (cdr type))))
298 (if (loop for r in tail
299 thereis (eq (clos-type-to-protobuf-required r) :repeated))
301 (if optional :optional :required))))
303 (if (or (subtypep type '(list-of t))
304 #+quux (subtypep type '(quux:list-of t)))
308 (if (or (equal type '(member t nil))
309 (equal type '(member nil t)))
311 (if (member nil tail) :optional :required)))
312 ((list-of #+quux quux:list-of)
318 (defun clos-init-to-protobuf-default (value &optional value-filter)
319 (let ((value (if value-filter (funcall value-filter value) value)))
320 (and value (constantp value)
321 (format nil "~A" value))))
323 (defun protobuf-default-to-clos-init (default type)
324 (cond ((or (null default)
325 (and (stringp default) (i= (length default) 0)))
327 ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
328 :fixed32 :sfixed32 :fixed64 :sfixed64
330 (read-from-string default))
332 (if (string= default "true") t nil))