;;; Protocol buffer defining macros
;; Define a schema named 'name', corresponding to a .proto file of that name
-(defmacro define-proto (name (&key proto-name syntax package import options)
+(defmacro define-proto (name (&key proto-name syntax package import options documentation)
&body messages &environment env)
"Define a schema named 'name', corresponding to a .proto file of that name.
'proto-name' can be used to override the defaultly generated name.
:options (list ,@options)
:enums (list ,@enums)
:messages (list ,@msgs)
- :services (list ,@svcs))))
+ :services (list ,@svcs)
+ :documentation ,documentation)))
(setq ,vname protobuf)
(setf (gethash ',pname *all-protobufs*) protobuf)
(setf (gethash ',cname *all-protobufs*) protobuf)
protobuf)))))
;; Define an enum type named 'name' and a Lisp 'deftype'
-(defmacro define-enum (name (&key proto-name conc-name) &body values)
+(defmacro define-enum (name (&key proto-name conc-name options documentation) &body values)
"Define an enum type named 'name' and a Lisp 'deftype'.
'proto-name' can be used to override the defaultly generated name.
The body consists of the enum values in the form (name &key index)."
:index ,idx
:value ,val-name)))))
(collect-form `(deftype ,name () '(member ,@vals)))
- `(progn
- define-enum
- (make-instance 'protobuf-enum
- :name ,(or proto-name (class-name->proto name))
- :class ',name
- :values (list ,@evals))
- ,forms)))
+ (let ((options (loop for (key val) on options by #'cddr
+ collect `(make-instance 'protobuf-option
+ :name ,key
+ :value ,val))))
+ `(progn
+ define-enum
+ (make-instance 'protobuf-enum
+ :name ,(or proto-name (class-name->proto name))
+ :class ',name
+ :options (list ,@options)
+ :values (list ,@evals)
+ :documentation ,documentation)
+ ,forms))))
;; Define a message named 'name' and a Lisp 'defclass'
-(defmacro define-message (name (&key proto-name conc-name) &body fields &environment env)
+(defmacro define-message (name (&key proto-name conc-name options documentation)
+ &body fields &environment env)
"Define a message named 'name' and a Lisp 'defclass'.
'proto-name' can be used to override the defaultly generated name.
The body consists of fields, or 'define-enum' or 'define-message' forms.
:packed ,(and (eq reqd :repeated)
(packed-type-p pclass)))))))))))
(collect-form `(defclass ,name () (,@slots)))
- `(progn
- define-message
- (make-instance 'protobuf-message
- :name ,(or proto-name (class-name->proto name))
- :class ',name
- :conc-name ,(and conc-name (string conc-name))
- :enums (list ,@enums)
- :messages (list ,@msgs)
- :fields (list ,@flds))
- ,forms)))
+ (let ((options (loop for (key val) on options by #'cddr
+ collect `(make-instance 'protobuf-option
+ :name ,key
+ :value ,val))))
+ `(progn
+ define-message
+ (make-instance 'protobuf-message
+ :name ,(or proto-name (class-name->proto name))
+ :class ',name
+ :conc-name ,(and conc-name (string conc-name))
+ :options (list ,@options)
+ :enums (list ,@enums)
+ :messages (list ,@msgs)
+ :fields (list ,@flds)
+ :documentation ,documentation)
+ ,forms))))
(defmacro define-extension (from to)
"Define an extension range within a message.
()))
;; Define a service named 'name' and a Lisp 'defun'
-(defmacro define-service (name (&key proto-name) &body rpc-specs)
+(defmacro define-service (name (&key proto-name options documentation) &body rpc-specs)
"Define a service named 'name' and a Lisp 'defun'.
'proto-name' can be used to override the defaultly generated name.
The body consists of a set of RPC specs of the form (name input-type output-type)."
:input-type ,(and input-type (class-name->proto input-type))
:output-type ,(and output-type (class-name->proto output-type))
:options (list ,@options))))))
- `(progn
- define-service
- (make-instance 'protobuf-service
- :name ,(or proto-name (class-name->proto name))
- :class ',name
- :rpcs (list ,@rpcs))
- ()))) ;---*** DEFINE LISP STUB HERE
+ (let ((options (loop for (key val) on options by #'cddr
+ collect `(make-instance 'protobuf-option
+ :name ,key
+ :value ,val))))
+ `(progn
+ define-service
+ (make-instance 'protobuf-service
+ :name ,(or proto-name (class-name->proto name))
+ :class ',name
+ :options (list ,@options)
+ :rpcs (list ,@rpcs)
+ :documentation ,documentation)
+ ())))) ;---*** define Lisp stub here
#||
(proto:define-proto color-wheel (:package ita.color
- :import "descriptor.proto")
- (proto:define-enum color-name ()
+ :import "descriptor.proto"
+ :documentation "Color wheel example")
+ (proto:define-enum color-name (:documentation "A color name")
red
green
blue)
- (proto:define-message color (:conc-name color-)
- (proto:define-enum contrast-name ()
+ (proto:define-message color (:conc-name color-
+ :documentation "Color and constrast")
+ (proto:define-enum contrast-name (:documentation "A contrast name")
(low 1)
(high 100))
(color :type color-name)
(contrast :type (or null contrast-name) :default :low))
- (proto:define-service color-wheel ()
+ (proto:define-service color-wheel (:documentation "Get and set colors")
(get-color nil color)
(set-color color color :options ("deadline" "1.0"))))
;;; Protol buffers model classes
-(defvar *all-protobufs* (make-hash-table :test #'equal))
+(defvar *all-protobufs* (make-hash-table :test #'equal)
+ "A table mapping names to 'protobuf' schemas.")
+
(defun find-protobuf (name)
+ "Given a name (a string or a symbol), return the 'protobuf' schema having that name."
(gethash name *all-protobufs*))
;; A few things (the pretty printer) want to keep track of the current schema
(defvar *protobuf* nil)
-;; The protobuf, corresponds to one .proto file
-(defclass protobuf ()
- ((name :type (or null string) ;the name of this .proto file
+;;; The model classes
+
+(defclass abstract-protobuf () ())
+
+(defclass base-protobuf (abstract-protobuf)
+ ((name :type (or null string) ;the name of this .proto file/enum/message, etc
:reader proto-name
:initarg :name
:initform nil)
- (class :type (or null symbol) ;a "class name" for this protobuf, for Lisp
+ (class :type (or null symbol) ;a Lisp "class name" for this object
:accessor proto-class
:initarg :class
:initform nil)
- (syntax :type (or null string) ;syntax, passed on but otherwise ignored
+ (options :type (list-of protobuf-option) ;options, mostly just passed along
+ :accessor proto-options
+ :initarg :options
+ :initform ())
+ (doc :type (or null string) ;documentation for this object
+ :accessor proto-documentation
+ :initarg :documentation
+ :initform nil))
+ (:documentation
+ "The base class for all Protobufs model classes."))
+
+
+;; The protobuf, corresponds to one .proto file
+(defclass protobuf (base-protobuf)
+ ((syntax :type (or null string) ;syntax, passed on but otherwise ignored
:accessor proto-syntax
:initarg :syntax
:initform nil)
:accessor proto-imports
:initarg :imports
:initform ())
- (options :type (list-of protobuf-option) ;options, passed on but otherwise ignored
- :accessor proto-options
- :initarg :options
- :initform ())
(enums :type (list-of protobuf-enum) ;the set of enum types
:accessor proto-enums
:initarg :enums
:initarg :services
:initform ()))
(:documentation
- "The model class that represents a protobufs schema, i.e., one .proto file."))
+ "The model class that represents a Protobufs schema, i.e., one .proto file."))
(defmethod print-object ((p protobuf) stream)
(print-unprintable-object (p stream :type t :identity t)
(some #'(lambda (msg) (find-enum-for-type msg type)) (proto-messages protobuf))))
-;;--- For now, we support only the built-in options in the .proto file
-;;--- and in RPCs. We will want to extend this to custom options.
-(defclass protobuf-option ()
+;;--- For now, we support only the built-in options.
+;;--- We will want to extend this to customizable options as well.
+(defclass protobuf-option (abstract-protobuf)
((name :type string ;the key
:reader proto-name
:initarg :name)
:initarg :value
:initform nil))
(:documentation
- "The model class that represents a protobufs options, i.e., a keyword/value pair."))
+ "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
(defmethod print-object ((o protobuf-option) stream)
(print-unprintable-object (o stream :type t :identity t)
(format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
(defun cl-user::protobuf-option (stream option colon-p atsign-p)
- (declare (ignore colon-p atsign-p))
- (format stream "~A~@[ = ~S~]" (proto-name option) (proto-value option)))
+ (declare (ignore atsign-p))
+ (if colon-p
+ (format stream "~A~@[ = ~S~]" (proto-name option) (proto-value option))
+ (format stream "~(:~A~) ~S" (proto-name option) (proto-value option))))
;; A protobuf enumeration
-(defclass protobuf-enum ()
- ((name :type string ;the Protobuf name for the enum type
- :reader proto-name
- :initarg :name)
- (class :type (or null symbol) ;the Lisp type it represents
- :accessor proto-class
- :initarg :class
- :initform nil)
- (values :type (list-of protobuf-enum-value) ;all the values for this enum type
+(defclass protobuf-enum (base-protobuf)
+ ((values :type (list-of protobuf-enum-value) ;all the values for this enum type
:accessor proto-values
:initarg :values
- :initform ())
- (comment :type (or null string)
- :accessor proto-comment
- :initarg :comment
- :initform nil))
+ :initform ()))
(:documentation
- "The model class that represents a protobufs enumeration type."))
+ "The model class that represents a Protobufs enumeration type."))
(defmethod print-object ((e protobuf-enum) stream)
(print-unprintable-object (e stream :type t :identity t)
;; A protobuf value within an enumeration
-(defclass protobuf-enum-value ()
- ((name :type string ;the name of the enum value
- :reader proto-name
- :initarg :name)
- (index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
+(defclass protobuf-enum-value (base-protobuf)
+ ((index :type (integer #.(- (ash 1 31)) #.(1- (ash 1 31)))
:accessor proto-index ;the index of the enum value
:initarg :index)
(value :type (or null symbol)
:initarg :value
:initform nil))
(:documentation
- "The model class that represents a protobufs enumeration value."))
+ "The model class that represents a Protobufs enumeration value."))
(defmethod print-object ((v protobuf-enum-value) stream)
(print-unprintable-object (v stream :type t :identity t)
;; A protobuf message
-(defclass protobuf-message ()
- ((name :type string ;the Protobuf name for the message
- :reader proto-name
- :initarg :name)
- (class :type (or null symbol) ;the Lisp class it represents
- :accessor proto-class
- :initarg :class
- :initform nil)
- (conc :type (or null string) ;the conc-name used for Lisp accessors
+(defclass protobuf-message (base-protobuf)
+ ((conc :type (or null string) ;the conc-name used for Lisp accessors
:accessor proto-conc-name
:initarg :conc-name
:initform nil)
(extensions :type (list-of protobuf-extension) ;any extensions
:accessor proto-extensions
:initarg :extensions
- :initform ())
- (comment :type (or null string)
- :accessor proto-comment
- :initarg :comment
- :initform nil))
+ :initform ()))
(:documentation
- "The model class that represents a protobufs message."))
+ "The model class that represents a Protobufs message."))
(defmethod print-object ((m protobuf-message) stream)
(print-unprintable-object (m stream :type t :identity t)
;; A protobuf field within a message
-(defclass protobuf-field ()
- ((name :type string ;the Protobuf name for the field
- :accessor proto-name
- :initarg :name)
- (type :type string ;the name of the Protobuf type for the field
+(defclass protobuf-field (base-protobuf)
+ ((type :type string ;the name of the Protobuf type for the field
:accessor proto-type
:initarg :type)
- (class :type (or null symbol) ;the Lisp class (or a keyword such as :fixed64)
- :accessor proto-class
- :initarg :class
- :initform nil)
(required :type (member :required :optional :repeated)
:accessor proto-required
:initarg :required)
:accessor proto-value
:initarg :value
:initform nil)
- (default :type (or null string)
+ (default :type (or null string) ;default value, pulled out of the options
:accessor proto-default
:initarg :default
:initform nil)
- (packed :type (member t nil)
+ (packed :type (member t nil) ;packed, pulled out of the options
:accessor proto-packed
:initarg :packed
- :initform nil)
- (comment :type (or null string)
- :accessor proto-comment
- :initarg :comment
- :initform nil))
+ :initform nil))
(:documentation
- "The model class that represents one field within a protobufs message."))
+ "The model class that represents one field within a Protobufs message."))
(defmethod print-object ((f protobuf-field) stream)
(print-unprintable-object (f stream :type t :identity t)
;; An extension within a message
;;--- We still need to support 'extend', which depends on supporting 'import'
-(defclass protobuf-extension ()
+(defclass protobuf-extension (abstract-protobuf)
((from :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
:accessor proto-extension-from
:initarg :from)
:accessor proto-extension-to
:initarg :to))
(:documentation
- "The model class that represents an extension with a protobufs message."))
+ "The model class that represents an extension with a Protobufs message."))
(defmethod print-object ((e protobuf-extension) stream)
(print-unprintable-object (e stream :type t :identity t)
;; A protobuf service
-(defclass protobuf-service ()
- ((name :type string ;the Protobuf name for the service
- :reader proto-name
- :initarg :name)
- (class :type (or null symbol) ;a "class name" for this service, for Lisp
- :accessor proto-class
- :initarg :class
- :initform nil)
- (rpcs :type (list-of protobuf-rpc) ;the RPCs in the service
+(defclass protobuf-service (base-protobuf)
+ ((rpcs :type (list-of protobuf-rpc) ;the RPCs in the service
:accessor proto-rpcs
:initarg :rpcs
- :initform ())
- (comment :type (or null string)
- :accessor proto-comment
- :initarg :comment
- :initform nil))
+ :initform ()))
(:documentation
- "The model class that represents a protobufs service."))
+ "The model class that represents a Protobufs service."))
(defmethod print-object ((s protobuf-service) stream)
(print-unprintable-object (s stream :type t :identity t)
;; A protobuf RPC within a service
-(defclass protobuf-rpc ()
- ((name :type string ;the Protobuf name for the RPC
- :reader proto-name
- :initarg :name)
- (class :type (or null symbol) ;a "class name" for this RPC, for Lisp
- :accessor proto-class
- :initarg :class
- :initform nil)
- (itype :type (or null string) ;the name of the input message type
+(defclass protobuf-rpc (base-protobuf)
+ ((itype :type (or null string) ;the name of the input message type
:accessor proto-input-type
:initarg :input-type)
(iclass :type (or null symbol) ;the name of the input message type
:initarg :output-type)
(oclass :type (or null symvol) ;the name of the output message type
:accessor proto-output-class
- :initarg :output-class)
- (options :type (list-of protobuf-option) ;options, passed on but otherwise ignored
- :accessor proto-options
- :initarg :options
- :initform ())
- (comment :type (or null string)
- :accessor proto-comment
- :initarg :comment
- :initform nil))
+ :initarg :output-class))
(:documentation
- "The model class that represents one RPC with a protobufs service."))
+ "The model class that represents one RPC with a Protobufs service."))
(defmethod print-object ((r protobuf-rpc) stream)
(print-unprintable-object (r stream :type t :identity t)
until (or (null ch) (not (proto-whitespace-char-p ch)))
do (read-char stream nil)))
-(defun skip-comment (stream)
- "Skip to the end of a comment, that is, to the end of the line.
+;;--- Collect the comment so we can attach it to its associated object
+(defun maybe-skip-comments (stream)
+ "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)
+ (read-char stream)
+ (case (peek-char nil stream nil)
+ ((#\/)
+ (skip-line-comment stream))
+ ((#\*)
+ (skip-block-comment stream))
+ (otherwise
+ (error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
+ #\/ (file-position stream) #\/ #\*)))))
+ (skip-whitespace stream))
+
+(defun skip-line-comment (stream)
+ "Skip to the end of a line comment, that is, to the end of the line.
Then skip any following whitespace."
(loop for ch = (read-char stream nil)
until (or (null ch) (proto-eol-char-p ch)))
(skip-whitespace stream))
-(defun maybe-skip-comments (stream)
- "If what appears next in the stream is a comment, skip it and any following comments,
- then skip any following whitespace."
- (when (eql (peek-char nil stream nil) #\/)
- (read-char stream)
- (if (eql (peek-char nil stream nil) #\/)
- (skip-comment stream)
- (error "Found a '~C' at position ~D to start a comment, but no following '~C'"
- #\/ (file-position stream) #\/)))
+(defun skip-block-comment (stream)
+ "Skip to the end of a block comment, that is, until a '*/' is seen.
+ Then skip any following whitespace."
+ (loop for ch = (read-char stream nil)
+ do (cond ((null ch)
+ (error "Premature end of file while skipping block comment"))
+ ((and (eql ch #\*)
+ (eql (peek-char nil stream nil) #\/))
+ (read-char stream nil)
+ (return))))
(skip-whitespace stream))
(defun expect-char (stream ch &optional within)
(defun parse-protobuf-from-file (filename)
- "Parses the named file as a .proto file, and returns the protobufs schema."
+ "Parses the named file as a .proto file, and returns the Protobufs schema."
(with-open-file (stream filename
:direction :input
:external-format :utf-8
(defgeneric write-protobuf-as (type protobuf stream &key indentation)
(:documentation
"Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
- the given stream 'stream'in the format given by 'type' (:proto, :text, etc)."))
+ the given stream 'stream' in the format given by 'type' (:proto, :text, etc)."))
+
+(defgeneric write-protobuf-documentation (type docstring stream &key indentation)
+ (:documentation
+ "Writes a the docstring as a \"block comment\" onto the given stream 'stream'
+ in the format given by 'type' (:proto, :text, etc)."))
;;; Pretty print as a .proto file
(defmethod write-protobuf-as ((type (eql :proto)) (protobuf protobuf) stream
&key (indentation 0))
- (with-prefixed-accessors (name class syntax package imports options) (proto- protobuf)
+ (with-prefixed-accessors (name class documentation syntax package imports options) (proto- protobuf)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(when syntax
(format stream "~&syntax = \"~A\";~%~%" syntax))
(when package
(terpri stream))
(when options
(dolist (option options)
- (format stream "~&option ~A~@[ = ~S~];~%" (proto-name option) (proto-value option)))
+ (format stream "~&option ~:/protobuf-option/;~%" option))
(terpri stream))
(dolist (enum (proto-enums protobuf))
(write-protobuf-as type enum stream :indentation indentation)
(write-protobuf-as type svc stream :indentation indentation)
(terpri stream))))
+(defmethod write-protobuf-documentation ((type (eql :proto)) docstring stream
+ &key (indentation 0))
+ (let ((lines (split-string docstring :separators '(#\newline #\return))))
+ (dolist (line lines)
+ (format stream "~&~@[~VT~]// ~A~%"
+ (and (not (zerop indentation)) indentation) line))))
+
(defmethod write-protobuf-as ((type (eql :proto)) (enum protobuf-enum) stream
&key (indentation 0))
- (with-prefixed-accessors (comment name) (proto- enum)
- (when comment
- (format stream "~&~@[~VT~]// ~A~%"
- (and (not (zerop indentation)) indentation) comment))
+ (with-prefixed-accessors (name documentation) (proto- enum)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~]enum ~A {~%"
(and (not (zerop indentation)) indentation) name)
(dolist (value (proto-values enum))
(format stream "~&~@[~VT~]}~%"
(and (not (zerop indentation)) indentation))))
+(defparameter *protobuf-enum-comment-column* 56)
(defmethod write-protobuf-as ((type (eql :proto)) (val protobuf-enum-value) stream
&key (indentation 0))
- (with-prefixed-accessors (name index) (proto- val)
- (format stream "~&~@[~VT~]~A = ~D;~%"
- (and (not (zerop indentation)) indentation) name index)))
+ (with-prefixed-accessors (name documentation index) (proto- val)
+ (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
+ (and (not (zerop indentation)) indentation) name index
+ documentation *protobuf-enum-comment-column* documentation)))
(defmethod write-protobuf-as ((type (eql :proto)) (message protobuf-message) stream
&key (indentation 0))
- (with-prefixed-accessors (comment name) (proto- message)
- (when comment
- (format stream "~&~@[~VT~]// ~A~%"
- (and (not (zerop indentation)) indentation) comment))
+ (with-prefixed-accessors (name documentation) (proto- message)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~]message ~A {~%"
(and (not (zerop indentation)) indentation) name)
(dolist (enum (proto-enums message))
(defparameter *protobuf-field-comment-column* 56)
(defmethod write-protobuf-as ((type (eql :proto)) (field protobuf-field) stream
&key (indentation 0))
- (with-prefixed-accessors (name type required index default packed comment) (proto- field)
+ (with-prefixed-accessors (name type documentation required index default packed) (proto- field)
(let ((dflt (if (stringp default)
(if (string-empty-p default) nil default)
default)))
(format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
(and (not (zerop indentation)) indentation)
required type name index dflt packed
- comment *protobuf-field-comment-column* comment))))
+ documentation *protobuf-field-comment-column* documentation))))
(defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
&key (indentation 0))
(defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
&key (indentation 0))
- (with-prefixed-accessors (comment name) (proto- service)
- (when comment
- (format stream "~&~@[~VT~]// ~A~%"
- (and (not (zerop indentation)) indentation) comment))
+ (with-prefixed-accessors (name doc documentation) (proto- service)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~]service ~A {~%"
(and (not (zerop indentation)) indentation) name)
(dolist (rpc (proto-rpcs service))
(defmethod write-protobuf-as ((type (eql :proto)) (rpc protobuf-rpc) stream
&key (indentation 0))
- (with-prefixed-accessors (name input-type output-type options) (proto- rpc)
+ (with-prefixed-accessors (name documentation input-type output-type options) (proto- rpc)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
(and (not (zerop indentation)) indentation)
name input-type output-type)
(cond (options
(format stream " {~%")
(dolist (option options)
- (format stream "~&~@[~VT~]option ~A~@[ = ~S~];~%"
- (+ indentation 2)
- (proto-name option) (proto-value option)))
+ (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
+ (+ indentation 2) option))
(format stream "~@[~VT~]}"
(and (not (zerop indentation)) indentation)))
(t
(defmethod write-protobuf-as ((type (eql :lisp)) (protobuf protobuf) stream
&key (indentation 0))
- (declare (ignore indentation))
- (with-prefixed-accessors (name class package imports options) (proto- protobuf)
+ (with-prefixed-accessors (name class documentation package imports options) (proto- protobuf)
(when package
(format stream "~&(in-package \"~A\")~%~%" package))
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&(proto:define-proto ~(~A~)" (or class name))
- (if (or package imports options)
+ (if (or package imports options documentation)
(format stream "~% (")
(format stream " ("))
(let ((spaces ""))
(when package
(format stream "~A:package ~A" spaces package)
- (when (or imports options)
+ (when (or imports options documentation)
(terpri stream))
(setq spaces " "))
(when imports
(format stream "~A:import (" spaces)
(format stream "~{\"~A\"~^ ~}" imports)
(format stream ")")))
- (when options
+ (when (or options documentation)
(terpri stream))
(setq spaces " "))
(when options
(format stream "~A:options (" spaces)
(format stream "~{~/protobuf-option/~^ ~}" options)
- (format stream ")~%"))))
+ (when documentation
+ (terpri stream))
+ (setq spaces " "))
+ (when documentation
+ (format stream "~A:documentation ~S" spaces documentation))
+ (format stream ")")))
(format stream ")")
(dolist (enum (proto-enums protobuf))
(write-protobuf-as type enum stream :indentation 2))
(write-protobuf-as type svc stream :indentation 2))
(format stream ")~%"))
+(defmethod write-protobuf-documentation ((type (eql :lisp)) docstring stream
+ &key (indentation 0))
+ (let ((lines (split-string docstring :separators '(#\newline #\return))))
+ (dolist (line lines)
+ (format stream "~&~@[~VT~];; ~A~%"
+ (and (not (zerop indentation)) indentation) line))))
+
(defmethod write-protobuf-as ((type (eql :lisp)) (enum protobuf-enum) stream
&key (indentation 0))
(terpri stream)
- (with-prefixed-accessors (comment class) (proto- enum)
- (when comment
- (format stream "~@[~VT~];; ~A~%"
- (and (not (zerop indentation)) indentation) comment))
- (format stream "~@[~VT~](proto:define-enum ~(~S~) ()"
+ (with-prefixed-accessors (class documentation) (proto- enum)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
+ (format stream "~@[~VT~](proto:define-enum ~(~S~)"
(and (not (zerop indentation)) indentation) class)
+ (cond (documentation
+ (format stream "~%~@[~VT~](:documentation ~S)"
+ (+ indentation 4) documentation))
+ (t
+ (format stream " ()")))
(loop for (value . more) on (proto-values enum) doing
(write-protobuf-as type value stream :indentation (+ indentation 2))
(when more
(defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
&key (indentation 0))
- (with-prefixed-accessors (comment class conc-name) (proto- message)
- (when comment
- (format stream "~&~@[~VT~];; ~A~%"
- (and (not (zerop indentation)) indentation) comment))
+ (with-prefixed-accessors (class conc-name documentation) (proto- message)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~](proto:define-message ~(~S~)"
(and (not (zerop indentation)) indentation) class)
- (if conc-name
+ (if (or conc-name documentation)
(format stream "~%~VT(" (+ indentation 4))
(format stream " ("))
- (when conc-name
- (format stream ":conc-name ~(~A~)" conc-name))
+ (when (or conc-name documentation)
+ (when conc-name
+ (format stream ":conc-name ~(~A~)" conc-name))
+ (when documentation
+ (if conc-name
+ (format stream "~%~VT:documentation ~S"
+ (+ indentation 5) documentation)
+ (format stream ":documentation ~S" documentation))))
(format stream ")")
(loop for (enum . more) on (proto-enums message) doing
(write-protobuf-as type enum stream :indentation (+ indentation 2))
(defparameter *protobuf-slot-comment-column* 56)
(defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
&key (indentation 0))
- (with-prefixed-accessors (value type class required default comment) (proto- field)
+ (with-prefixed-accessors (value type class documentation required default) (proto- field)
(let ((dflt (cond ((or (null default)
(and (stringp default) (string-empty-p default)))
nil)
"~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~])~:[~*~*~;~VT; ~A~]")
(and (not (zerop indentation)) indentation)
value clss dflt
- comment *protobuf-slot-comment-column* comment))))
+ documentation *protobuf-slot-comment-column* documentation))))
(defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
&key (indentation 0))
(defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
&key (indentation 0))
- (with-prefixed-accessors (comment class conc-name) (proto- service)
- (when comment
- (format stream "~&~@[~VT~];; ~A~%"
- (and (not (zerop indentation)) indentation) comment))
- (format stream "~&~@[~VT~](proto:define-service ~(~S~) ()"
+ (with-prefixed-accessors (class documentation conc-name) (proto- service)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
+ (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
(and (not (zerop indentation)) indentation) (proto-class service))
+ (cond (documentation
+ (format stream "~%~@[~VT~](:documentation ~S)"
+ (+ indentation 4) documentation))
+ (t
+ (format stream " ()")))
(loop for (rpc . more) on (proto-rpcs service) doing
(write-protobuf-as type rpc stream :indentation (+ indentation 2))
(when more
(defmethod write-protobuf-as ((type (eql :lisp)) (rpc protobuf-rpc) stream
&key (indentation 0))
- (with-prefixed-accessors (class input-type output-type options) (proto- rpc)
+ (with-prefixed-accessors (class documentation input-type output-type options) (proto- rpc)
+ (when documentation
+ (write-protobuf-documentation type documentation stream :indentation indentation))
(let ((in (find-message-for-class *protobuf* input-type))
(out (find-message-for-class *protobuf* output-type)))
(format stream "~&~@[~VT~](~(~S~) ~(~S~) ~(~S~)"
(and (not (zerop indentation)) indentation) class
(if in (proto-class in) input-type)
(if out (proto-class out) output-type))
- (cond (options
- (format stream "~%~VT:options ("
- (+ indentation 3))
- (loop for (option . more) on options doing
- (format stream "~S ~S"
- (proto-name option) (proto-value option))
- (when more
- (format stream " ")))
- (format stream "))"))
- (t
- (format stream ")"))))))
+ (when options
+ (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
+ (+ indentation 2) options))
+ (format stream ")"))))
(:export
;; Model class protocol
+ "ABSTRACT-PROTOBUF"
+ "BASE-PROTOBUF"
"PROTO-CLASS"
- "PROTO-COMMENT"
"PROTO-DEFAULT"
+ "PROTO-DOCUMENTATION"
"PROTO-ENUM-NAME"
"PROTO-ENUMS"
"PROTO-EXTENSION-FROM"
;; that has the field, but our current message does not
;; We still have to deserialize everything, though
(slot (proto-value field)))
- ;;---*** Check for mismatched types, running past end of buffer, etc
+ ;;--- Check for mismatched types, running past end of buffer, etc
(declare (ignore type))
(cond ((eq (proto-required field) :repeated)
(cond ((and (proto-packed field) (packed-type-p cl))
(deserialize-prim cl field buffer index)
(setq index idx)
(when slot
- (setf (slot-value object slot) (nconc (slot-value object slot) (list val))))))
+ (setf (slot-value object slot)
+ (nconc (slot-value object slot) (list val))))))
((typep msg 'protobuf-enum)
(multiple-value-bind (val idx)
(deserialize-enum msg field buffer index)
(setq index idx)
(when slot
- (setf (slot-value object slot) (nconc (slot-value object slot) (list val))))))
+ (setf (slot-value object slot)
+ (nconc (slot-value object slot) (list val))))))
((typep msg 'protobuf-message)
(multiple-value-bind (len idx)
(decode-uint32 buffer index)
(setq index idx)
(let ((obj (deserialize cl (cons msg trace) (+ index len))))
(when slot
- (setf (slot-value object slot) (nconc (slot-value object slot) (list obj)))))))))
+ (setf (slot-value object slot)
+ (nconc (slot-value object slot) (list obj)))))))))
(t
(cond ((keywordp cl)
(multiple-value-bind (val idx)
(defmethod protobuf-upgradable ((old protobuf-field) (new protobuf-field))
(flet ((arity-upgradable (old new)
- ;;--- We need to handle conversions between non-required fields and extensions
+ ;;--- Handle conversions between non-required fields and extensions
(or (eq old new)
(not (eq new :required))))
(type-upgradable (old new)
- ;;--- We need to handle conversions between embedded messages and bytes
+ ;;--- Handle conversions between embedded messages and bytes
(or
(string= old new)
;; These varint types are all compatible
;; Serialize 'val' of primitive type 'type' into the buffer
(defun serialize-prim (val type field buffer index)
- "Serializes a protobufs primitive (scalar) value into the buffer at the given index.
+ "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
The value is given by 'val', the primitive type by 'type'.
'field' is the protobuf-field describing the value.
Modifies the buffer in place, and returns the new index into the buffer."
;; Serialize 'val' of enum type 'type' into the buffer
(defun serialize-enum (val enum field buffer index)
- "Serializes a protobufs enum value into the buffer at the given index.
+ "Serializes a Protobufs enum value into the buffer at the given index.
The value is given by 'val', the enum type by 'enum'.
'field' is the protobuf-field describing the value.
Modifies the buffer in place, and returns the new index into the buffer."
(declare (type fixnum index)
(type (simple-array (unsigned-byte 8)) buffer))
(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
- ;;---*** DO ENCODING OF SINGLE FLOATS
+ ;;---*** Do encoding of single floats
val buffer index))
(defun encode-double (val buffer index)
(declare (type fixnum index)
(type (simple-array (unsigned-byte 8)) buffer))
(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
- ;;---*** DO ENCODING OF DOUBLE FLOATS
+ ;;---*** Do encoding of double floats
val buffer index))
(defun encode-octets (octets buffer index)
(declare (type fixnum index)
(type (simple-array (unsigned-byte 8)) buffer))
(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
- ;;---*** DO DECODING OF SINGLE FLOATS
+ ;;---*** Do decoding of single floats
buffer index))
(defun decode-double (buffer index)
(declare (type fixnum index)
(type (simple-array (unsigned-byte 8)) buffer))
(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
- ;;---*** DO DECODING OF DOUBLE FLOATS
+ ;;---*** Do decoding of double floats
buffer index))
(defun decode-octets (buffer index)
projects / cl-protobufs.git / commitdiff