1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protocol buffer generation from ordinary CLOS classes
16 ;; Controls whether or not to use ':alias-for' for the Protobuf generated
17 ;; for an existing Lisp class
18 ;; The default is presently true because, at least initially, we'll be using
19 ;; the generated Protobufs code in the Lisp world that includes that classes
20 ;; from which the code was generated
21 (defvar *alias-existing-classes* t)
23 ;; Doing this can't really work perfectly, there's not enough information
24 ;; - How do we decide if there's an ownership hierarchy that should produce embedded messages?
25 ;; - How do we decide if there are volatile slots that should not be included in the message?
26 (defun write-schema-for-classes (classes
27 &key (stream *standard-output*) (type :proto)
28 name package lisp-package install
29 slot-filter type-filter enum-filter value-filter
30 (alias-existing-classes *alias-existing-classes*))
31 "Given a set of CLOS classes, generates a Protobufs schema for the classes
32 and pretty prints the schema to the stream.
33 The return value is the schema."
34 (let ((schema (generate-schema-for-classes classes
37 :lisp-package (or lisp-package package)
39 :slot-filter slot-filter
40 :type-filter type-filter
41 :enum-filter enum-filter
42 :value-filter value-filter
43 :alias-existing-classes alias-existing-classes)))
45 (write-schema schema :stream stream :type type)
49 (defun generate-schema-for-classes (classes
50 &key name package lisp-package install
51 slot-filter type-filter enum-filter value-filter
52 (alias-existing-classes *alias-existing-classes*))
53 "Given a set of CLOS classes, generates a Protobufs schema for the classes.
54 The return value is the schema."
55 (let* ((*alias-existing-classes* alias-existing-classes)
56 (package (and package (if (stringp package) package (string-downcase (string package)))))
57 (lisp-pkg (string (or lisp-package package)))
58 (schema (make-instance 'protobuf-schema
61 :lisp-package lisp-pkg
64 (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
65 (messages (mapcar #'(lambda (c)
66 (class-to-protobuf-message c schema
67 :slot-filter slot-filter
68 :type-filter type-filter
69 :enum-filter enum-filter
70 :value-filter value-filter))
72 (setf (proto-messages schema) messages)
74 (record-protobuf schema)
75 (with-collectors ((messages collect-message))
76 (labels ((collect-messages (message)
77 (collect-message message)
78 (map () #'collect-messages (proto-messages message))))
79 (map () #'collect-messages (proto-messages schema)))
80 (map () #'record-protobuf messages)))
84 (defun class-to-protobuf-message (class schema
85 &key slot-filter type-filter enum-filter value-filter)
86 "Given a CLOS class, return a Protobufs model object for it."
87 (let* ((class (let ((c (find-class class)))
88 (unless (class-finalized-p c)
89 (finalize-inheritance c)) ;so the rest of the MOP will work
91 (slots (class-slots class)))
92 (with-collectors ((enums collect-enum)
94 (fields collect-field))
97 (multiple-value-bind (field msg enum)
98 (slot-to-protobuf-field class s index slots
99 :slot-filter slot-filter
100 :type-filter type-filter
101 :enum-filter enum-filter
102 :value-filter value-filter)
108 (incf index 1) ;don't worry about the 19000-19999 restriction
109 (collect-field field))))
110 (let* ((cname (class-name class))
111 (pname (class-name->proto cname))
113 ;;--- Making the message this late means its children won't
114 ;;--- have the right qualified names
115 (make-instance 'protobuf-message
118 :qualified-name (make-qualified-name *protobuf* pname)
120 :alias-for (and *alias-existing-classes* cname)
121 :enums (delete-duplicates enums :key #'proto-name :test #'string=)
122 :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
124 (*protobuf* message))
125 ;; Give every child a proper parent
126 (dolist (enum (proto-enums message))
127 (setf (proto-parent enum) message))
128 (dolist (msg (proto-messages message))
129 (setf (proto-parent msg) message))
130 (dolist (field (proto-fields message))
131 (setf (proto-parent field) message))
134 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
135 (defun slot-to-protobuf-field (class slot index slots
136 &key slot-filter type-filter enum-filter value-filter)
137 "Given a CLOS slot, return a Protobufs model object for it."
138 (when (or (null slot-filter)
139 (funcall slot-filter slot slots))
140 (multiple-value-bind (expanded-type unexpanded-type)
141 (find-slot-definition-type class slot)
142 (multiple-value-bind (type pclass packed enums)
143 (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
144 (multiple-value-bind (reqd vectorp)
145 (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter)
146 (let* ((ename (and enums
147 (if (and unexpanded-type (symbolp unexpanded-type))
148 (symbol-name unexpanded-type)
149 (format nil "~A-~A" 'enum (slot-definition-name slot)))))
151 (if (and unexpanded-type (symbolp unexpanded-type))
153 (intern ename (symbol-package (slot-definition-name slot))))))
155 (let* ((names (mapcar #'enum-name->proto enums))
156 (prefix (and (> (length names) 1)
157 (subseq (first names)
158 0 (mismatch (first names) (car (last names)))))))
159 (when (and prefix (> (length prefix) 2)
160 (every #'(lambda (name) (starts-with name prefix)) names))
161 (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
162 (unless (and unexpanded-type (symbolp unexpanded-type))
163 #+ignore ;this happens constantly, the warning is not useful
164 (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
166 (let* ((pname (class-name->proto ename))
168 (make-instance 'protobuf-enum
171 :qualified-name (make-qualified-name *protobuf* pname)
174 (loop for name in names
177 collect (make-instance 'protobuf-enum-value
179 :qualified-name (make-qualified-name enum name)
183 (setf (proto-values enum) values)
185 (default (if (slot-definition-initfunction slot)
186 (clos-init-to-protobuf-default
187 (slot-definition-initform slot) expanded-type value-filter)
188 (if (eq reqd :repeated)
189 (if vectorp $empty-vector $empty-list)
191 (field (make-instance 'protobuf-field
192 :name (slot-name->proto (slot-definition-name slot))
193 :type (if enum (class-name->proto ename) type)
194 :class (if enum etype pclass)
197 :value (slot-definition-name slot)
198 :reader (let ((reader (find-slot-definition-reader class slot)))
199 ;; Only use the reader if it is "interesting"
200 (unless (string= (symbol-name reader)
202 (class-name class) (slot-definition-name slot)))
206 (values field nil enum)))))))
208 (defun list-of-list-of ()
209 (let ((list-of-package (find-package 'list-of)))
210 (and list-of-package (find-symbol (string 'list-of) list-of-package))))
212 (defun find-slot-definition-type (class slotd)
213 "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
214 (let* ((slot-name (slot-definition-name slotd))
215 (direct-slotd (some #'(lambda (c)
216 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
217 (class-precedence-list class))))
219 ;; The direct slotd will have an unexpanded definition
220 ;; Prefer it for 'list-of' so we can get the base type
221 (let ((type (slot-definition-type direct-slotd)))
222 (values (if (and (listp type)
223 (or (member (car type) '(list-of vector-of))
224 (let ((list-of-list-of (list-of-list-of)))
225 (and list-of-list-of (eq (car type) list-of-list-of)))))
227 (slot-definition-type slotd))
230 (when (and (listp type)
232 (member 'null (cdr type)))
233 (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
234 (values (slot-definition-type slotd) nil))))
236 (defun find-slot-definition-reader (class slotd)
237 "Given a class and a slot descriptor, find the name of a reader method for the slot."
238 (let* ((slot-name (slot-definition-name slotd))
239 (direct-slotd (some #'(lambda (c)
240 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
241 (class-precedence-list class))))
242 (and direct-slotd (first (slot-definition-readers direct-slotd)))))
244 (defun satisfies-list-of-p (type)
246 (eq (car type) 'satisfies)
249 (let ((function (cadr type)))
250 (and (symbolp function)
251 (string= "LIST-OF" (package-name (symbol-package function)))
252 (let ((name (symbol-name function)))
253 (and (<= #.(length "LIST-OF-_-P") (length name))
254 (starts-with name "LIST-OF-")
255 (ends-with name "-P")
256 (let* ((typestring (subseq name #.(length "LIST-OF-") (- (length name) 2)))
258 (with-standard-io-syntax
259 (let ((*package* (find-package :cl)))
260 (read-from-string typestring))))))
261 (and (typep type 'symbol) type))))))))
263 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
264 "Given a Lisp type, returns a Protobuf type, a class or primitive type,
265 whether or not to pack the field, and (optionally) a set of enum values."
266 (let* ((type (if type-filter (funcall type-filter type) type))
267 (list-of-list-of (list-of-list-of))
268 (type-enum (when (and *protobuf* (symbolp type))
269 (find-enum *protobuf* type)))
270 (type-alias (when (and *protobuf* (symbolp type))
271 (find-type-alias *protobuf* type)))
272 (expanded-type (type-expand type)))
275 (destructuring-bind (head &rest tail) type
278 (when (or (> (length tail) 2)
279 (not (member 'null tail)))
280 (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
281 (if (eq (first tail) 'null)
282 (clos-type-to-protobuf-type (second tail))
283 (clos-type-to-protobuf-type (first tail))))
285 ;; Special knowledge of 'list-of:list-of', which uses (and list (satisfies list-of::FOO-p))
286 (let ((satisfies-list-of
287 (and list-of-list-of (find-if #'satisfies-list-of-p tail))))
288 (if satisfies-list-of
289 (multiple-value-bind (type class)
290 (lisp-type-to-protobuf-type satisfies-list-of)
291 (values type class (packed-type-p class)))
293 (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
294 (when (> (length new-tail) 1)
295 (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
296 (lisp-type-to-protobuf-type (first tail))))))
297 ((member) ;maybe generate an enum type
298 (if (or (equal type '(member t nil))
299 (equal type '(member nil t)))
300 (values "bool" :bool)
301 (let ((values (if enum-filter (funcall enum-filter tail) tail)))
302 (cond ((every #'(lambda (x)
303 (or (null x) (characterp x) (stringp x))) values)
304 (values "string" :string))
305 ((every #'(lambda (x)
306 (or (null x) (and (integerp x) (>= x 0)))) values)
307 (values "uint32" :uint32))
308 ((every #'(lambda (x)
309 (or (null x) (integerp x))) values)
310 (values "int32" :int32))
311 ((every #'(lambda (x) (symbolp x)) values)
312 (let ((values (remove-if #'null values)))
313 (values (class-name->proto (format nil "~A" type))
315 nil ;don't pack enums
316 (if enum-filter (funcall enum-filter values) values))))
318 (error "The MEMBER type ~S is too complicated" type))))))
320 (multiple-value-bind (type class)
321 (lisp-type-to-protobuf-type (first tail))
322 (values type class (packed-type-p class))))
324 (let ((lo (or (first tail) '*))
325 (hi (or (second tail) '*)))
326 (if (or (eq lo '*) (< lo 0))
328 (values "int64" :int64)
329 (if (<= (integer-length hi) 32)
330 (values "int32" :int32)
331 (values "int64" :int64)))
333 (values "uint64" :uint64)
334 (if (<= (integer-length hi) 32)
335 (values "uint32" :uint32)
336 (values "uint64" :uint64))))))
338 (let ((len (first tail)))
340 (values "int32" :int32)
341 (values "int64" :int64))))
343 (let ((len (first tail)))
345 (values "uint32" :uint32)
346 (values "uint64" :uint64))))
347 ((float single-float double-float)
348 (lisp-type-to-protobuf-type head))
350 (if (eq head list-of-list-of)
351 (multiple-value-bind (type class)
352 (lisp-type-to-protobuf-type (first tail))
353 (values type class (packed-type-p class)))
354 (lisp-type-to-protobuf-type type))))))
356 (values (proto-proto-type-str type-alias) type))
357 ((not (or type-enum (equal type expanded-type)))
358 (clos-type-to-protobuf-type expanded-type))
360 (lisp-type-to-protobuf-type type)))))
362 (defun lisp-type-to-protobuf-type (type)
364 ((int32) (values "int32" :int32))
365 ((int64) (values "int64" :int64))
366 ((uint32) (values "uint32" :uint32))
367 ((uint64) (values "uint64" :uint64))
368 ((sint32) (values "sint32" :sint32))
369 ((sint64) (values "sint64" :sint64))
370 ((fixed32) (values "fixed32" :fixed32))
371 ((fixed64) (values "fixed64" :fixed64))
372 ((sfixed32) (values "sfixed32" :sfixed32))
373 ((sfixed64) (values "sfixed64" :sfixed64))
374 ((integer) (values "int64" :int64))
375 ((single-float float)
376 (values "float" :float))
378 (values "double" :double))
380 (values "bool" :bool))
382 (values "string" :symbol))
384 (cond ((ignore-errors
385 (or (eql type 'symbol)
386 (subtypep type '(or string character))))
387 (values "string" :string))
389 (subtypep type 'byte-vector))
390 (values "bytes" :bytes))
392 (values (class-name->proto type) type))))))
394 (defun packed-type-p (type)
395 "Returns true if the given Protobufs type can use a packed field."
396 (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
397 :fixed32 :fixed64 :sfixed32 :sfixed64
398 :bool :float :double)))))
400 (defun clos-type-to-protobuf-required (type &optional type-filter)
401 "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
402 If the sceond returned value is true, it's a repeated field that should use a vector."
403 (let ((type (if type-filter (funcall type-filter type) type))
404 (list-of-list-of (list-of-list-of)))
406 (destructuring-bind (head &rest tail) type
409 (let ((optional (member 'null tail))
410 (repeated (find-if #'(lambda (r)
411 (eq (clos-type-to-protobuf-required r) :repeated)) tail)))
413 (clos-type-to-protobuf-required repeated)
414 (values (if optional :optional :required) nil))))
416 (cond ((and (subtypep type 'list)
417 (not (subtypep type 'null)))
418 (values :repeated nil))
419 ((subtypep type '(vector-of t))
420 (values :repeated t))
422 (values :required nil))))
424 (if (or (equal type '(member t nil))
425 (equal type '(member nil t)))
426 (values :required nil)
427 (values (if (member nil tail) :optional :required) nil)))
429 (values :repeated nil))
431 (values :repeated t))
433 (if (eq head list-of-list-of)
434 (values :repeated nil)
435 (values :required nil)))))
436 (values :required nil))))
438 (defun clos-init-to-protobuf-default (value type &optional value-filter)
439 "Given an initform and a Lisp type, returns a plausible default value.
440 Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
441 (let ((value (if value-filter (funcall value-filter value) value)))
442 (and (constantp value)
443 (ignore-errors (typep value type))
446 (defun protobuf-default-to-clos-init (default type)
447 "Given a Protobufs type and default, return a CLOS initform value.
448 Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
449 (cond ((ignore-errors (typep default type))
452 (cond ((eq type :bool)
453 (boolean-true-p default))
454 ;; If we've got a symbol, it must be to initialize an enum type
455 ;; whose values are represented by keywords in Lisp
456 (t (kintern (symbol-name default)))))
458 (cond ((eq type :bool)
459 (boolean-true-p default))
460 ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
461 :fixed32 :sfixed32 :fixed64 :sfixed64))
462 (let ((default (read-from-string default)))
463 (and (integerp default) default)))
464 ((member type '(:float :double))
465 (let ((default (read-from-string default)))
466 (and (floatp default) default)))
469 (defun boolean-true-p (x)
470 "Returns t or nil given a value that might be a boolean."
473 (integer (not (eql x 0)))
474 (character (char-equal x #\t))
475 (string (or (string-equal x "true")
476 (string-equal x "yes")
478 (string-equal x "1")))
479 (symbol (string-equal (string x) "true"))))