;;; ;;;
;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
(defun write-schema (protobuf &rest keys
&key (stream *standard-output*) (type :proto) &allow-other-keys)
"Writes the object 'protobuf' (schema, message, enum, etc) onto the
- stream 'stream'in the format given by 'type' (:proto, :text, etc)."
+ stream 'stream' in the format given by 'type' (:proto, :text, etc)."
(let ((*protobuf* protobuf))
(apply #'write-schema-as type protobuf stream keys)))
(and (not (zerop indentation)) indentation) line))))
;; Lisp was born in 1958 :-)
-(defvar *lisp-options* '(("lisp_package" string 195801)
- ("lisp_name" string 195802)
- ("lisp_alias" string 195803)
- ("lisp_type" string 195804)
- ("lisp_class" string 195805)
- ("lisp_slot" string 195806)))
-
-(defvar *option-types* '(("ctype" symbol)
- ("deadline" float)
- ("deprecated" symbol)
- ("optimize_for" symbol)
- ("packed" boolean)
- ("protocol" symbol)
- ("stream_type" string)
- ;; Keep the rest of these in alphabetical order
- ("cc_api_version" integer)
- ("cc_generic_services" symbol)
- ("go_api_version" integer)
- ("go_generic_services" symbol)
- ("go_package" string)
- ("java_api_version" integer)
- ("java_generic_services" symbol)
- ("java_java5_enums" boolean)
- ("java_multiple_files" boolean)
- ("java_outer_classname" string)
- ("java_package" string)
- ("java_use_javaproto2" boolean)
- ("py_api_version" integer)
- ("py_generic_services" symbol)))
+(defparameter *lisp-options* '(("lisp_package" string 195801)
+ ("lisp_name" string 195802)
+ ("lisp_alias" string 195803)
+ ("lisp_type" string 195804)
+ ("lisp_class" string 195805)
+ ("lisp_slot" string 195806)))
+
+(defparameter *option-types* '(("allow_alias" boolean)
+ ("ctype" symbol)
+ ("deadline" float)
+ ("deprecated" symbol)
+ ("optimize_for" symbol)
+ ("packed" boolean)
+ ("protocol" symbol)
+ ("stream_type" string)
+ ;; Keep the rest of these in alphabetical order
+ ("cc_api_version" integer)
+ ("cc_generic_services" symbol)
+ ("go_api_version" integer)
+ ("go_generic_services" symbol)
+ ("go_package" string)
+ ("java_api_version" integer)
+ ("java_generic_services" symbol)
+ ("java_java5_enums" boolean)
+ ("java_multiple_files" boolean)
+ ("java_outer_classname" string)
+ ("java_package" string)
+ ("java_use_javaproto2" boolean)
+ ("py_api_version" integer)
+ ("py_generic_services" symbol)))
(defmethod write-schema-header ((type (eql :proto)) (schema protobuf-schema) stream)
(when (any-lisp-option schema)
&key (indentation 0) more)
(declare (ignore more))
(with-prefixed-accessors (name documentation index) (proto- val)
- (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
+ (format stream "~&~@[~VT~]~A = ~D;~:[~2*~;~VT// ~A~]~%"
(and (not (zerop indentation)) indentation)
(maybe-qualified-name val) index
documentation *protobuf-enum-comment-column* documentation)))
(if (typep msg 'protobuf-type-alias)
(format stream "~&~@[~VT~]~(~A~) ~(~A~) ~A = ~D~
~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
- ~:[~*~*~;~VT// ~A~]~%"
+ ~:[~2*~;~VT// ~A~]~%"
(and (not (zerop indentation)) indentation)
required (proto-proto-type msg) name index
defaultp default packed options
;; Keyword class means a primitive type, print default with ~S
"~&~@[~VT~]~(~A~) ~A ~A = ~D~
~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
- ~:[~*~*~;~VT// ~A~]~%"
+ ~:[~2*~;~VT// ~A~]~%"
;; Non-keyword class means an enum type, print default with ~A"
"~&~@[~VT~]~(~A~) ~A ~A = ~D~
~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
- ~:[~*~*~;~VT// ~A~]~%")
+ ~:[~2*~;~VT// ~A~]~%")
(and (not (zerop indentation)) indentation)
required (maybe-qualified-name msg type) name index
defaultp default packed options
;;; Pretty print a schema as a .lisp file
-(defvar *show-lisp-enum-indexes* t)
+(defvar *show-lisp-enum-indexes* t)
(defvar *show-lisp-field-indexes* t)
+(defvar *use-common-lisp-package* nil)
(defmethod write-schema-as ((type (eql :lisp)) (schema protobuf-schema) stream
&key (indentation 0)
(show-field-indexes *show-lisp-field-indexes*)
- (show-enum-indexes *show-lisp-enum-indexes*))
+ (show-enum-indexes *show-lisp-enum-indexes*)
+ (use-common-lisp *use-common-lisp-package*))
(with-prefixed-accessors (name class documentation package lisp-package imports) (proto- schema)
(let* ((optimize (let ((opt (find-option schema "optimize_for")))
(and opt (cond ((string= opt "SPEED") :speed)
(proto-options schema)))
(pkg (and package (if (stringp package) package (string package))))
(lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
- (*show-lisp-enum-indexes* show-enum-indexes)
+ (rpc-pkg (and (or lisp-pkg pkg)
+ (format nil "~A-~A" (or lisp-pkg pkg) 'rpc)))
+ (*show-lisp-enum-indexes* show-enum-indexes)
(*show-lisp-field-indexes* show-field-indexes)
- (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
- (*package* *protobuf-package*))
+ (*use-common-lisp-package* use-common-lisp)
+ (*protobuf-package* (find-proto-package lisp-pkg))
+ (*protobuf-rpc-package* (find-proto-package rpc-pkg))
+ ;; If *protobuf-package* has not been defined, print symbols
+ ;; from :common-lisp if *use-common-lisp-package* is true; or
+ ;; :keyword otherwise. This ensures that all symbols will be
+ ;; read back correctly.
+ ;; (The :keyword package does not use any other packages, so
+ ;; all symbols will be printed with package prefixes.
+ ;; Keywords are always printed as :keyword.)
+ (*package* (or *protobuf-package*
+ (when *use-common-lisp-package* (find-package :common-lisp))
+ (find-package :keyword)))
+ (exports (collect-exports schema)))
+ (when rpc-pkg
+ (let* ((pkg (string-upcase rpc-pkg))
+ (rpc-exports (remove-if-not
+ #'(lambda (sym)
+ (string=
+ (package-name (symbol-package sym))
+ pkg))
+ exports))
+ (*package* (or *protobuf-rpc-package*
+ (when *use-common-lisp-package* (find-package :common-lisp))
+ (find-package :keyword))))
+ (when rpc-exports
+ (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
+ ~% (cl:unless (cl:find-package \"~A\")~
+ ~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
+ ~%(cl:in-package \"~A\")~
+ ~%(cl:export '(~{~A~^~% ~}))~%~%"
+ pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
+ rpc-exports))))
(when (or lisp-pkg pkg)
(let ((pkg (string-upcase (or lisp-pkg pkg))))
- (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel) ~
- ~% (unless (cl:find-package \"~A\") ~
- ~% (cl:defpackage ~A (:use :COMMON-LISP)))) ~
- ~%(cl:in-package \"~A\") ~
+ (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
+ ~% (cl:unless (cl:find-package \"~A\")~
+ ~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
+ ~%(cl:in-package \"~A\")~
~%(cl:export '(~{~A~^~% ~}))~%~%"
- pkg pkg pkg (collect-exports schema))))
+ pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
+ (remove-if-not
+ #'(lambda (sym)
+ (string=
+ (package-name (symbol-package sym))
+ pkg))
+ exports))))
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&(proto:define-schema ~(~A~)" (or class name))
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~@[~VT~](proto:define-enum ~(~S~)"
(and (not (zerop indentation)) indentation) class)
- (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+ (let ((other (and name (string/= name (class-name->proto class)) name)))
(cond ((or other alias-for documentation source-location)
- (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
- ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
- ~:[~*~;:documentation ~S~@[~%~VT~]~]~
+ (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
+ ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+ ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
~:[~*~;:source-location ~/source-location/~])"
(+ indentation 4)
- other other (and (or alias-for documentation) (+ indentation 5))
+ other other (and (or alias-for documentation source-location) (+ indentation 5))
alias-for alias-for (and (or documentation source-location) (+ indentation 5))
documentation documentation (and source-location (+ indentation 5))
source-location source-location))
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~](proto:define-group ~(~S~)"
(and (not (zerop indentation)) indentation) class)
- (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+ (let ((other (and name (string/= name (class-name->proto class)) name)))
(format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
:arity ~(~S~)~@[~%~VT~]~
- ~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
- ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
- ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
- ~:[~*~;:documentation ~S~@[~%~VT~]~]~
+ ~:[~2*~;:name ~S~@[~%~VT~]~]~
+ ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+ ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+ ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
~:[~*~;:source-location ~/source-location/~])"
(+ indentation 4)
index (+ indentation 5)
(format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
(and (not (zerop indentation)) indentation)
(if (eq message-type :message) "message" "extend") class)
- (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+ (let ((other (and name (string/= name (class-name->proto class)) name)))
(cond ((eq message-type :extends)
(format stream " ()"))
((or other alias-for conc-name documentation source-location)
- (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
- ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
- ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
- ~:[~*~;:documentation ~S~@[~%~VT~]~]~
+ (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
+ ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+ ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+ ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
~:[~*~;:source-location ~/source-location/~])"
(+ indentation 4)
other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
~@[ :options (~{~/protobuf-option/~^ ~})~])~
- ~:[~*~*~;~VT; ~A~]"
+ ~:[~2*~;~VT; ~A~]"
;; Non-keyword class means an enum type, print default with ~(~S~)
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
~@[ :options (~{~/protobuf-option/~^ ~})~])~
- ~:[~*~*~;~VT; ~A~]")
+ ~:[~2*~;~VT; ~A~]")
(and (not (zerop indentation)) indentation)
slot-name type defaultp default reader writer packed options
;; Don't write the comment if we'll insert a close paren after it
(defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
&key (indentation 0) more)
(declare (ignore more))
- (with-prefixed-accessors (class documentation source-location) (proto- service)
+ (with-prefixed-accessors (class documentation name source-location) (proto- service)
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~](proto:define-service ~(~S~)"
(and (not (zerop indentation)) indentation) (proto-class service))
- (cond ((or documentation source-location)
- (format stream "~%~@[~VT~](~:[~*~;:documentation ~S~@[~%~VT~]~]~
- ~:[~*~;:source-location ~/source-location/~])"
- (+ indentation 4)
- documentation documentation (and source-location (+ indentation 5))
- source-location source-location))
- (t
- (format stream " ()")))
+ (let ((other (and name (string/= name (class-name->proto (proto-class service))) name)))
+ (cond ((or documentation other source-location)
+ (format stream "~%~@[~VT~](~:[~2*~;:documentation ~S~@[~%~VT~]~]~
+ ~:[~2*~;:name ~S~@[~%~VT~]~]~
+ ~:[~*~;:source-location ~/source-location/~])"
+ (+ indentation 4)
+ documentation documentation (and (or documentation source-location) (+ indentation 5))
+ other other (and source-location (+ indentation 5))
+ source-location source-location))
+ (t
+ (format stream " ()"))))
(loop for (method . more) on (proto-methods service) doing
(write-schema-as type method stream :indentation (+ indentation 2) :more more)
(when more
(defmethod write-schema-as ((type (eql :lisp)) (method protobuf-method) stream
&key (indentation 0) more)
(declare (ignore more))
- (with-prefixed-accessors (class input-type output-type streams-type options
- documentation source-location) (proto- method)
+ (with-prefixed-accessors (class input-type output-type streams-type
+ name input-name output-name streams-name
+ options documentation source-location) (proto- method)
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
- (format stream "~&~@[~VT~](~(~S~) (~(~S~) => ~(~S~)~@[ :streams ~(~S~)~])"
- (and (not (zerop indentation)) indentation)
- class input-type output-type streams-type)
+ (format stream "~&~@[~VT~](~(~S~) (" (and (not (zerop indentation)) indentation) class)
+ (if (and input-name (string/= (class-name->proto input-type) input-name))
+ (format stream "(~(~S~) :name ~S) => " input-type input-name)
+ (format stream "~(~S~) => " input-type))
+ (if (and output-name (string/= (class-name->proto output-type) output-name))
+ (format stream "(~(~S~) :name ~S)" output-type output-name)
+ (format stream "~(~S~)" output-type))
+ (when streams-type
+ (if (and streams-name (string/= (class-name->proto streams-type) streams-name))
+ (format stream " :streams (~(~S~) :name ~S)" streams-type streams-name)
+ (format stream " :streams ~(~S~)" streams-type)))
+ (format stream ")")
+ (when (and name (string/= (class-name->proto name) name))
+ (format stream "~%~VT:name ~S"
+ (+ indentation 2) name))
(when options
(format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
(+ indentation 2) options))
;; Export the class name and all of the accessor names
(defmethod collect-exports ((message protobuf-message))
(append (list (proto-class message))
+ (mapcan #'collect-exports (proto-messages message))
(mapcan #'collect-exports (proto-fields message))))
;; Export just the slot accessor name
(defmethod collect-exports ((field protobuf-field))
- (list (proto-slot field)))
+ (list (or (proto-reader field)
+ (proto-slot field))))
;; Export the names of all the methods
(defmethod collect-exports ((service protobuf-service))