Commit 05a12c0f authored by Howard Shrobe's avatar Howard Shrobe

Howies updates

parent a6bd7c6b
......@@ -8,7 +8,9 @@
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defsystem "cl-protobufs"
(in-package :asdf)
(asdf:defsystem "cl-protobufs"
:name "CL Protobufs"
:author "Scott McKay"
:version "1.0"
......
......@@ -361,7 +361,11 @@
((not (or type-enum (equal type expanded-type)))
(clos-type-to-protobuf-type expanded-type))
(t
(lisp-type-to-protobuf-type type)))))
(multiple-value-bind (name class) (lisp-type-to-protobuf-type type)
(values name
;; always return class-name as opposed to actual class
(if (typep class 'class) (class-name class) class))
)))))
(defun lisp-type-to-protobuf-type (type)
(case type
......
......@@ -235,11 +235,11 @@
(dolist (field fields)
(case (car field)
((define-enum define-message define-extend define-extension define-group
define-type-alias)
define-type-alias)
(destructuring-bind (&optional progn model-type model definers extra-field extra-slot)
(macroexpand-1 field env)
(assert (eq progn 'progn) ()
"The macroexpansion for ~S failed" field)
"The macroexpansion for ~S failed" field)
(map () #'collect-form definers)
(ecase model-type
((define-enum)
......@@ -259,21 +259,49 @@
(appendf (proto-fields *protobuf*) (list extra-field)))
((define-extension)
(appendf (proto-extensions *protobuf*) (list model))))))
(protobuf-oneof
(destructuring-bind (name options . oneof-fields) (rest field)
(let* ((message *protobuf*)
(source-location (getf options :source-location))
(qualified-name (getf options :qualified-name))
(oneof (make-instance 'protobuf-oneof
:class name
:name (getf options :name)
:qualified-name qualified-name
:parent message
:source-location source-location
)))
(appendf (proto-oneofs message) (list oneof))
(loop with processed-fields = nil
for oneof-field in oneof-fields
do (multiple-value-bind (field slot idx)
(process-field oneof-field index :conc-name conc-name :alias-for alias-for)
(assert (not (find-field *protobuf* (proto-index field))) ()
"The field ~S overlaps with another field in ~S"
(proto-value field) (proto-class *protobuf*))
(push field processed-fields)
(setq index idx)
(when slot
(collect-slot slot))
(appendf (proto-fields *protobuf*) (list field))
(appendf (proto-fields oneof) (list field))
))
)))
(otherwise
(multiple-value-bind (field slot idx)
(process-field field index :conc-name conc-name :alias-for alias-for)
(assert (not (find-field *protobuf* (proto-index field))) ()
"The field ~S overlaps with another field in ~S"
(proto-value field) (proto-class *protobuf*))
"The field ~S overlaps with another field in ~S"
(proto-value field) (proto-class *protobuf*))
(setq index idx)
(when slot
(collect-slot slot))
(appendf (proto-fields *protobuf*) (list field))))))
(if alias-for
;; If we've got an alias, define 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-type-form `(deftype ,type () ',alias-for)))
;; If we've got an alias, define 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-type-form `(deftype ,type () ',alias-for)))
;; If no alias, define the class now
(collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message)
,slots
......
......@@ -380,6 +380,17 @@
;; A Protobufs enumeration
(defclass protobuf-oneof (base-protobuf)
((fields :type (list-of protobuf-field) ;all the fields of this message
:accessor proto-fields ;this includes local ones and extended ones
:initarg :fields
:initform ()))
(:documentation
"The model class that represents a Protobufs oneof type."))
(defmethod make-load-form ((oneof protobuf-oneof) &optional environment)
(make-load-form-saving-slots oneof :environment environment))
(defclass protobuf-enum (base-protobuf)
((alias :type (or null symbol) ;use this if you want to make this enum
:accessor proto-alias-for ; be an alias for an existing Lisp enum
......@@ -463,6 +474,10 @@
:accessor proto-fields ;this includes local ones and extended ones
:initarg :fields
:initform ())
(oneofs :type (list-of protobuf-oneof)
:accessor proto-oneofs
:initarg :oneofs
:initform ())
(extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
:accessor proto-extended-fields
:initform ())
......@@ -575,6 +590,9 @@
(declare (ignore relative-to))
(find index (proto-fields message) :key #'proto-index))
(defmethod proto-syntax ((message protobuf-message))
(proto-syntax (proto-parent message)))
;; Extensions protocol
(defgeneric get-extension (object slot)
......@@ -639,7 +657,12 @@
(message-type :type (member :message :group :extends)
:accessor proto-message-type
:initarg :message-type
:initform :message))
:initform :message)
(oneof :type (or null proto-oneof)
:accessor proto-oneof
:initarg :oneof
:initform nil)
)
(:documentation
"The model class that represents one field within a Protobufs message."))
......@@ -650,6 +673,74 @@
(not (<= 19000 (proto-index field) 19999))) ()
"Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Special Hack for Allegro
;;;
;;; The "class" slot of a field might contain an actual class object (see more below)
;;;
;;; The base method below will do the right thing in all Lisps;
;;; Except in Allegro where in some situations it will cause an error
;;;
;;; The situation is when a Message type is defined and used in the same file
;;; In that case there's a subtle problem in the way the code in define-proto works.
;;; That code zt macro-expansion time generates both a tree structured object -- the Schema --
;;; as well as a bunch of defclass forms for all the message types in the file.
;;;
;;; The actual form to be compiled into fasl form contains both the class defs (first)
;;; followed by the schema object.
;;;
;;; The compiler eventually winds up calling make-load-form on the Schema object which
;;; recursively calls make-load form on each message object and each field object
;;; in the schema.
;;;
;;; Now, the schema object is built during macroexpansion time
;;; while constructing the forms to be compiled.
;;; So the class objects in the class slot of the field objects are found before the defclass forms are evaluated.
;;;
;;; As a result, these classes are not the same classes as those in the compiler environment
;;; at the time that make-load-form is called on the Schema object.
;;;
;;; Allegro has a check for that (labelled with a bug number) that signals an error.
;;;
;;; Note on the class field:
;;; If type of a field specificatoin in the define-message is a symbol naming an existing class, then the
;;; class slot of the field object in the Schema will be that class.
;;; If it's symbol naming a non-existent class then the slot will contain the symbol
;;; (and in this case it should be an error, I think)
;;; But if the type is (list-of symbol) where symbol names an existing class, then
;;; the class slot holds the symbol not the class object!!!!
;;; and the required slot is :repeated
;;; If it's another compound type such as and, or, member
;;; Then: For OR it will be the class(es)
;;; for AND it will be the symbol
;;; for Member it will be a symbol (or string?)
;;; The difference is whether it calls clos-type-to-protobuf-type, lisp-type-to-protobuf-type
;;; or class-name->proto (member).
;;;
;;; I have no idea why this is true, and whether this matters to wire format reading or generation
;;; A quick perusal of the serialize and deserialize code indicates that it doesn't matter whether it's
;;; a symbol or a class. It's always used by calling find-message which can be called with either.
;;;
;;; In any event this now generates a fasl
;;; that will recreate the Schema as it existed (subject to these wacko variations
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+Allegro
(defmethod make-load-form :around ((f protobuf-field) &optional environment)
(if (or (not (slot-boundp f 'class))
(symbolp (slot-value f 'class)))
(call-next-method f environment)
(multiple-value-bind (create init) (call-next-method)
(loop for pairs on (rest init) by #'cddr
for (nil nil name) = (first pairs)
for (nil object) = (second pairs)
when (equal name ''class)
do (setf (second pairs) `(find-class ',(class-name object)))
(return))
(values create init))))
(defmethod make-load-form ((f protobuf-field) &optional environment)
(make-load-form-saving-slots f :environment environment))
......
......@@ -448,6 +448,75 @@
;; If nothing to graft the option into, just return it as the value
(values option terminator)))))
(defun parse-proto-oneof (stream message)
"Parse a Messages 'oneof' from 'stream'.
Updates the 'message-schema' or 'message-message' object to have the oneof"
(check-type message protobuf-message)
(let* ((loc (file-position stream))
(name (prog1 (parse-token stream)
(expect-char stream #\{ () "oneof")
(maybe-skip-comments stream)))
(oneof (make-instance 'protobuf-oneof
:class (proto->class-name name *protobuf-package*)
:name (proto->slot-name name *protobuf-package*)
:qualified-name (make-qualified-name message name)
:parent message
:source-location (make-source-location stream loc (i+ loc (length name))))))
(loop
(let ((type (parse-token stream)))
(when (null type)
(expect-char stream #\} '(#\;) "oneof")
(maybe-skip-comments stream)
(appendf (proto-oneofs message) (list oneof))
(let ((type (find-option oneof "lisp_name")))
(when type
(setf (proto-class oneof) (make-lisp-symbol type))))
(let ((alias (find-option oneof "lisp_alias")))
(when alias
(setf (proto-alias-for oneof) (make-lisp-symbol alias))))
(return-from parse-proto-oneof oneof))
(parse-proto-oneof-field stream oneof message type)))))
(defun parse-proto-oneof-field (stream oneof message type)
"Parse a Oneofs field from 'stream'.
Updates the 'protobuf-oneof' object to have the field."
(check-type oneof protobuf-oneof)
(check-type message protobuf-message)
(let* ((name (prog1 (parse-token stream)
(expect-char stream #\= () "oneof")))
(idx (parse-unsigned-int stream))
(slot (proto->slot-name name *protobuf-package*))
(opts (prog1 (parse-proto-field-options stream)
(expect-char stream #\; () "oneof")
(maybe-skip-comments stream)))
(field (make-instance 'protobuf-field
:name name
:type type
:qualified-name (make-qualified-name message name)
;; the field is an actual field in the message
;; the oneof is a constraint that only one of these
;;
:parent message
;; One of :required, :optional or :repeated
:required nil
:index idx
:value slot
;; Fields parsed from .proto files usually get an accessor
:reader (let ((conc-name (proto-conc-name message)))
(and conc-name
(intern (format nil "~A~A" conc-name slot) *protobuf-package*)))
:message-type (proto-message-type message)
:oneof oneof
)))
(let ((slot (find-option opts "lisp_name")))
(when slot
(setf (proto-value field) (make-lisp-symbol type))))
;; both the message and the one-of want to know about the field
(appendf (proto-fields message) (list field))
(appendf (proto-fields oneof) (list field))
field))
(defun parse-proto-enum (stream protobuf)
"Parse a Protobufs 'enum' from 'stream'.
......@@ -508,12 +577,13 @@
(expect-char stream #\{ () "message")
(maybe-skip-comments stream)))
(class (proto->class-name name *protobuf-package*))
(syntax (proto-syntax *protobuf*))
(message (make-instance 'protobuf-message
:class class
:name name
:qualified-name (make-qualified-name protobuf name)
:parent protobuf
;; Maybe force accessors for all slots
;; Maybe force accessors for all slots
:conc-name (conc-name-for-type class *protobuf-conc-name*)
:source-location (make-source-location stream loc (i+ loc (length name)))))
(*protobuf* message))
......@@ -532,6 +602,8 @@
(return-from parse-proto-message message))
(cond ((string= token "enum")
(parse-proto-enum stream message))
((string= token "oneof")
(parse-proto-oneof stream message))
((string= token "extend")
(parse-proto-extend stream message))
((string= token "message")
......@@ -542,10 +614,27 @@
(parse-proto-option stream message))
((string= token "extensions")
(parse-proto-extension stream message))
(t
((and (string-equal syntax "proto3")
(or (member token '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
"fixed32" "fixed64" "sfixed32" "sfixed64"
"string" "bytes" "bool" "float" "double") :test #'string=)
(valid-type protobuf token)))
;; in proto3 you don't have the required/optional etc prefix, just treat it like we
;; saw one; I think all fields are optional in proto3
(parse-proto-field stream message "optional" nil token))
(t
(error "Unrecognized token ~A at ~A"
token (parse-error-position stream))))))))
(defmethod valid-type ((schema protobuf-schema) (name string))
(flet ((ok-in-this-schema (schema name)
(or (member name (proto-enums schema) :test #'string= :key #'proto-name )
(member name (proto-messages schema) :test #'string= :key #'proto-name))))
(or (ok-in-this-schema schema name)
(loop for sub-schema in (proto-imported-schemas schema)
thereis (ok-in-this-schema sub-schema name)))))
(defmethod resolve-lisp-names ((message protobuf-message))
"Recursively resolves protobuf type names to lisp type names in nested messages and fields of 'message'."
(map () #'resolve-lisp-names (proto-messages message))
......@@ -601,11 +690,11 @@
(error "Unrecognized token ~A at ~A"
token (parse-error-position stream))))))))
(defun parse-proto-field (stream message required &optional extended-from)
(defun parse-proto-field (stream message required &optional extended-from alredy-seen-token)
"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)))
(let ((type (or alredy-seen-token (parse-token stream))))
(if (string= type "group")
(parse-proto-group stream message required extended-from)
(let* ((name (prog1 (parse-token stream)
......
......@@ -39,6 +39,7 @@
;; Model classes
"PROTOBUF-SCHEMA"
"PROTOBUF-OPTION"
"PROTOBUF-ONEOF"
"PROTOBUF-ENUM"
"PROTOBUF-ENUM-VALUE"
"PROTOBUF-MESSAGE"
......
......@@ -229,6 +229,10 @@
(format stream "~&~@[~VT~]~%"
(and (not (zerop indentation)) indentation))))
;;; ToDo: Add code to generate proto format for OneOf's following the pattern
;;; in the :lisp format. I.e. fields in oneofs aren't generated in the message
;;; and the oneof generates code with those fields.
(defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
&key (indentation 0) more index arity)
(declare (ignore more arity))
......@@ -249,7 +253,7 @@
(format stream "~&~VToption ~:/protobuf-option/;~%"
(+ indentation 2) option))
(loop for (enum . more) on (proto-enums message) doing
(write-schema-as type enum stream :indentation (+ indentation 2) :more more))
(write-schema-as type enum stream :indentation (+ indentation 2) :more more))
(loop for (field . more) on (proto-fields message) doing
(write-schema-as type field stream
:indentation (+ indentation 2) :more more :message message))
......@@ -454,7 +458,7 @@
;; 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.)
;; Keywords are always printed as :keyword.)esee
(*package* (or *protobuf-package*
(when *use-common-lisp-package* (find-package :common-lisp))
(find-package :keyword)))
......@@ -475,7 +479,8 @@
~% (cl:unless (cl:find-package \"~A\")~
~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
~%(cl:in-package \"~A\")~
~%(cl:export '(~{~A~^~% ~}))~%~%"
~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
~% (cl:export '(~{~A~^~% ~})))~%~%"
pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
rpc-exports))))
(when (or lisp-pkg pkg)
......@@ -484,7 +489,8 @@
~% (cl:unless (cl:find-package \"~A\")~
~% (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
~%(cl:in-package \"~A\")~
~%(cl:export '(~{~A~^~% ~}))~%~%"
~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
~% (cl:export '(~{~A~^~% ~})))~%~%"
pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
(remove-if-not
#'(lambda (sym)
......@@ -531,7 +537,7 @@
(format stream "~A:documentation ~S" spaces documentation)))
(format stream ")")
(loop for (enum . more) on (proto-enums schema) doing
(write-schema-as type enum stream :indentation 2 :more more))
(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
......@@ -551,6 +557,35 @@
(declare (ignorable type stream))
nil)
(defmethod write-schema-as ((type (eql :lisp)) (oneof protobuf-oneof) stream
&key (indentation 0) more)
(terpri stream)
(with-prefixed-accessors (name class documentation source-location fields qualified-name) (proto- oneof)
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~@[~VT~](proto:protobuf-oneof ~(~S~)"
(and (not (zerop indentation)) indentation) class)
(let ((other (and name (string/= name (class-name->proto class)) name)))
(cond ((or other documentation source-location)
(format stream "~%~@[~VT~](~:[~2*~;:name ~(~S~)~@[~%~VT~]~]~
~:[~2*~;:documentation ~S~@[~%~VT~]~]~
~:[~*~;:source-location ~/source-location/~]
~:[~*~;:qualified-name ~s~])"
(+ indentation 4)
other other
(and (or documentation source-location) (+ indentation 5))
documentation documentation (and source-location (+ indentation 5))
source-location source-location
qualified-name qualified-name))
(t
(format stream " ()")))
(loop for (field . more) on (proto-fields oneof)
for message = (proto-parent field)
do (write-schema-as type field stream :indentation (+ indentation 2) :more more :message message))
(when more (terpri stream))
(format stream ")"))))
(defmethod write-schema-as ((type (eql :lisp)) (enum protobuf-enum) stream
&key (indentation 0) more)
(declare (ignore more))
......@@ -638,12 +673,13 @@
(write-schema-as type enum stream :indentation (+ indentation 2) :more more)
(when more
(terpri stream)))
(loop for (field . more) on (proto-fields message) doing
(write-schema-as type field stream
(loop for (field . more) on (proto-fields message)
unless (proto-oneof field)
do (write-schema-as type field stream
:indentation (+ indentation 2) :more more
:message message)
(when more
(terpri stream))))
(when more
(terpri stream))))
(t
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
......@@ -668,12 +704,14 @@
(t
(format stream " ()"))))
(cond ((eq message-type :extends)
(loop for (field . more) on (proto-extended-fields message) doing
(write-schema-as type field stream
(loop for (field . more) on (proto-extended-fields message)
unless (proto-oneof field)
do
(write-schema-as type field stream
:indentation (+ indentation 2) :more more
:message message)
(when more
(terpri stream))))
(when more
(terpri stream))))
(t
(loop for (enum . more) on (proto-enums message) doing
(write-schema-as type enum stream :indentation (+ indentation 2) :more more)
......@@ -684,12 +722,17 @@
(write-schema-as type msg stream :indentation (+ indentation 2) :more more)
(when more
(terpri stream))))
(loop for (field . more) on (proto-fields message) doing
(write-schema-as type field stream
(loop for (oneof . more) on (proto-oneofs message)
do (write-schema-as type oneof stream
:indentation (+ indentation 2)
:more more
:message message))
(loop for (field . more) on (proto-fields message)
unless (proto-oneof field)
do (write-schema-as type field stream
:indentation (+ indentation 2) :more more
:message message)
(when more
(terpri stream)))
(when more (terpri stream)))
(loop for (extension . more) on (proto-extensions message) doing
(write-schema-as type extension stream :indentation (+ indentation 2) :more more)
(when more
......@@ -768,7 +811,7 @@
(format stream (if (and (keywordp class) (not (eq class :bool)))
;; Keyword class means a primitive type, print default with ~S
"~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :~packed ~(~S~)~]~
~@[ :options (~{~/protobuf-option/~^ ~})~])~
~:[~2*~;~VT; ~A~]"
;; Non-keyword class means an enum type, print default with ~(~S~)
......@@ -777,7 +820,8 @@
~@[ :options (~{~/protobuf-option/~^ ~})~])~
~:[~2*~;~VT; ~A~]")
(and (not (zerop indentation)) indentation)
slot-name type defaultp default reader writer packed options
slot-name type
defaultp default reader writer packed options
;; Don't write the comment if we'll insert a close paren after it
(and more documentation) *protobuf-slot-comment-column* documentation)))))))
......
......@@ -8,7 +8,7 @@
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defsystem "cl-protobufs-tests"
(asdf:defsystem "cl-protobufs-tests"
:name "Protobufs Tests"
:author "Scott McKay"
:version "1.0"
......
......@@ -140,7 +140,6 @@ message DefinedMessage {
")
(define-test undefined-types-test ()
(labels ((parse-schema-containing (string)
(with-input-from-string (s (concatenate 'string *test-proto-preamble* string))
......@@ -164,8 +163,8 @@ message DefinedMessage {
for expected-string in expected-strings
as position = (search expected-string actual-string :start2 index)
always position
do (setf index (+ position (length expected-string))))))
(do-field-test (field-type)
do (setf index (+ position (length expected-string))))))
(do-field-test (field-type)
(let ((condition (assert-error undefined-field-type
(parse-message-with-field-type field-type))))
(poor-mans-assert-regex-equal
......@@ -184,7 +183,11 @@ message DefinedMessage {
"in service "
"ServiceWithUndefinedMethodType"
(format nil "has unknown type ~A" type))
(princ-to-string condition))
(let ((*package* (find-package :proto-test)))
;; The format string for the condition includes @< ... @> which justifies
;; and might introduce a newline which would cause a mismatch. So
;; replace that by a space
(substitute #\space #\newline (princ-to-string condition) :test #'char-equal)))
(assert-equal type (error-type-name condition))
(assert-equal method-proto-name (proto-name (error-method condition))))
(do-method-input-test (input-type)
......@@ -219,7 +222,11 @@ message DefinedMessage {
(parse-service-with-rpc
"rpc MethodWithDefinedInputOutput (DefinedMessage) returns (DefinedMessage);")
(do-method-input-test "UndefinedMessage")
;; my understanding is that primitive types are not allowed for method input/output; if this is
;; incorrect, change to "int"
(do-method-input-test "int32")
......
......@@ -356,8 +356,10 @@
;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
(defun class-name->proto (x)
"Given a Lisp class name, returns a Protobufs message or enum name.
The second value is the fully qualified name, as a list."
(let* ((xs (split-string (string x) :separators '(#\.)))
The second value is the fully qualified name, as a list. At least one caller
passes in the class, not the name, so check for that first."
(let* ((real-class-name (if (typep x 'class) (class-name x) x))
(xs (split-string (string real-class-name) :separators '(#\.)))
(ns (loop for x in (butlast xs)
collect (remove-if-not #'alphanumericp
(camel-case (format nil "~A" x) *proto-name-separators*))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment