1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protobufs schema pretty printing
16 (defun write-schema (protobuf &rest keys
17 &key (stream *standard-output*) (type :proto) &allow-other-keys)
18 "Writes the object 'protobuf' (schema, message, enum, etc) onto the
19 stream 'stream' in the format given by 'type' (:proto, :text, etc)."
20 (let ((*protobuf* protobuf))
21 (apply #'write-schema-as type protobuf stream keys)))
23 (defgeneric write-schema-as (type protobuf stream &key indentation &allow-other-keys)
25 "Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
26 the given stream 'stream' in the format given by 'type' (:proto, :text, etc).
27 If 'more' is true, this means there are more enum values, fields, etc to
28 be written after the current one."))
30 (defgeneric write-schema-header (type schema stream)
32 "Writes a header for the schema onto the given stream 'stream'
33 in the format given by 'type' (:proto, :text, etc)."))
35 (defgeneric write-schema-documentation (type docstring stream &key indentation)
37 "Writes the docstring as a \"block comment\" onto the given stream 'stream'
38 in the format given by 'type' (:proto, :text, etc)."))
41 ;;; Pretty print a schema as a .proto file
43 (defmethod write-schema-as ((type (eql :proto)) (schema protobuf-schema) stream
45 (with-prefixed-accessors (documentation syntax package imports options) (proto- schema)
47 (write-schema-documentation type documentation stream :indentation indentation))
49 (format stream "~&syntax = \"~A\";~%~%" syntax))
51 (format stream "~&package ~A;~%~%" (substitute #\_ #\- package)))
53 (dolist (import imports)
54 (format stream "~&import \"~A\";~%" import))
56 (write-schema-header type schema stream)
58 (dolist (option options)
59 (format stream "~&option ~:/protobuf-option/;~%" option))
61 (loop for (enum . more) on (proto-enums schema) doing
62 (write-schema-as type enum stream :indentation indentation :more more)
64 (loop for (alias . more) on (proto-type-aliases schema) doing
65 (write-schema-as type alias stream :indentation indentation :more more)
67 (loop for (msg . more) on (proto-messages schema) doing
68 (write-schema-as type msg stream :indentation indentation :more more)
70 (loop for (svc . more) on (proto-services schema) doing
71 (write-schema-as type svc stream :indentation indentation :more more)
74 (defmethod write-schema-documentation ((type (eql :proto)) docstring stream
76 (let ((lines (split-string docstring :separators '(#\newline #\return))))
78 (format stream "~&~@[~VT~]// ~A~%"
79 (and (not (zerop indentation)) indentation) line))))
81 ;; Lisp was born in 1958 :-)
82 (defparameter *lisp-options* '(("lisp_package" string 195801)
83 ("lisp_name" string 195802)
84 ("lisp_alias" string 195803)
85 ("lisp_type" string 195804)
86 ("lisp_class" string 195805)
87 ("lisp_slot" string 195806)))
89 (defparameter *option-types* '(("ctype" symbol)
92 ("optimize_for" symbol)
95 ("stream_type" string)
96 ;; Keep the rest of these in alphabetical order
97 ("cc_api_version" integer)
98 ("cc_generic_services" symbol)
99 ("go_api_version" integer)
100 ("go_generic_services" symbol)
101 ("go_package" string)
102 ("java_api_version" integer)
103 ("java_generic_services" symbol)
104 ("java_java5_enums" boolean)
105 ("java_multiple_files" boolean)
106 ("java_outer_classname" string)
107 ("java_package" string)
108 ("java_use_javaproto2" boolean)
109 ("py_api_version" integer)
110 ("py_generic_services" symbol)))
112 (defmethod write-schema-header ((type (eql :proto)) (schema protobuf-schema) stream)
113 (when (any-lisp-option schema)
114 (format stream "~&import \"net/proto2/proto/descriptor.proto\";~%~%")
115 (format stream "~&extend proto2.MessageOptions {~%")
116 (loop for (option type index) in *lisp-options* doing
117 (format stream "~& optional ~(~A~) ~A = ~D;~%" type option index))
118 (format stream "~&}~%~%")))
120 (defgeneric any-lisp-option (schema)
122 "Returns true iff there is anything in the schema that would require that
123 the .proto file include and extend 'MessageOptions'.")
124 (:method ((schema protobuf-schema))
125 (labels ((find-one (protobuf)
126 (dolist (enum (proto-enums protobuf))
127 (with-prefixed-accessors (name class alias-for) (proto- enum)
129 (and class (not (string-equal name (class-name->proto class))) class))
130 (return-from any-lisp-option t))))
131 (dolist (msg (proto-messages protobuf))
132 (with-prefixed-accessors (name class alias-for) (proto- msg)
134 (and class (not (string-equal name (class-name->proto class))) class))
135 (return-from any-lisp-option t))))
136 (map () #'find-one (proto-messages protobuf))))
140 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
141 (let* ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
142 (proto-type option)))
143 (value (proto-value option)))
144 (cond (colon-p ;~:/protobuf-option/ -- .proto format
146 (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
148 ((symbol) "(~A)~@[ = ~A~]")
149 ((boolean) "(~A)~@[ = ~(~A~)~]")
151 (cond ((typep value 'standard-object)
152 ;; If the value is an instance of some class,
153 ;; then it must be some sort of complex option,
154 ;; so print the value using the text format
156 (with-output-to-string (s)
157 (print-text-format value nil
158 :stream s :print-name nil :suppress-line-breaks t)))
161 "(~A)~@[ = ~S~]")))))
164 ((symbol) "~A~@[ = ~A~]")
165 ((boolean) "~A~@[ = ~(~A~)~]")
167 (cond ((typep value 'standard-object)
169 (with-output-to-string (s)
170 (print-text-format value nil
171 :stream s :print-name nil :suppress-line-breaks t)))
173 (t "~A~@[ = ~S~]"))))))))
174 (format stream fmt-control (proto-name option) value)))
175 (atsign-p ;~@/protobuf-option/ -- string/value format
176 (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
177 (format stream fmt-control (proto-name option) value)))
178 (t ;~/protobuf-option/ -- keyword/value format
179 (let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S")))
180 (format stream fmt-control (proto-name option) value))))))
182 (defun cl-user::source-location (stream location colon-p atsign-p)
183 (declare (ignore colon-p atsign-p))
184 (format stream "(~S ~D ~D)"
185 (source-location-pathname location)
186 (source-location-start-pos location) (source-location-end-pos location)))
188 (defmethod write-schema-as ((type (eql :proto)) (enum protobuf-enum) stream
189 &key (indentation 0) more)
190 (declare (ignore more))
191 (with-prefixed-accessors (name class alias-for documentation options) (proto- enum)
193 (write-schema-documentation type documentation stream :indentation indentation))
194 (format stream "~&~@[~VT~]enum ~A {~%"
195 (and (not (zerop indentation)) indentation)
196 (maybe-qualified-name enum))
197 (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
199 (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
200 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
202 (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
203 (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
204 (dolist (option options)
205 (format stream "~&option ~:/protobuf-option/;~%" option))
206 (loop for (value . more) on (proto-values enum) doing
207 (write-schema-as type value stream :indentation (+ indentation 2) :more more))
208 (format stream "~&~@[~VT~]}~%"
209 (and (not (zerop indentation)) indentation))))
211 (defparameter *protobuf-enum-comment-column* 56)
212 (defmethod write-schema-as ((type (eql :proto)) (val protobuf-enum-value) stream
213 &key (indentation 0) more)
214 (declare (ignore more))
215 (with-prefixed-accessors (name documentation index) (proto- val)
216 (format stream "~&~@[~VT~]~A = ~D;~:[~2*~;~VT// ~A~]~%"
217 (and (not (zerop indentation)) indentation)
218 (maybe-qualified-name val) index
219 documentation *protobuf-enum-comment-column* documentation)))
221 (defmethod write-schema-as ((type (eql :proto)) (alias protobuf-type-alias) stream
222 &key (indentation 0) more)
223 (declare (ignore more))
224 (with-prefixed-accessors (name lisp-type proto-type) (proto- alias)
225 (let ((comment (format nil "Note: there is an alias ~A that maps Lisp ~(~S~) to Protobufs ~(~A~)"
226 name lisp-type proto-type)))
227 (write-schema-documentation type comment stream :indentation indentation))
228 (format stream "~&~@[~VT~]~%"
229 (and (not (zerop indentation)) indentation))))
231 (defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
232 &key (indentation 0) more index arity)
233 (declare (ignore more arity))
234 (let ((*protobuf* message))
235 (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
236 (cond ((eq message-type :group)
237 ;; If we've got a group, the printer for fields has already
238 ;; printed a partial line (nice modularity, huh?)
239 (format stream "group ~A = ~D {~%" name index)
240 (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
242 (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
243 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
245 (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
246 (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
247 (dolist (option options)
248 (format stream "~&~VToption ~:/protobuf-option/;~%"
249 (+ indentation 2) option))
250 (loop for (enum . more) on (proto-enums message) doing
251 (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
252 (loop for (field . more) on (proto-fields message) doing
253 (write-schema-as type field stream
254 :indentation (+ indentation 2) :more more :message message))
255 (format stream "~&~@[~VT~]}~%"
256 (and (not (zerop indentation)) indentation)))
259 (write-schema-documentation type documentation stream :indentation indentation))
260 (format stream "~&~@[~VT~]~A ~A {~%"
261 (and (not (zerop indentation)) indentation)
262 (if (eq message-type :message) "message" "extend")
263 (maybe-qualified-name message))
264 (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
266 (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
267 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
269 (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
270 (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
271 (dolist (option options)
272 (format stream "~&~VToption ~:/protobuf-option/;~%"
273 (+ indentation 2) option))
274 (cond ((eq message-type :extends)
275 (loop for (field . more) on (proto-extended-fields message) doing
276 (write-schema-as type field stream
277 :indentation (+ indentation 2) :more more
280 (loop for (enum . more) on (proto-enums message) doing
281 (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
282 (loop for (msg . more) on (proto-messages message) doing
283 (unless (eq (proto-message-type msg) :group)
284 (write-schema-as type msg stream :indentation (+ indentation 2) :more more)))
285 (loop for (field . more) on (proto-fields message) doing
286 (write-schema-as type field stream
287 :indentation (+ indentation 2) :more more
289 (loop for (extension . more) on (proto-extensions message) doing
290 (write-schema-as type extension stream :indentation (+ indentation 2) :more more))))
291 (format stream "~&~@[~VT~]}~%"
292 (and (not (zerop indentation)) indentation)))))))
294 (defun maybe-qualified-name (x &optional name)
295 "Given a message, return a fully qualified name if the short name
296 is not sufficient to name the message in the current scope."
298 ((or protobuf-message protobuf-enum protobuf-enum-value
300 (cond ((string= (make-qualified-name (proto-parent x) (proto-name x))
301 (proto-qualified-name x))
304 (proto-qualified-name x))))
307 (defparameter *protobuf-field-comment-column* 56)
308 (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream
309 &key (indentation 0) more message)
310 (declare (ignore more))
311 (with-prefixed-accessors (name documentation required type index packed options) (proto- field)
312 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
313 (msg (and (not (keywordp class))
314 (or (find-message message class)
315 (find-enum message class)
316 (find-type-alias message class)))))
317 (cond ((and (typep msg 'protobuf-message)
318 (eq (proto-message-type msg) :group))
319 (format stream "~&~@[~VT~]~(~A~) "
320 (and (not (zerop indentation)) indentation) required)
321 (write-schema-as :proto msg stream :indentation indentation :index index :arity required))
323 (let* ((defaultp (if (proto-alias-for message)
324 ;; Special handling for imported CLOS classes
325 (if (eq (proto-required field) :optional)
327 (and (proto-default field)
328 (not (equalp (proto-default field) #()))
329 (not (empty-default-p field))))
330 (not (empty-default-p field))))
331 (default (proto-default field))
332 (default (and defaultp
333 (cond ((and (typep msg 'protobuf-enum)
334 (or (stringp default) (symbolp default)))
335 (let ((e (find default (proto-values msg)
336 :key #'proto-name :test #'string=)))
337 (and e (proto-name e))))
339 (if (boolean-true-p default) "true" "false"))
341 (default (and defaultp
342 (if (stringp default) (escape-string default) default))))
343 (if (typep msg 'protobuf-type-alias)
344 (format stream "~&~@[~VT~]~(~A~) ~(~A~) ~A = ~D~
345 ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
346 ~:[~2*~;~VT// ~A~]~%"
347 (and (not (zerop indentation)) indentation)
348 required (proto-proto-type msg) name index
349 defaultp default packed options
350 t *protobuf-field-comment-column*
351 (format nil "alias maps Lisp ~(~S~) to Protobufs ~(~A~)"
352 (proto-lisp-type msg) (proto-proto-type msg)))
353 (format stream (if (and (keywordp class) (not (eq class :bool)))
354 ;; Keyword class means a primitive type, print default with ~S
355 "~&~@[~VT~]~(~A~) ~A ~A = ~D~
356 ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
357 ~:[~2*~;~VT// ~A~]~%"
358 ;; Non-keyword class means an enum type, print default with ~A"
359 "~&~@[~VT~]~(~A~) ~A ~A = ~D~
360 ~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
361 ~:[~2*~;~VT// ~A~]~%")
362 (and (not (zerop indentation)) indentation)
363 required (maybe-qualified-name msg type) name index
364 defaultp default packed options
365 documentation *protobuf-field-comment-column* documentation))))))))
367 (defun escape-string (string)
368 (if (every #'(lambda (ch) (and (standard-char-p ch) (graphic-char-p ch))) string)
370 (with-output-to-string (s)
371 (loop for ch across string
372 as esc = (escape-char ch)
373 do (format s "~A" esc)))))
375 (defmethod write-schema-as ((type (eql :proto)) (extension protobuf-extension) stream
376 &key (indentation 0) more)
377 (declare (ignore more))
378 (with-prefixed-accessors (from to) (proto-extension- extension)
379 (format stream "~&~@[~VT~]extensions ~D~:[~*~; to ~D~];~%"
380 (and (not (zerop indentation)) indentation)
381 from (not (eql from to)) (if (eql to #.(1- (ash 1 29))) "max" to))))
383 (defmethod write-schema-as ((type (eql :proto)) (service protobuf-service) stream
384 &key (indentation 0) more)
385 (declare (ignore more))
386 (with-prefixed-accessors (name documentation) (proto- service)
388 (write-schema-documentation type documentation stream :indentation indentation))
389 (format stream "~&~@[~VT~]service ~A {~%"
390 (and (not (zerop indentation)) indentation) name)
391 (loop for (method . more) on (proto-methods service) doing
392 (write-schema-as type method stream :indentation (+ indentation 2) :more more))
393 (format stream "~&~@[~VT~]}~%"
394 (and (not (zerop indentation)) indentation))))
396 (defmethod write-schema-as ((type (eql :proto)) (method protobuf-method) stream
397 &key (indentation 0) more)
398 (declare (ignore more))
399 (with-prefixed-accessors
400 (name documentation input-name output-name streams-name options) (proto- method)
401 (let* ((imsg (find-message *protobuf* input-name))
402 (omsg (find-message *protobuf* output-name))
403 (smsg (find-message *protobuf* streams-name))
404 (iname (maybe-qualified-name imsg))
405 (oname (maybe-qualified-name omsg))
406 (sname (maybe-qualified-name smsg)))
408 (write-schema-documentation type documentation stream :indentation indentation))
409 (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ streams (~A)~]~@[ returns (~A)~]"
410 (and (not (zerop indentation)) indentation)
411 name iname sname oname)
413 (format stream " {~%")
414 (dolist (option options)
415 (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
416 (+ indentation 2) option))
417 (format stream "~@[~VT~]}"
418 (and (not (zerop indentation)) indentation)))
420 (format stream ";~%"))))))
423 ;;; Pretty print a schema as a .lisp file
425 (defvar *show-lisp-enum-indexes* t)
426 (defvar *show-lisp-field-indexes* t)
427 (defvar *use-common-lisp-package* nil)
429 (defmethod write-schema-as ((type (eql :lisp)) (schema protobuf-schema) stream
431 (show-field-indexes *show-lisp-field-indexes*)
432 (show-enum-indexes *show-lisp-enum-indexes*)
433 (use-common-lisp *use-common-lisp-package*))
434 (with-prefixed-accessors (name class documentation package lisp-package imports) (proto- schema)
435 (let* ((optimize (let ((opt (find-option schema "optimize_for")))
436 (and opt (cond ((string= opt "SPEED") :speed)
437 ((string= opt "CODE_SIZE") :space)
439 (options (remove-if #'(lambda (x) (string= (proto-name x) "optimize_for"))
440 (proto-options schema)))
441 (pkg (and package (if (stringp package) package (string package))))
442 (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
443 (rpc-pkg (and (or lisp-pkg pkg)
444 (format nil "~A-~A" (or lisp-pkg pkg) 'rpc)))
445 (*show-lisp-enum-indexes* show-enum-indexes)
446 (*show-lisp-field-indexes* show-field-indexes)
447 (*use-common-lisp-package* use-common-lisp)
448 (*protobuf-package* (find-proto-package lisp-pkg))
449 (*protobuf-rpc-package* (find-proto-package rpc-pkg))
450 ;; If *protobuf-package* has not been defined, print symbols
451 ;; from :common-lisp if *use-common-lisp-package* is true; or
452 ;; :keyword otherwise. This ensures that all symbols will be
453 ;; read back correctly.
454 ;; (The :keyword package does not use any other packages, so
455 ;; all symbols will be printed with package prefixes.
456 ;; Keywords are always printed as :keyword.)
457 (*package* (or *protobuf-package*
458 (when *use-common-lisp-package* (find-package :common-lisp))
459 (find-package :keyword)))
460 (exports (collect-exports schema)))
462 (let* ((pkg (string-upcase rpc-pkg))
463 (rpc-exports (remove-if-not
466 (package-name (symbol-package sym))
469 (*package* (or *protobuf-rpc-package*
470 (when *use-common-lisp-package* (find-package :common-lisp))
471 (find-package :keyword))))
473 (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
474 ~% (cl:unless (cl:find-package \"~A\")~
475 ~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
476 ~%(cl:in-package \"~A\")~
477 ~%(cl:export '(~{~A~^~% ~}))~%~%"
478 pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
480 (when (or lisp-pkg pkg)
481 (let ((pkg (string-upcase (or lisp-pkg pkg))))
482 (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
483 ~% (cl:unless (cl:find-package \"~A\")~
484 ~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
485 ~%(cl:in-package \"~A\")~
486 ~%(cl:export '(~{~A~^~% ~}))~%~%"
487 pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
491 (package-name (symbol-package sym))
495 (write-schema-documentation type documentation stream :indentation indentation))
496 (format stream "~&(proto:define-schema ~(~A~)" (or class name))
497 (if (or pkg lisp-pkg imports optimize options documentation)
498 (format stream "~% (")
499 (format stream " ("))
502 (format stream "~A:package \"~A\"" spaces pkg)
503 (when (or lisp-pkg imports optimize options documentation)
507 (format stream "~A:lisp-package \"~A\"" spaces lisp-pkg)
508 (when (or imports optimize options documentation)
512 (cond ((= (length imports) 1)
513 (format stream "~A:import \"~A\"" spaces (car imports)))
515 (format stream "~A:import (~{\"~A\"~^ ~})" spaces imports)))
516 (when (or optimize options documentation)
520 (format stream "~A:optimize ~(~S~)" spaces optimize)
521 (when (or options documentation)
525 (format stream "~A:options (~{~/protobuf-option/~^ ~})" spaces options)
530 (format stream "~A:documentation ~S" spaces documentation)))
532 (loop for (enum . more) on (proto-enums schema) doing
533 (write-schema-as type enum stream :indentation 2 :more more))
534 (loop for (alias . more) on (proto-type-aliases schema) doing
535 (write-schema-as type alias stream :indentation 2 :more more))
536 (loop for (msg . more) on (proto-messages schema) doing
537 (write-schema-as type msg stream :indentation 2 :more more))
538 (loop for (svc . more) on (proto-services schema) doing
539 (write-schema-as type svc stream :indentation 2 :more more)))
540 (format stream ")~%")))
542 (defmethod write-schema-documentation ((type (eql :lisp)) docstring stream
543 &key (indentation 0))
544 (let ((lines (split-string docstring :separators '(#\newline #\return))))
546 (format stream "~&~@[~VT~];; ~A~%"
547 (and (not (zerop indentation)) indentation) line))))
549 (defmethod write-schema-header ((type (eql :lisp)) (schema protobuf-schema) stream)
550 (declare (ignorable type stream))
553 (defmethod write-schema-as ((type (eql :lisp)) (enum protobuf-enum) stream
554 &key (indentation 0) more)
555 (declare (ignore more))
557 (with-prefixed-accessors (name class alias-for
558 documentation source-location) (proto- enum)
560 (write-schema-documentation type documentation stream :indentation indentation))
561 (format stream "~@[~VT~](proto:define-enum ~(~S~)"
562 (and (not (zerop indentation)) indentation) class)
563 (let ((other (and name (string/= name (class-name->proto class)) name)))
564 (cond ((or other alias-for documentation source-location)
565 (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
566 ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
567 ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
568 ~:[~*~;:source-location ~/source-location/~])"
570 other other (and (or alias-for documentation source-location) (+ indentation 5))
571 alias-for alias-for (and (or documentation source-location) (+ indentation 5))
572 documentation documentation (and source-location (+ indentation 5))
573 source-location source-location))
575 (format stream " ()"))))
576 (loop for (value . more) on (proto-values enum) doing
577 (write-schema-as type value stream :indentation (+ indentation 2) :more more)
580 (format stream ")")))
582 (defmethod write-schema-as ((type (eql :lisp)) (val protobuf-enum-value) stream
583 &key (indentation 0) more)
584 (declare (ignore more))
585 (with-prefixed-accessors (value index) (proto- val)
586 (if *show-lisp-enum-indexes*
587 (format stream "~&~@[~VT~](~(~A~) ~D)"
588 (and (not (zerop indentation)) indentation) value index)
589 (format stream "~&~@[~VT~]~(~A~)"
590 (and (not (zerop indentation)) indentation) value))))
592 (defmethod write-schema-as ((type (eql :lisp)) (alias protobuf-type-alias) stream
593 &key (indentation 0) more)
594 (declare (ignore more))
596 (with-prefixed-accessors (class lisp-type proto-type serializer deserializer) (proto- alias)
597 (format stream "~@[~VT~](proto:define-type-alias ~(~S~)"
598 (and (not (zerop indentation)) indentation) class)
599 (format stream " ()") ;no options yet
600 (format stream "~%~@[~VT~]:lisp-type ~(~S~)~
601 ~%~@[~VT~]:proto-type ~(~A~)~
602 ~%~@[~VT~]:serializer ~(~S~)~
603 ~%~@[~VT~]:deserializer ~(~S~))"
604 (+ indentation 2) lisp-type
605 (+ indentation 2) proto-type
606 (+ indentation 2) serializer
607 (+ indentation 2) deserializer)))
609 (defmethod write-schema-as ((type (eql :lisp)) (message protobuf-message) stream
610 &key (indentation 0) more index arity)
611 (declare (ignore more))
612 (let ((*protobuf* message))
613 (with-prefixed-accessors (name class alias-for conc-name message-type
614 documentation source-location) (proto- message)
615 (cond ((eq message-type :group)
617 (write-schema-documentation type documentation stream :indentation indentation))
618 (format stream "~&~@[~VT~](proto:define-group ~(~S~)"
619 (and (not (zerop indentation)) indentation) class)
620 (let ((other (and name (string/= name (class-name->proto class)) name)))
621 (format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
622 :arity ~(~S~)~@[~%~VT~]~
623 ~:[~2*~;:name ~S~@[~%~VT~]~]~
624 ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
625 ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
626 ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
627 ~:[~*~;:source-location ~/source-location/~])"
629 index (+ indentation 5)
630 arity (and (or other alias-for conc-name documentation source-location) (+ indentation 5))
631 other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
632 alias-for alias-for (and (or conc-name documentation source-location) (+ indentation 5))
633 conc-name conc-name (and (or documentation source-location) (+ indentation 5))
634 documentation documentation (and source-location (+ indentation 5))
635 source-location source-location))
636 (loop for (enum . more) on (proto-enums message) doing
637 (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
640 (loop for (field . more) on (proto-fields message) doing
641 (write-schema-as type field stream
642 :indentation (+ indentation 2) :more more
648 (write-schema-documentation type documentation stream :indentation indentation))
649 (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
650 (and (not (zerop indentation)) indentation)
651 (if (eq message-type :message) "message" "extend") class)
652 (let ((other (and name (string/= name (class-name->proto class)) name)))
653 (cond ((eq message-type :extends)
654 (format stream " ()"))
655 ((or other alias-for conc-name documentation source-location)
656 (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
657 ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
658 ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
659 ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
660 ~:[~*~;:source-location ~/source-location/~])"
662 other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
663 alias-for alias-for (and (or conc-name documentation source-location) (+ indentation 5))
664 conc-name conc-name (and (or documentation source-location) (+ indentation 5))
665 documentation documentation (and source-location (+ indentation 5))
666 source-location source-location))
668 (format stream " ()"))))
669 (cond ((eq message-type :extends)
670 (loop for (field . more) on (proto-extended-fields message) doing
671 (write-schema-as type field stream
672 :indentation (+ indentation 2) :more more
677 (loop for (enum . more) on (proto-enums message) doing
678 (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
681 (loop for (msg . more) on (proto-messages message) doing
682 (unless (eq (proto-message-type msg) :group)
683 (write-schema-as type msg stream :indentation (+ indentation 2) :more more)
686 (loop for (field . more) on (proto-fields message) doing
687 (write-schema-as type field stream
688 :indentation (+ indentation 2) :more more
692 (loop for (extension . more) on (proto-extensions message) doing
693 (write-schema-as type extension stream :indentation (+ indentation 2) :more more)
695 (terpri stream)))))))
696 (format stream ")"))))
698 (defparameter *protobuf-slot-comment-column* 56)
699 (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream
700 &key (indentation 0) more message)
701 (with-prefixed-accessors (value required index packed options documentation) (proto- field)
702 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
703 (msg (and (not (keywordp class))
704 (or (find-message message class)
705 (find-enum message class)
706 (find-type-alias message class))))
707 (type (let ((cl (case class
714 ((:fixed32) 'fixed32)
715 ((:fixed64) 'fixed64)
716 ((:sfixed32) 'sfixed32)
717 ((:sfixed64) 'sfixed64)
719 ((:double) 'double-float)
722 ((:bytes) 'byte-vector)
725 (cond ((eq required :optional)
727 ((eq required :repeated)
728 (if (vector-field-p field)
732 (cond ((and (typep msg 'protobuf-message)
733 (eq (proto-message-type msg) :group))
734 (write-schema-as :lisp msg stream :indentation indentation :index index :arity required))
736 (let* ((defaultp (if (proto-alias-for message)
737 (if (eq (proto-required field) :optional)
739 (and (proto-default field)
740 (not (equalp (proto-default field) #()))
741 (not (empty-default-p field))))
742 (not (empty-default-p field))))
743 (default (proto-default field))
744 (default (and defaultp
745 (cond ((and (typep msg 'protobuf-enum)
746 (or (stringp default) (symbolp default)))
747 (let ((e (find default (proto-values msg)
748 :key #'proto-name :test #'string=)))
749 (and e (proto-value e))))
751 (boolean-true-p default))
753 (default (and defaultp
754 (if (stringp default) (escape-string default) default)))
755 (conc-name (proto-conc-name message))
756 (reader (when (and (not (eq (proto-reader field) value))
757 (not (string-equal (proto-reader field)
758 (format nil "~A~A" conc-name value))))
759 (proto-reader field)))
760 (writer (when (and (not (eq (proto-writer field) value))
761 (not (string-equal (proto-writer field)
762 (format nil "~A~A" conc-name value))))
763 (proto-writer field)))
764 (slot-name (if *show-lisp-field-indexes*
765 (format nil "(~(~S~) ~D)" value index)
766 (format nil "~(~S~)" value))))
767 (format stream (if (and (keywordp class) (not (eq class :bool)))
768 ;; Keyword class means a primitive type, print default with ~S
769 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
770 ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
771 ~@[ :options (~{~/protobuf-option/~^ ~})~])~
773 ;; Non-keyword class means an enum type, print default with ~(~S~)
774 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
775 ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
776 ~@[ :options (~{~/protobuf-option/~^ ~})~])~
778 (and (not (zerop indentation)) indentation)
779 slot-name type defaultp default reader writer packed options
780 ;; Don't write the comment if we'll insert a close paren after it
781 (and more documentation) *protobuf-slot-comment-column* documentation)))))))
783 (defmethod write-schema-as ((type (eql :lisp)) (extension protobuf-extension) stream
784 &key (indentation 0) more)
785 (declare (ignore more))
786 (with-prefixed-accessors (from to) (proto-extension- extension)
787 (format stream "~&~@[~VT~](proto:define-extension ~D ~D)"
788 (and (not (zerop indentation)) indentation)
789 from (if (eql to #.(1- (ash 1 29))) "max" to))))
791 (defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
792 &key (indentation 0) more)
793 (declare (ignore more))
794 (with-prefixed-accessors (class documentation name source-location) (proto- service)
796 (write-schema-documentation type documentation stream :indentation indentation))
797 (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
798 (and (not (zerop indentation)) indentation) (proto-class service))
799 (let ((other (and name (string/= name (class-name->proto (proto-class service))) name)))
800 (cond ((or documentation other source-location)
801 (format stream "~%~@[~VT~](~:[~2*~;:documentation ~S~@[~%~VT~]~]~
802 ~:[~2*~;:name ~S~@[~%~VT~]~]~
803 ~:[~*~;:source-location ~/source-location/~])"
805 documentation documentation (and (or documentation source-location) (+ indentation 5))
806 other other (and source-location (+ indentation 5))
807 source-location source-location))
809 (format stream " ()"))))
810 (loop for (method . more) on (proto-methods service) doing
811 (write-schema-as type method stream :indentation (+ indentation 2) :more more)
814 (format stream ")")))
816 (defmethod write-schema-as ((type (eql :lisp)) (method protobuf-method) stream
817 &key (indentation 0) more)
818 (declare (ignore more))
819 (with-prefixed-accessors (class input-type output-type streams-type
820 name input-name output-name streams-name
821 options documentation source-location) (proto- method)
823 (write-schema-documentation type documentation stream :indentation indentation))
824 (format stream "~&~@[~VT~](~(~S~) (" (and (not (zerop indentation)) indentation) class)
825 (if (and input-name (string/= (class-name->proto input-type) input-name))
826 (format stream "(~(~S~) :name ~S) => " input-type input-name)
827 (format stream "~(~S~) => " input-type))
828 (if (and output-name (string/= (class-name->proto output-type) output-name))
829 (format stream "(~(~S~) :name ~S)" output-type output-name)
830 (format stream "~(~S~)" output-type))
832 (if (and streams-name (string/= (class-name->proto streams-type) streams-name))
833 (format stream " :streams (~(~S~) :name ~S)" streams-type streams-name)
834 (format stream " :streams ~(~S~)" streams-type)))
836 (when (and name (string/= (class-name->proto name) name))
837 (format stream "~%~VT:name ~S"
838 (+ indentation 2) name))
840 (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
841 (+ indentation 2) options))
842 (format stream ")")))
845 ;;; Collect symbols to be exported
847 (defgeneric collect-exports (schema)
849 "Collect all the symbols that should be exported from a Protobufs package"))
851 (defmethod collect-exports ((schema protobuf-schema))
854 (append (mapcan #'collect-exports (proto-enums schema))
855 (mapcan #'collect-exports (proto-messages schema))
856 (mapcan #'collect-exports (proto-services schema))))
859 ;; Export just the type name
860 (defmethod collect-exports ((enum protobuf-enum))
861 (list (proto-class enum)))
863 ;; Export the class name and all of the accessor names
864 (defmethod collect-exports ((message protobuf-message))
865 (append (list (proto-class message))
866 (mapcan #'collect-exports (proto-messages message))
867 (mapcan #'collect-exports (proto-fields message))))
869 ;; Export just the slot accessor name
870 (defmethod collect-exports ((field protobuf-field))
871 (list (or (proto-reader field)
872 (proto-slot field))))
874 ;; Export the names of all the methods
875 (defmethod collect-exports ((service protobuf-service))
876 (mapcan #'collect-exports (proto-methods service)))
878 ;; Export just the method name
879 (defmethod collect-exports ((method protobuf-method))
880 (list (proto-client-stub method) (proto-server-stub method)))