(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)))
(loop for (enum . more) on (proto-enums schema) doing
(write-schema-as type enum stream :indentation indentation :more more)
(terpri stream))
+ (loop for (alias . more) on (proto-type-aliases schema) doing
+ (write-schema-as type alias stream :indentation indentation :more more)
+ (terpri stream))
(loop for (msg . more) on (proto-messages schema) doing
(write-schema-as type msg stream :indentation indentation :more more)
(terpri stream))
("deprecated" symbol)
("optimize_for" symbol)
("packed" boolean)
+ ("protocol" symbol)
("stream_type" string)
;; Keep the rest of these in alphabetical order
("cc_api_version" integer)
nil)))
(defun cl-user::protobuf-option (stream option colon-p atsign-p)
- (let ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
- (proto-type option))))
+ (let* ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
+ (proto-type option)))
+ (value (proto-value option)))
(cond (colon-p ;~:/protobuf-option/ -- .proto format
(let ((fmt-control
(cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
(case type
((symbol) "(~A)~@[ = ~A~]")
((boolean) "(~A)~@[ = ~(~A~)~]")
- (otherwise "(~A)~@[ = ~S~]")))
+ (otherwise
+ (cond ((typep value 'standard-object)
+ ;; If the value is an instance of some class,
+ ;; then it must be some sort of complex option,
+ ;; so print the value using the text format
+ (setq value
+ (with-output-to-string (s)
+ (print-text-format value nil
+ :stream s :print-name nil :suppress-line-breaks t)))
+ "(~A)~@[ = ~A~]")
+ (t
+ "(~A)~@[ = ~S~]")))))
(t
(case type
((symbol) "~A~@[ = ~A~]")
((boolean) "~A~@[ = ~(~A~)~]")
- (otherwise "~A~@[ = ~S~]"))))))
- (format stream fmt-control (proto-name option) (proto-value option))))
- (atsign-p ;~@/protobuf-option/ -- .lisp format
+ (otherwise
+ (cond ((typep value 'standard-object)
+ (setq value
+ (with-output-to-string (s)
+ (print-text-format value nil
+ :stream s :print-name nil :suppress-line-breaks t)))
+ "~A~@[ = ~A~]")
+ (t "~A~@[ = ~S~]"))))))))
+ (format stream fmt-control (proto-name option) value)))
+ (atsign-p ;~@/protobuf-option/ -- string/value format
(let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
- (format stream fmt-control (proto-name option) (proto-value option))))
+ (format stream fmt-control (proto-name option) value)))
(t ;~/protobuf-option/ -- keyword/value format
(let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S")))
- (format stream fmt-control (proto-name option) (proto-value option)))))))
+ (format stream fmt-control (proto-name option) value))))))
(defun cl-user::source-location (stream location colon-p atsign-p)
(declare (ignore colon-p atsign-p))
(maybe-qualified-name val) index
documentation *protobuf-enum-comment-column* documentation)))
+(defmethod write-schema-as ((type (eql :proto)) (alias protobuf-type-alias) stream
+ &key (indentation 0) more)
+ (declare (ignore more))
+ (with-prefixed-accessors (name lisp-type proto-type) (proto- alias)
+ (let ((comment (format nil "Note: there is an alias ~A that maps Lisp ~(~S~) to Protobufs ~(~A~)"
+ name lisp-type proto-type)))
+ (write-schema-documentation type comment stream :indentation indentation))
+ (format stream "~&~@[~VT~]~%"
+ (and (not (zerop indentation)) indentation))))
(defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
&key (indentation 0) more index arity)
"Given a message, return a fully qualified name if the short name
is not sufficient to name the message in the current scope."
(etypecase x
- ((or protobuf-message protobuf-enum protobuf-enum-value)
+ ((or protobuf-message protobuf-enum protobuf-enum-value
+ protobuf-type-alias)
(cond ((string= (make-qualified-name (proto-parent x) (proto-name x))
(proto-qualified-name x))
(proto-name x))
(with-prefixed-accessors (name documentation required type index packed options) (proto- field)
(let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
(msg (and (not (keywordp class))
- (or (find-message message class) (find-enum message class)))))
+ (or (find-message message class)
+ (find-enum message class)
+ (find-type-alias message class)))))
(cond ((and (typep msg 'protobuf-message)
(eq (proto-message-type msg) :group))
(format stream "~&~@[~VT~]~(~A~) "
(t default))))
(default (and defaultp
(if (stringp default) (escape-string default) default))))
- (format stream (if (and (keywordp class) (not (eq class :bool)))
- ;; Keyword class means a primitive type, print default with ~S
- "~&~@[~VT~]~(~A~) ~A ~A = ~D~
+ (if (typep msg 'protobuf-type-alias)
+ (format stream "~&~@[~VT~]~(~A~) ~(~A~) ~A = ~D~
~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
~:[~*~*~;~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~]~%")
- (and (not (zerop indentation)) indentation)
- required (maybe-qualified-name msg type) name index
- defaultp default packed options
- documentation *protobuf-field-comment-column* documentation)))))))
+ (and (not (zerop indentation)) indentation)
+ required (proto-proto-type msg) name index
+ defaultp default packed options
+ t *protobuf-field-comment-column*
+ (format nil "alias maps Lisp ~(~S~) to Protobufs ~(~A~)"
+ (proto-lisp-type msg) (proto-proto-type msg)))
+ (format stream (if (and (keywordp class) (not (eq class :bool)))
+ ;; Keyword class means a primitive type, print default with ~S
+ "~&~@[~VT~]~(~A~) ~A ~A = ~D~
+ ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
+ ~:[~*~*~;~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~]~%")
+ (and (not (zerop indentation)) indentation)
+ required (maybe-qualified-name msg type) name index
+ defaultp default packed options
+ documentation *protobuf-field-comment-column* documentation))))))))
(defun escape-string (string)
(if (every #'(lambda (ch) (and (standard-char-p ch) (graphic-char-p ch))) string)
(and (not (zerop indentation)) indentation)
from (not (eql from to)) (if (eql to #.(1- (ash 1 29))) "max" to))))
-
(defmethod write-schema-as ((type (eql :proto)) (service protobuf-service) stream
&key (indentation 0) more)
(declare (ignore more))
&key (indentation 0) more)
(declare (ignore more))
(with-prefixed-accessors
- (name documentation input-name output-name options) (proto- method)
+ (name documentation input-name output-name streams-name options) (proto- method)
(let* ((imsg (find-message *protobuf* input-name))
(omsg (find-message *protobuf* output-name))
+ (smsg (find-message *protobuf* streams-name))
(iname (maybe-qualified-name imsg))
- (oname (maybe-qualified-name omsg)))
+ (oname (maybe-qualified-name omsg))
+ (sname (maybe-qualified-name smsg)))
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
- (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
+ (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ streams (~A)~]~@[ returns (~A)~]"
(and (not (zerop indentation)) indentation)
- name iname oname)
+ name iname sname oname)
(cond (options
(format stream " {~%")
(dolist (option 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)
+ (*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))
+ ;; 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))))
(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: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
+ (collect-exports schema))))
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&(proto:define-schema ~(~A~)" (or class name))
(terpri stream))
(setq spaces " "))
(when options
- (format stream "~A:options (~{~@/protobuf-option/~^ ~})" spaces options)
+ (format stream "~A:options (~{~/protobuf-option/~^ ~})" spaces options)
(when documentation
(terpri stream))
(setq spaces " "))
(format stream ")")
(loop for (enum . more) on (proto-enums schema) doing
(write-schema-as type enum stream :indentation 2 :more more))
+ (loop for (alias . more) on (proto-type-aliases schema) doing
+ (write-schema-as type alias stream :indentation 2 :more more))
(loop for (msg . more) on (proto-messages schema) doing
(write-schema-as type msg stream :indentation 2 :more more))
(loop for (svc . more) on (proto-services schema) doing
(format stream "~&~@[~VT~]~(~A~)"
(and (not (zerop indentation)) indentation) value))))
+(defmethod write-schema-as ((type (eql :lisp)) (alias protobuf-type-alias) stream
+ &key (indentation 0) more)
+ (declare (ignore more))
+ (terpri stream)
+ (with-prefixed-accessors (class lisp-type proto-type serializer deserializer) (proto- alias)
+ (format stream "~@[~VT~](proto:define-type-alias ~(~S~)"
+ (and (not (zerop indentation)) indentation) class)
+ (format stream " ()") ;no options yet
+ (format stream "~%~@[~VT~]:lisp-type ~(~S~)~
+ ~%~@[~VT~]:proto-type ~(~A~)~
+ ~%~@[~VT~]:serializer ~(~S~)~
+ ~%~@[~VT~]:deserializer ~(~S~))"
+ (+ indentation 2) lisp-type
+ (+ indentation 2) proto-type
+ (+ indentation 2) serializer
+ (+ indentation 2) deserializer)))
(defmethod write-schema-as ((type (eql :lisp)) (message protobuf-message) stream
&key (indentation 0) more index arity)
(with-prefixed-accessors (value required index packed options documentation) (proto- field)
(let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
(msg (and (not (keywordp class))
- (or (find-message message class) (find-enum message class))))
+ (or (find-message message class)
+ (find-enum message class)
+ (find-type-alias message class))))
(type (let ((cl (case class
((:int32) 'int32)
((:int64) 'int64)
;; Keyword class means a primitive type, print default with ~S
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
- ~@[ :options (~{~@/protobuf-option/~^ ~})~])~
+ ~@[ :options (~{~/protobuf-option/~^ ~})~])~
~:[~*~*~;~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/~^ ~})~])~
+ ~@[ :options (~{~/protobuf-option/~^ ~})~])~
~:[~*~*~;~VT; ~A~]")
(and (not (zerop indentation)) indentation)
slot-name type defaultp default reader writer packed options
(and (not (zerop indentation)) indentation)
from (if (eql to #.(1- (ash 1 29))) "max" to))))
-
(defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
&key (indentation 0) more)
(declare (ignore 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 options
+ (with-prefixed-accessors (class input-type output-type streams-type options
documentation source-location) (proto- method)
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
- (format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
+ (format stream "~&~@[~VT~](~(~S~) (~(~S~) => ~(~S~)~@[ :streams ~(~S~)~])"
(and (not (zerop indentation)) indentation)
- class input-type output-type)
+ class input-type output-type streams-type)
(when options
- (format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
+ (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
(+ indentation 2) options))
(format stream ")")))
;; 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))
projects / cl-protobufs.git / blobdiff