:package package
:lisp-package (or lisp-pkg package)
:imports imports
- :options options
- :optimize optimize
+ :options (if optimize
+ (append options (list (make-instance 'protobuf-option
+ :name "optimize_for"
+ :value (if (eq optimize :speed) "SPEED" "CODE_SIZE")
+ :type 'symbol)))
+ options)
:documentation documentation))
(*protobuf* protobuf)
(*protobuf-package* (or (find-package lisp-pkg)
(find-package (string-upcase lisp-pkg))
- *package*)))
+ *package*)))
(apply #'process-imports imports)
(with-collectors ((forms collect-form))
(dolist (msg messages)
((define-message define-extend)
(setf (proto-parent model) protobuf)
(setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list model)))
- (when (proto-extension-p model)
+ (when (eql (proto-message-type model) :extends)
(setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list model)))))
((define-service)
(setf (proto-services protobuf) (nconc (proto-services protobuf) (list model)))))))
collect (make-instance 'protobuf-option
:name key
:value val)))
- (index 0)
(message (make-instance 'protobuf-message
:class type
:name name
:conc-name (and conc-name (string conc-name))
:options options
:documentation documentation))
+ (index 0)
(*protobuf* message))
(with-collectors ((slots collect-slot)
(forms collect-form))
(dolist (field fields)
(case (car field)
- ((define-enum define-message define-extend define-extension)
- (destructuring-bind (&optional progn type model definers)
+ ((define-enum define-message define-extend define-extension define-group)
+ (destructuring-bind (&optional progn type model definers extra-field extra-slot)
(macroexpand-1 field env)
(assert (eq progn 'progn) ()
"The macroexpansion for ~S failed" field)
((define-message define-extend)
(setf (proto-parent model) message)
(setf (proto-messages message) (nconc (proto-messages message) (list model)))
- (when (proto-extension-p model)
+ (when (eql (proto-message-type model) :extends)
(setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ ((define-group)
+ (setf (proto-parent model) message)
+ (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (when extra-slot
+ (collect-slot extra-slot))
+ (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
((define-extension)
(setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
(otherwise
collect (make-instance 'protobuf-option
:name key
:value val)))
- (index 0)
(message (find-message *protobuf* name))
(conc-name (and message (proto-conc-name message)))
(alias-for (and message (proto-alias-for message)))
:messages (copy-list (proto-messages message))
:fields (copy-list (proto-fields message))
:options (or options (copy-list (proto-options message)))
- :extension-p t ;this message is an extension
- :documentation documentation))))
+ :message-type :extends ;this message is an extension
+ :documentation documentation)))
+ (index 0))
(assert message ()
"There is no message named ~A to extend" name)
(assert (eq type (proto-class message)) ()
(with-collectors ((forms collect-form))
(dolist (field fields)
(assert (not (member (car field)
- '(define-enum define-message define-extend define-extension))) ()
+ '(define-enum define-message define-extend define-extension define-group))) ()
"The body of ~S can only contain field definitions" 'define-extend)
(multiple-value-bind (field slot idx)
(process-field field index :conc-name conc-name :alias-for alias-for)
;; This so that (de)serialization works
(setf (proto-reader field) reader
(proto-writer field) writer)))
- (setf (proto-extension-p field) t) ;this field is an extension
+ (setf (proto-message-type field) :extends) ;this field is an extension
(setf (proto-fields extends) (nconc (proto-fields extends) (list field)))))
`(progn
define-extend
,extends
,forms))))
+(defmacro define-group (type (&key index arity name conc-name alias-for options documentation)
+ &body fields &environment env)
+ "Define a message named 'type' and a Lisp 'defclass', *and* a field named type.
+ This is deprecated in Protobufs, but if you have to use it, you must give
+ 'index' as the field index and 'arity' of :required, :optional or :repeated.
+ 'name' can be used to override the defaultly generated Protobufs message name.
+ The body consists of fields, or 'define-enum' or 'define-message' forms.
+ 'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
+ If 'alias-for' is given, no Lisp class is defined. Instead, the message will be
+ used as an alias for a class that already exists in Lisp. This feature is intended
+ to be used to define messages that will be serialized from existing Lisp classes;
+ unless you get the slot names or readers exactly right for each field, it will be
+ the case that trying to (de)serialize into a Lisp object won't work.
+ 'options' is a set of keyword/value pairs, both of which are strings.
+
+ Fields take the form (slot &key type name default reader)
+ 'slot' can be either a symbol giving the field name, or a list whose
+ first element is the slot name and whose second element is the index.
+ 'type' is the type of the slot.
+ 'name' can be used to override the defaultly generated Protobufs field name.
+ 'default' is the default value for the slot.
+ 'reader' is a Lisp slot reader function to use to get the value, instead of
+ using 'slot-value'; this is often used when aliasing an existing class.
+ 'writer' is a Lisp slot writer function to use to set the value."
+ (check-type index integer)
+ (check-type arity (member :required :optional :repeated))
+ (let* ((slot (or (and name (proto->slot-name name)) type))
+ (name (or name (class-name->proto type)))
+ (options (loop for (key val) on options by #'cddr
+ collect (make-instance 'protobuf-option
+ :name key
+ :value val)))
+ (mslot (unless alias-for
+ `(,slot ,@(case arity
+ (:required
+ `(:type ,type))
+ (:optional
+ `(:type (or ,type null)
+ :initform nil))
+ (:repeated
+ `(:type (list-of ,type)
+ :initform ())))
+ :initarg ,(kintern (symbol-name slot)))))
+ (mfield (make-instance 'protobuf-field
+ :name (slot-name->proto slot)
+ :value slot
+ :type name
+ :class type
+ ;; One of :required, :optional or :repeated
+ :required arity
+ :index index
+ :message-type :group))
+ (message (make-instance 'protobuf-message
+ :class type
+ :name name
+ :alias-for alias-for
+ :conc-name (and conc-name (string conc-name))
+ :options options
+ :message-type :group ;this message is a group
+ :documentation documentation))
+ (index 0)
+ (*protobuf* message))
+ (with-collectors ((slots collect-slot)
+ (forms collect-form))
+ (dolist (field fields)
+ (case (car field)
+ ((define-enum define-message define-extend define-extension define-group)
+ (destructuring-bind (&optional progn type model definers extra-field extra-slot)
+ (macroexpand-1 field env)
+ (assert (eq progn 'progn) ()
+ "The macroexpansion for ~S failed" field)
+ (map () #'collect-form definers)
+ (ecase type
+ ((define-enum)
+ (setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ ((define-message define-extend)
+ (setf (proto-parent model) message)
+ (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (when (eql (proto-message-type model) :extends)
+ (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ ((define-group)
+ (setf (proto-parent model) message)
+ (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (when extra-slot
+ (collect-slot extra-slot))
+ (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
+ ((define-extension)
+ (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
+ (otherwise
+ (multiple-value-bind (field slot idx)
+ (process-field field index :conc-name conc-name :alias-for alias-for)
+ (assert (not (find (proto-index field) (proto-fields message) :key #'proto-index)) ()
+ "The field ~S overlaps with another field in ~S"
+ (proto-value field) (proto-class message))
+ (setq index idx)
+ (when slot
+ (collect-slot slot))
+ (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
+ (if alias-for
+ ;; If we've got an alias, define a a type that is the subtype of
+ ;; the Lisp class that typep and subtypep work
+ (unless (or (eq type alias-for) (find-class type nil))
+ (collect-form `(deftype ,type () ',alias-for)))
+ ;; If no alias, define the class now
+ (collect-form `(defclass ,type () (,@slots)
+ ,@(and documentation `((:documentation ,documentation))))))
+ `(progn
+ define-group
+ ,message
+ ,forms
+ ,mfield
+ ,mslot))))
+
(defun process-field (field index &key conc-name alias-for)
"Process one field descriptor within 'define-message' or 'define-extend'.
Returns a 'proto-field' object, a CLOS slot form and the incremented field index."
#+stubby (add-color request)
#+ignore (add-color request)))
||#
+
+#||
+(let ((ps "syntax = \"proto2\";
+
+package color_wheel;
+
+option optimize_for = SPEED;
+
+message ColorWheel {
+ required string name = 1;
+ repeated Color colors = 2;
+ optional group Metadata = 3 {
+ optional string author = 1;
+ optional string revision = 2;
+ optional string date = 3;
+ }
+}
+
+message Color {
+ optional string name = 1;
+ required int64 r_value = 2;
+ required int64 g_value = 3;
+ required int64 b_value = 4;
+ extensions 1000 to max;
+}
+
+extend Color {
+ optional int64 opacity = 1000;
+}
+
+message GetColorRequest {
+ required ColorWheel wheel = 1;
+ required string name = 2;
+}
+
+message AddColorRequest {
+ required ColorWheel wheel = 1;
+ required Color color = 2;
+}
+
+service ColorWheel {
+ rpc GetColor (GetColorRequest) returns (Color) {
+ option deadline = \"1.0\";
+ }
+ rpc AddColor (AddColorRequest) returns (Color) {
+ option deadline = \"1.0\";
+ }
+}"))
+ (with-input-from-string (s ps)
+ (setq cw (proto:parse-protobuf-from-stream s))))
+
+(proto:define-proto color-wheel
+ (:package color-wheel
+ :optimize :speed
+ :documentation "Color wheel example, with groups")
+ (proto:define-message color-wheel ()
+ (name :type string)
+ (colors :type (list-of color))
+ (proto:define-group metadata
+ (:index 3
+ :arity :optional)
+ (author :type (or null string))
+ (revision :type (or null string))
+ (date :type (or null string))))
+ (proto:define-message color ()
+ (name :type (or null string))
+ (r-value :type integer)
+ (g-value :type integer)
+ (b-value :type integer))
+ (proto:define-message get-color-request ()
+ (wheel :type color-wheel)
+ (name :type string))
+ (proto:define-message add-color-request ()
+ (wheel :type color-wheel)
+ (color :type color))
+ (proto:define-service color-wheel ()
+ (get-color (get-color-request color))
+ (add-color (add-color-request color))))
+
+(proto:write-protobuf *color-wheel*)
+(proto:write-protobuf *color-wheel* :type :lisp)
+
+(progn ;with-rpc-channel (rpc)
+ (let* ((meta1 (make-instance 'metadata :revision "1.0"))
+ (wheel (make-instance 'color-wheel :name "Colors" :metadata meta1))
+ (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
+ (rqst1 (make-instance 'add-color-request :wheel wheel :color color1)))
+ #-ignore (progn
+ (format t "~2&Unextended~%")
+ (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil)))
+ (print ser1)
+ (proto:print-text-format rqst1)
+ (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
+ #+stubby (add-color request)
+ #+ignore (add-color request)))
+||#
:accessor proto-imports
:initarg :imports
:initform ())
- (optimize :type (member nil :space :speed)
- :accessor proto-optimize
- :initarg :optimize
- :initform nil)
(enums :type (list-of protobuf-enum) ;the set of enum types
:accessor proto-enums
:initarg :enums
(value :type (or null string) ;the value
:accessor proto-value
:initarg :value
- :initform nil))
+ :initform nil)
+ (type :type (or null symbol) ;(optional) Lisp type,
+ :reader proto-type ; one of string, integer, sybol (for now)
+ :initarg :type
+ :initform 'string))
(:documentation
"The model class that represents a Protobufs options, i.e., a keyword/value pair."))
(print-unreadable-object (o stream :type t :identity t)
(format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
+(defgeneric find-option (protobuf name)
+ (:documentation
+ "Given a protobuf schema, message, enum, etc and the name of an option,
+ returns the value of the option and its (Lisp) type."))
+
(defmethod find-option ((protobuf base-protobuf) (name string))
(let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
- (and option (proto-value option))))
+ (and option
+ (values (proto-value option) (proto-type option)))))
(defmethod find-option ((options list) (name string))
(let ((option (find name options :key #'proto-name :test #'option-name=)))
- (and option (proto-value option))))
+ (and option
+ (values (proto-value option) (proto-type option)))))
(defun option-name= (name1 name2)
(let ((start1 (if (eql (char name1 0) #\() 1 0))
:accessor proto-extensions
:initarg :extensions
:initform ())
- (extension-p :type (member t nil) ;true iff this message extends another message
- :accessor proto-extension-p
- :initarg :extension-p
- :initform nil))
+ ;; :message is an ordinary message
+ ;; :group is a (deprecated) group (kind of an "implicit" message)
+ ;; :extends is an 'extends' to an existing message
+ (message-type :type (member :message :group :extends)
+ :accessor proto-message-type
+ :initarg :message-type
+ :initform :message))
(:documentation
"The model class that represents a Protobufs message."))
(defmethod initialize-instance :after ((message protobuf-message) &rest initargs)
(declare (ignore initargs))
;; Record this message under just its Lisp class name
- (with-slots (class extension-p) message
- (when (and class (not extension-p))
+ ;; No need to record an extension, it's already been recorded
+ (with-slots (class message-type) message
+ (when (and class (not (eql message-type :extends)))
(setf (gethash class *all-messages*) message))))
(defmethod make-load-form ((m protobuf-message) &optional environment)
(defmethod print-object ((m protobuf-message) stream)
(print-unreadable-object (m stream :type t :identity t)
- (format stream "~S~@[ (alias for ~S)~]~@[ (extended~*)~]"
- (proto-class m) (proto-alias-for m) (proto-extension-p m))))
+ (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
+ (proto-class m) (proto-alias-for m)
+ (eql (proto-message-type m) :group)
+ (eql (proto-message-type m) :extends))))
(defmethod find-message ((message protobuf-message) (type symbol))
;; Extended messages "shadow" non-extended ones
:accessor proto-packed
:initarg :packed
:initform nil)
- (extension-p :type (member t nil) ;true iff this field is an extension
- :accessor proto-extension-p
- :initarg :extension-p
- :initform nil))
+ ;; Copied from 'proto-message-type' of the field
+ (message-type :type (member :message :group :extends)
+ :accessor proto-message-type
+ :initarg :message-type
+ :initform :message))
(:documentation
"The model class that represents one field within a Protobufs message."))
(defmethod print-object ((f protobuf-field) stream)
(print-unreadable-object (f stream :type t :identity t)
- (format stream "~S :: ~S = ~D~@[ (extended~*)~]"
- (proto-value f) (proto-class f) (proto-index f) (proto-extension-p f))))
+ (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
+ (proto-value f) (proto-class f) (proto-index f)
+ (eql (proto-message-type f) :group)
+ (eql (proto-message-type f) :extends))))
;; An extension within a message
"If what appears next in the stream is a comment, skip it and any following comments,
then skip any following whitespace."
(loop
- (unless (eql (peek-char nil stream nil) #\/)
- (return)
+ (let ((ch (peek-char nil stream nil)))
+ (when (or (null ch) (not (eql ch #\/)))
+ (return-from maybe-skip-comments))
(read-char stream)
(case (peek-char nil stream nil)
((#\/)
(skip-line-comment stream))
((#\*)
(skip-block-comment stream))
+ ((nil)
+ (return-from maybe-skip-comments))
(otherwise
(error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
#\/ (file-position stream) #\/ #\*)))))
:class class
:name name))
(*protobuf* protobuf)
- (*protobuf-package* nil))
+ (*protobuf-package* *package*))
(loop
(skip-whitespace stream)
(maybe-skip-comments stream)
(let* ((option (parse-proto-option stream protobuf))
(name (and option (proto-name option)))
(value (and option (proto-value option))))
- (when option
- (cond ((option-name= name "optimize_for")
- (let ((value (cond ((string= value "SPEED") :speed)
- ((string= value "CODE_SIZE") :space)
- (t nil))))
- (setf (proto-optimize protobuf) value)))
- ((option-name= name "lisp_package")
- (let ((package (or (find-package value)
- (find-package (string-upcase value)))))
- (setf (proto-lisp-package protobuf) value)
- (setq *protobuf-package* package)))))))
+ (when (and option (option-name= name "lisp_package"))
+ (let ((package (or (find-package value)
+ (find-package (string-upcase value))
+ *protobuf-package*)))
+ (setf (proto-lisp-package protobuf) value)
+ (setq *protobuf-package* package)))))
((string= token "enum")
(parse-proto-enum stream protobuf))
((string= token "extend")
(unless (proto-lisp-package protobuf)
(setf (proto-lisp-package protobuf) lisp-pkg))
(let ((package (or (find-package lisp-pkg)
- (find-package (string-upcase lisp-pkg)))))
+ (find-package (string-upcase lisp-pkg))
+ *protobuf-package*)))
(setq *protobuf-package* package))))
(defun parse-proto-import (stream protobuf &optional (terminator #\;))
(let ((alias (find-option enum "lisp_alias")))
(when alias
(setf (proto-alias-for enum) (make-lisp-symbol alias))))
- (return-from parse-proto-enum))
+ (return-from parse-proto-enum enum))
(if (string= name "option")
(parse-proto-option stream enum #\;)
(parse-proto-enum-value stream enum name))))))
:name name
:index idx
:value (proto->enum-name name *protobuf-package*))))
- (setf (proto-values enum) (nconc (proto-values enum) (list value)))))
+ (setf (proto-values enum) (nconc (proto-values enum) (list value)))
+ value))
-(defun parse-proto-message (stream protobuf)
+(defun parse-proto-message (stream protobuf &optional name)
"Parse a Protobufs 'message' from 'stream'.
Updates the 'protobuf' or 'protobuf-message' object to have the message."
(check-type protobuf (or protobuf protobuf-message))
- (let* ((name (prog1 (parse-token stream)
+ (let* ((name (prog1 (or name (parse-token stream))
(expect-char stream #\{ "message")
(maybe-skip-comments stream)))
(message (make-instance 'protobuf-message
(let ((alias (find-option message "lisp_alias")))
(when alias
(setf (proto-alias-for message) (make-lisp-symbol alias))))
- (return-from parse-proto-message))
+ (return-from parse-proto-message message))
(cond ((string= token "enum")
(parse-proto-enum stream message))
((string= token "extend")
:enums (copy-list (proto-enums message))
:messages (copy-list (proto-messages message))
:fields (copy-list (proto-fields message))
- :extension-p t)))) ;this message is an extension
+ :message-type :extends)))) ;this message is an extension
(loop
(let ((token (parse-token stream)))
(when (null token)
(let ((alias (find-option extends "lisp_alias")))
(when alias
(setf (proto-alias-for extends) (make-lisp-symbol alias))))
- (return-from parse-proto-extend))
+ (return-from parse-proto-extend extends))
(cond ((member token '("required" "optional" "repeated") :test #'string=)
(parse-proto-field stream extends token message))
((string= token "option")
"Parse a Protobufs field from 'stream'.
Updates the 'protobuf-message' object to have the field."
(check-type message protobuf-message)
- (let* ((type (parse-token stream))
- (name (prog1 (parse-token stream)
+ (let ((type (parse-token stream)))
+ (if (string= type "group")
+ (parse-proto-group stream message required extended-from)
+ (let* ((name (prog1 (parse-token stream)
+ (expect-char stream #\= "message")))
+ (idx (parse-int stream))
+ (opts (prog1 (parse-proto-field-options stream)
+ (expect-char stream #\; "message")
+ (maybe-skip-comments stream)))
+ (dflt (find-option opts "default"))
+ (packed (find-option opts "packed"))
+ (ptype (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
+ "fixed32" "fixed64" "sfixed32" "sfixed64"
+ "string" "bytes" "bool" "float" "double") :test #'string=)
+ (kintern type)
+ type))
+ (class (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*)))
+ (field (make-instance 'protobuf-field
+ :name name
+ :value (proto->slot-name name *protobuf-package*)
+ :type type
+ :class class
+ ;; One of :required, :optional or :repeated
+ :required (kintern required)
+ :index idx
+ :default dflt
+ :packed (and packed (string= packed "true"))
+ :message-type (proto-message-type message))))
+ (when extended-from
+ (assert (index-within-extensions-p idx extended-from) ()
+ "The index ~D is not in range for extending ~S"
+ idx (proto-class extended-from)))
+ (let ((slot (find-option opts "lisp_name")))
+ (when slot
+ (setf (proto-value field) (make-lisp-symbol type))))
+ (setf (proto-fields message) (nconc (proto-fields message) (list field)))
+ field))))
+
+(defun parse-proto-group (stream message required &optional extended-from)
+ "Parse a (deprecated) Protobufs group from 'stream'.
+ Updates the 'protobuf-message' object to have the group type and field."
+ (check-type message protobuf-message)
+ (let* ((type (prog1 (parse-token stream)
(expect-char stream #\= "message")))
+ (name (slot-name->proto (proto->slot-name type)))
(idx (parse-int stream))
- (opts (prog1 (parse-proto-field-options stream)
- (expect-char stream #\; "message")
- (maybe-skip-comments stream)))
- (dflt (find-option opts "default"))
- (packed (find-option opts "packed"))
- (ptype (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
- "fixed32" "fixed64" "sfixed32" "sfixed64"
- "string" "bytes" "bool" "float" "double") :test #'string=)
- (kintern type)
- type))
- (class (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*)))
+ (msg (parse-proto-message stream message type))
+ (class (proto->class-name type *protobuf-package*))
(field (make-instance 'protobuf-field
:name name
:value (proto->slot-name name *protobuf-package*)
;; One of :required, :optional or :repeated
:required (kintern required)
:index idx
- :default dflt
- :packed (and packed (string= packed "true"))
- :extension-p (proto-extension-p message))))
+ :message-type :group)))
+ (setf (proto-message-type msg) :group)
(when extended-from
(assert (index-within-extensions-p idx extended-from) ()
"The index ~D is not in range for extending ~S"
idx (proto-class extended-from)))
- (let ((slot (find-option opts "lisp_name")))
- (when slot
- (setf (proto-value field) (make-lisp-symbol type))))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))))
+ (setf (proto-fields message) (nconc (proto-fields message) (list field)))
+ field))
(defun parse-proto-field-options (stream)
"Parse any options in a Protobufs field from 'stream'.
"Expected 'to' in 'extensions' at position ~D" (file-position stream))
(assert (or (integerp to) (string= to "max")) ()
"Extension value is not an integer or 'max' as position ~D" (file-position stream))
- (setf (proto-extensions message)
- (nconc (proto-extensions message)
- (list (make-instance 'protobuf-extension
- :from from
- :to (if (integerp to) to #.(1- (ash 1 29)))))))))
+ (let ((extension (make-instance 'protobuf-extension
+ :from from
+ :to (if (integerp to) to #.(1- (ash 1 29))))))
+ (setf (proto-extensions message)
+ (nconc (proto-extensions message)
+ (list extension)))
+ extension)))
(defun parse-proto-service (stream protobuf)
(expect-char stream #\} "service")
(maybe-skip-comments stream)
(setf (proto-services protobuf) (nconc (proto-services protobuf) (list service)))
- (return-from parse-proto-service))
+ (return-from parse-proto-service service))
(cond ((string= token "option")
(parse-proto-option stream service #\;))
((string= token "rpc")
(setf (proto-function method) (make-lisp-symbol name))))
(assert (string= ret "returns") ()
"Syntax error in 'message' at position ~D" (file-position stream))
- (setf (proto-methods service) (nconc (proto-methods service) (list method)))))
+ (setf (proto-methods service) (nconc (proto-methods service) (list method)))
+ method))
(defun parse-proto-method-options (stream)
"Parse any options in a Protobufs method from 'stream'.
(let ((*protobuf* protobuf))
(write-protobuf-as type protobuf stream)))
-(defgeneric write-protobuf-as (type protobuf stream &key indentation more)
+(defgeneric write-protobuf-as (type protobuf stream &key indentation &allow-other-keys)
(:documentation
"Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
the given stream 'stream' in the format given by 'type' (:proto, :text, etc).
;;; Pretty print a schema as a .proto file
(defmethod write-protobuf-as ((type (eql :proto)) (protobuf protobuf) stream
- &key (indentation 0) more)
- (declare (ignore more))
- (with-prefixed-accessors (name documentation syntax package imports optimize options) (proto- protobuf)
+ &key (indentation 0))
+ (with-prefixed-accessors (name documentation syntax package imports options) (proto- protobuf)
(when documentation
(write-protobuf-documentation type documentation stream :indentation indentation))
(when syntax
(format stream "~&import \"~A\";~%" import))
(terpri stream))
(write-protobuf-header type stream)
- (when optimize
- (format stream "~&option optimize_for ~A;~%~%"
- (if (eq optimize :space) "CODE_SIZE" "SPEED")))
(when options
(dolist (option options)
(format stream "~&option ~:/protobuf-option/;~%" option))
("lisp_class" "string" 195805)
("lisp_slot" "string" 195806)))
+(defvar *option-types* '(("optimize_for" symbol)))
+
(defmethod write-protobuf-header ((type (eql :proto)) stream)
(format stream "~&import \"net/proto2/proto/descriptor.proto\";~%~%")
(format stream "~&extend proto2.MessageOptions {~%")
(format stream "~&}~%~%"))
(defun cl-user::protobuf-option (stream option colon-p atsign-p)
- (cond (colon-p ;~:/protobuf-option/ -- .proto format
- (if (find (proto-name option) *lisp-options* :key #'first :test #'string=)
- (format stream "(~A)~@[ = ~S~]" (proto-name option) (proto-value option))
- (format stream "~A~@[ = ~S~]" (proto-name option) (proto-value option))))
- (atsign-p ;~@/protobuf-option/ -- .lisp format
- (format stream "~S ~S" (proto-name option) (proto-value option)))
- (t ;~/protobuf-option/ -- keyword/value format
- (format stream "~(:~A~) ~S" (proto-name option) (proto-value option)))))
+ (let ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
+ 'string)))
+ (cond (colon-p ;~:/protobuf-option/ -- .proto format
+ (let ((fmt-control
+ (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
+ (if (eql type 'symbol) "(~A)~@[ = ~A~]" "(~A)~@[ = ~S~]"))
+ (t
+ (if (eql type 'symbol) "~A~@[ = ~A~]" "~A~@[ = ~S~]")))))
+ (format stream fmt-control (proto-name option) (proto-value option))))
+ (atsign-p ;~@/protobuf-option/ -- .lisp format
+ (format stream "~S ~S" (proto-name option) (proto-value option)))
+ (t ;~/protobuf-option/ -- keyword/value format
+ (format stream "~(:~A~) ~S" (proto-name option) (proto-value option))))))
(defmethod write-protobuf-as ((type (eql :proto)) (enum protobuf-enum) stream
&key (indentation 0) more)
(defmethod write-protobuf-as ((type (eql :proto)) (message protobuf-message) stream
- &key (indentation 0) more)
- (declare (ignore more))
- (with-prefixed-accessors (name class alias-for extension-p documentation options) (proto- message)
- (when documentation
- (write-protobuf-documentation type documentation stream :indentation indentation))
- (format stream "~&~@[~VT~]~A ~A {~%"
- (and (not (zerop indentation)) indentation)
- (if extension-p "extend" "message") name)
- (let ((other (and class (not (string= name (class-name->proto class))) class)))
- (when other
- (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
- (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
- (when alias-for
- (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
- (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
- (dolist (option options)
- (format stream "~&~VToption ~:/protobuf-option/;~%"
- (+ indentation 2) option))
- (cond (extension-p
- (loop for (field . more) on (proto-fields message) doing
- (when (proto-extension-p field)
- (write-protobuf-as type field stream :indentation (+ indentation 2) :more more))))
- (t
+ &key (indentation 0) more index arity)
+ (declare (ignore more arity))
+ (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
+ (cond ((eql message-type :group)
+ ;; If we've got a group, the printer for fields has already
+ ;; printed a partial line (nice modularity, huh?)
+ (format stream "group ~A = ~D {~%" name index)
+ (let ((other (and class (not (string= name (class-name->proto class))) class)))
+ (when other
+ (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
+ (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
+ (when alias-for
+ (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
+ (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
+ (dolist (option options)
+ (format stream "~&~VToption ~:/protobuf-option/;~%"
+ (+ indentation 2) option))
(loop for (enum . more) on (proto-enums message) doing
(write-protobuf-as type enum stream :indentation (+ indentation 2) :more more))
- (loop for (msg . more) on (proto-messages message) doing
- (write-protobuf-as type msg stream :indentation (+ indentation 2) :more more))
(loop for (field . more) on (proto-fields message) doing
- (write-protobuf-as type field stream :indentation (+ indentation 2) :more more))
- (loop for (extension . more) on (proto-extensions message) doing
- (write-protobuf-as type extension stream :indentation (+ indentation 2) :more more))))
- (format stream "~&~@[~VT~]}~%"
- (and (not (zerop indentation)) indentation))))
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more :message message))
+ (format stream "~&~@[~VT~]}~%"
+ (and (not (zerop indentation)) indentation)))
+ (t
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
+ (format stream "~&~@[~VT~]~A ~A {~%"
+ (and (not (zerop indentation)) indentation)
+ (if (eql message-type :message) "message" "extend") name)
+ (let ((other (and class (not (string= name (class-name->proto class))) class)))
+ (when other
+ (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
+ (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
+ (when alias-for
+ (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
+ (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
+ (dolist (option options)
+ (format stream "~&~VToption ~:/protobuf-option/;~%"
+ (+ indentation 2) option))
+ (cond ((eql message-type :extends)
+ (loop for (field . more) on (proto-fields message) doing
+ (when (eql (proto-message-type field) :extends)
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message))))
+ (t
+ (loop for (enum . more) on (proto-enums message) doing
+ (write-protobuf-as type enum stream :indentation (+ indentation 2) :more more))
+ (loop for (msg . more) on (proto-messages message) doing
+ (unless (eql (proto-message-type msg) :group)
+ (write-protobuf-as type msg stream :indentation (+ indentation 2) :more more)))
+ (loop for (field . more) on (proto-fields message) doing
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message))
+ (loop for (extension . more) on (proto-extensions message) doing
+ (write-protobuf-as type extension stream :indentation (+ indentation 2) :more more))))
+ (format stream "~&~@[~VT~]}~%"
+ (and (not (zerop indentation)) indentation))))))
(defparameter *protobuf-field-comment-column* 56)
(defmethod write-protobuf-as ((type (eql :proto)) (field protobuf-field) stream
- &key (indentation 0) more)
+ &key (indentation 0) more message)
(declare (ignore more))
(with-prefixed-accessors (name documentation required index default packed) (proto- field)
- (let ((dflt (if (stringp default)
- (if (i= (length default) 0) nil default)
- default)))
- (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
- (and (not (zerop indentation)) indentation)
- required (proto-type field) name index dflt packed
- documentation *protobuf-field-comment-column* documentation))))
+ (let ((group (let ((msg (find-message message (proto-class field))))
+ (and msg (eql (proto-message-type msg) :group) msg)))
+ (dflt (if (stringp default)
+ (if (i= (length default) 0) nil default)
+ default)))
+ (cond (group
+ (format stream "~&~@[~VT~]~(~A~) "
+ (and (not (zerop indentation)) indentation) required)
+ (write-protobuf-as type group stream :indentation indentation :index index :arity required))
+ (t
+ (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
+ (and (not (zerop indentation)) indentation)
+ required (proto-type field) name index dflt packed
+ documentation *protobuf-field-comment-column* documentation))))))
(defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
&key (indentation 0) more)
;;; Pretty print a schema as a .lisp file
(defmethod write-protobuf-as ((type (eql :lisp)) (protobuf protobuf) stream
- &key (indentation 0) more)
- (declare (ignore more))
- (with-prefixed-accessors (name class documentation package lisp-package imports optimize options) (proto- protobuf)
- (let* ((pkg (and package (if (stringp package) package (string package))))
+ &key (indentation 0))
+ (with-prefixed-accessors (name class documentation package lisp-package imports) (proto- protobuf)
+ (let* ((optimize (let ((opt (find-option protobuf "optimize_for")))
+ (and opt (cond ((string= opt "SPEED") :speed)
+ ((string= opt "CODE_SIZE") :space)
+ (t nil)))))
+ (options (remove "optimize_for" (proto-options protobuf) :test #'string-equal :key #'proto-name))
+ (pkg (and package (if (stringp package) package (string package))))
(lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
(*protobuf-package* (or (find-package lisp-pkg)
- (find-package (string-upcase lisp-pkg))))
- (*package* (or *protobuf-package* *package*)))
+ (find-package (string-upcase lisp-pkg))
+ *package*))
+ (*package* *protobuf-package*))
(when (or lisp-pkg pkg)
(format stream "~&(in-package \"~A\")~%~%" (string-upcase (or lisp-pkg pkg))))
(when documentation
(defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
- &key (indentation 0) more)
+ &key (indentation 0) more index arity)
(declare (ignore more))
- (with-prefixed-accessors (name class alias-for conc-name extension-p documentation) (proto- message)
- (when documentation
- (write-protobuf-documentation type documentation stream :indentation indentation))
- (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
- (and (not (zerop indentation)) indentation)
- (if extension-p "extend" "message") class)
- (let ((other (and name (not (string= name (class-name->proto class))) name)))
- (cond (extension-p
- (format stream " ()"))
- ((or alias-for conc-name documentation)
- (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
+ (with-prefixed-accessors (name class alias-for conc-name message-type documentation) (proto- message)
+ (cond ((eql message-type :group)
+ (when documentation
+ (write-protobuf-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= 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~])"
(+ indentation 4)
+ index (+ indentation 5)
+ arity (and (or other alias-for conc-name documentation) (+ indentation 5))
other other (and (or alias-for conc-name documentation) (+ indentation 5))
alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
conc-name conc-name (and documentation (+ indentation 5))
documentation documentation))
- (t
- (format stream " ()"))))
- (cond (extension-p
- (loop for (field . more) on (proto-fields message) doing
- (when (proto-extension-p field)
- (write-protobuf-as type field stream :indentation (+ indentation 2) :more more)
- (when more
- (terpri stream)))))
- (t
(loop for (enum . more) on (proto-enums message) doing
(write-protobuf-as type enum stream :indentation (+ indentation 2) :more more)
(when more
(terpri stream)))
- (loop for (msg . more) on (proto-messages message) doing
- (write-protobuf-as type msg stream :indentation (+ indentation 2) :more more)
- (when more
- (terpri stream)))
(loop for (field . more) on (proto-fields message) doing
- (write-protobuf-as type field stream :indentation (+ indentation 2) :more more)
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message)
(when more
- (terpri stream)))
- (loop for (extension . more) on (proto-extensions message) doing
- (write-protobuf-as type extension stream :indentation (+ indentation 2) :more more)
- (when more
- (terpri stream)))))
+ (terpri stream))))
+ (t
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
+ (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
+ (and (not (zerop indentation)) indentation)
+ (if (eql message-type :message) "message" "extend") class)
+ (let ((other (and name (not (string= name (class-name->proto class))) name)))
+ (cond ((eql message-type :extends)
+ (format stream " ()"))
+ ((or other alias-for conc-name documentation)
+ (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
+ ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+ ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+ ~:[~*~;:documentation ~S~])"
+ (+ indentation 4)
+ other other (and (or alias-for conc-name documentation) (+ indentation 5))
+ alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
+ conc-name conc-name (and documentation (+ indentation 5))
+ documentation documentation))
+ (t
+ (format stream " ()"))))
+ (cond ((eql message-type :extends)
+ (loop for (field . more) on (proto-fields message) doing
+ (when (eql (proto-message-type field) :extends)
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message)
+ (when more
+ (terpri stream)))))
+ (t
+ (loop for (enum . more) on (proto-enums message) doing
+ (write-protobuf-as type enum stream :indentation (+ indentation 2) :more more)
+ (when more
+ (terpri stream)))
+ (loop for (msg . more) on (proto-messages message) doing
+ (unless (eql (proto-message-type msg) :group)
+ (write-protobuf-as type msg stream :indentation (+ indentation 2) :more more)
+ (when more
+ (terpri stream))))
+ (loop for (field . more) on (proto-fields message) doing
+ (write-protobuf-as type field stream
+ :indentation (+ indentation 2) :more more
+ :message message)
+ (when more
+ (terpri stream)))
+ (loop for (extension . more) on (proto-extensions message) doing
+ (write-protobuf-as type extension stream :indentation (+ indentation 2) :more more)
+ (when more
+ (terpri stream)))))))
(format stream ")")))
(defparameter *protobuf-slot-comment-column* 56)
(defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
- &key (indentation 0) more)
- (with-prefixed-accessors (value reader writer class documentation required default) (proto- field)
- (let ((dflt (protobuf-default-to-clos-init default class))
- (clss (let ((cl (case class
- ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
- :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
- ((:single) 'float)
- ((:double) 'double-float)
- ((:bool) 'boolean)
- ((:string) 'string)
- ((:symbol) 'symbol)
- (otherwise class))))
- (cond ((eq required :optional)
- `(or null ,cl))
- ((eq required :repeated)
- `(list-of ,cl))
- (t cl)))))
- (format stream (if (keywordp class)
- ;; Keyword means a primitive type, print default with ~S
- "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~]~
- ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]"
- ;; Non-keyword must mean an enum type, print default with ~A
- "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~]~
- ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]")
- (and (not (zerop indentation)) indentation)
- value clss dflt reader writer
- ;; Don't write the comment if we'll insert a close paren after it
- (and more documentation) *protobuf-slot-comment-column* documentation))))
+ &key (indentation 0) more message)
+ (with-prefixed-accessors (value reader writer class required index documentation default) (proto- field)
+ (let ((group (let ((msg (find-message message (proto-class field))))
+ (and msg (eql (proto-message-type msg) :group) msg)))
+ (dflt (protobuf-default-to-clos-init default class))
+ (clss (let ((cl (case class
+ ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
+ :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
+ ((:single) 'float)
+ ((:double) 'double-float)
+ ((:bool) 'boolean)
+ ((:string) 'string)
+ ((:symbol) 'symbol)
+ (otherwise class))))
+ (cond ((eq required :optional)
+ `(or null ,cl))
+ ((eq required :repeated)
+ `(list-of ,cl))
+ (t cl)))))
+ (cond (group
+ (write-protobuf-as type group stream :indentation indentation :index index :arity required))
+ (t
+ (format stream (if (keywordp class)
+ ;; Keyword means a primitive type, print default with ~S
+ "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~]~
+ ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]"
+ ;; Non-keyword must mean an enum type, print default with ~A
+ "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~]~
+ ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]")
+ (and (not (zerop indentation)) indentation)
+ value clss dflt reader writer
+ ;; Don't write the comment if we'll insert a close paren after it
+ (and more documentation) *protobuf-slot-comment-column* documentation))))))
(defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
&key (indentation 0) more)
"DEFINE-MESSAGE"
"DEFINE-EXTEND"
"DEFINE-EXTENSION"
+ "DEFINE-GROUP"
"DEFINE-SERVICE"
;; Upgradability testing
"PROTO-EXTENSION-TO"
"PROTO-EXTENDERS"
"PROTO-EXTENSIONS"
- "PROTO-EXTENSION-P"
"PROTO-FIELDS"
"PROTO-FUNCTION"
"PROTO-IMPORTS"
"PROTO-INPUT-NAME"
"PROTO-INPUT-TYPE"
"PROTO-LISP-PACKAGE"
+ "PROTO-MESSAGE-TYPE"
"PROTO-MESSAGES"
"PROTO-METHODS"
"PROTO-NAME"
- "PROTO-OPTIMIZE"
"PROTO-OPTIONS"
"PROTO-OUTPUT-NAME"
"PROTO-OUTPUT-TYPE"
(reader (and field (proto-reader field)))
(writer (and field (proto-writer field)))
msg)
- (if (null field)
+ (if (null field)
;; If there's no field descriptor for this index, just skip
;; the next element in the buffer having the given wire type
(setq index (skip-element buffer index tag))
(defun make-lisp-symbol (string)
"Intern a string of the 'package:string' and return the symbol."
- (let* ((colon (position #\: string))
- (pkg (if colon (subseq string 0 colon) "KEYWORD"))
- (sym (if colon (subseq string (+ colon 1)) string)))
+ (let* ((string (string string))
+ (colon (position #\: string))
+ (pkg (if colon (subseq string 0 colon) "KEYWORD"))
+ (sym (if colon (subseq string (+ colon 1)) string)))
(intern sym pkg)))
#-quux
projects / cl-protobufs.git / commitdiff