diff --git a/conditions.lisp b/conditions.lisp index 012c3bb45ae91af3f47bb31eca1b9d25ff3a6e58..9eef5ee97010d8fd21e973ba630b7bb6fa1859ab 100644 --- a/conditions.lisp +++ b/conditions.lisp @@ -31,7 +31,7 @@ (:documentation "Indicates that a schema contains a message with a field whose type is not a primitive type and is not a known message (or extend) or enum.") (:report (lambda (condition stream) - (format stream "~? Field ~S in message ~S has unknown type ~S" + (format stream "~? Field ~A in message ~A has unknown type ~A" (simple-condition-format-control condition) (simple-condition-format-arguments condition) (error-field condition) @@ -58,7 +58,7 @@ that a schema contains a service with a method whose input, output, or stream type is not a known message (or extend).") (:report (lambda (condition stream) - (format stream "~? ~A type for RPC ~S in service ~S has unknown type ~S" + (format stream "~? ~A type for RPC ~A in service ~A has unknown type ~A" (simple-condition-format-control condition) (simple-condition-format-arguments condition) (error-where condition) diff --git a/model-classes.lisp b/model-classes.lisp index 9a7a1304da5721ae80e31aa876add0d4c5f2827d..bfe1c62abd224aac837b86c7319dabc5600589f8 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -187,9 +187,11 @@ (setf (gethash (make-pathname :type nil :defaults path) *all-schemas*) schema)))))) (defmethod print-object ((s protobuf-schema) stream) - (print-unreadable-object (s stream :type t :identity t) - (format stream "~@[~S~]~@[ (package ~A)~]" - (when (slot-boundp s 'class) (proto-class s)) (proto-package s)))) + (if *print-escape* + (print-unreadable-object (s stream :type t :identity t) + (format stream "~@[~S~]~@[ (package ~A)~]" + (and (slot-boundp s 'class) (proto-class s)) (proto-package s))) + (format stream "~S" (and (slot-boundp s 'class) (proto-class s))))) (defgeneric make-qualified-name (proto name) (:documentation @@ -296,8 +298,10 @@ (make-load-form-saving-slots o :environment environment)) (defmethod print-object ((o protobuf-option) stream) - (print-unreadable-object (o stream :type t :identity t) - (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o)))) + (if *print-escape* + (print-unreadable-object (o stream :type t :identity t) + (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))) + (format stream "~A" (proto-name o)))) (defgeneric find-option (protobuf name) (:documentation @@ -363,9 +367,12 @@ (make-load-form-saving-slots e :environment environment)) (defmethod print-object ((e protobuf-enum) stream) - (print-unreadable-object (e stream :type t :identity t) - (format stream "~S~@[ (alias for ~S)~]" - (when (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))) + (if *print-escape* + (print-unreadable-object (e stream :type t :identity t) + (format stream "~S~@[ (alias for ~S)~]" + (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e))) + (format stream "~S" + (and (slot-boundp e 'class) (proto-class e))))) (defmethod make-qualified-name ((enum protobuf-enum) name) ;; The qualified name is the enum name "dot" the name @@ -394,9 +401,11 @@ (make-load-form-saving-slots v :environment environment)) (defmethod print-object ((v protobuf-enum-value) stream) - (print-unreadable-object (v stream :type t :identity t) - (format stream "~A = ~D" - (proto-name v) (proto-index v)))) + (if *print-escape* + (print-unreadable-object (v stream :type t :identity t) + (format stream "~A = ~D" + (proto-name v) (proto-index v))) + (format stream "~A" (proto-name v)))) ;; A Protobufs message @@ -469,12 +478,14 @@ (setf (gethash name *all-messages*) message))))) (defmethod print-object ((m protobuf-message) stream) - (print-unreadable-object (m stream :type t :identity t) - (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]" - (when (slot-boundp m 'class) (proto-class m)) - (proto-alias-for m) - (eq (proto-message-type m) :group) - (eq (proto-message-type m) :extends)))) + (if *print-escape* + (print-unreadable-object (m stream :type t :identity t) + (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]" + (and (slot-boundp m 'class) (proto-class m)) + (proto-alias-for m) + (eq (proto-message-type m) :group) + (eq (proto-message-type m) :extends))) + (format stream "~S" (and (slot-boundp m 'class) (proto-class m))))) (defmethod proto-package ((message protobuf-message)) (and (proto-parent message) @@ -617,13 +628,15 @@ (make-load-form-saving-slots f :environment environment)) (defmethod print-object ((f protobuf-field) stream) - (print-unreadable-object (f stream :type t :identity t) - (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]" - (proto-value f) - (when (slot-boundp f 'class) (proto-class f)) - (proto-index f) - (eq (proto-message-type f) :group) - (eq (proto-message-type f) :extends)))) + (if *print-escape* + (print-unreadable-object (f stream :type t :identity t) + (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]" + (proto-value f) + (and (slot-boundp f 'class) (proto-class f)) + (proto-index f) + (eq (proto-message-type f) :group) + (eq (proto-message-type f) :extends))) + (format stream "~S" (proto-value f)))) ;; The 'value' slot really holds the name of the slot, ;; so let's give it a better name @@ -672,7 +685,7 @@ (defmethod print-object ((e protobuf-extension) stream) (print-unreadable-object (e stream :type t :identity t) (format stream "~D - ~D" - (proto-extension-from e) (proto-extension-from e)))) + (proto-extension-from e) (proto-extension-to e)))) ;; A Protobufs service @@ -688,9 +701,10 @@ (make-load-form-saving-slots s :environment environment)) (defmethod print-object ((s protobuf-service) stream) - (print-unreadable-object (s stream :type t :identity t) - (format stream "~A" - (proto-name s)))) + (if *print-escape* + (print-unreadable-object (s stream :type t :identity t) + (format stream "~S" (proto-name s))) + (format stream "~S" (proto-name s)))) (defgeneric find-method (service name) (:documentation @@ -747,11 +761,13 @@ (make-load-form-saving-slots m :environment environment)) (defmethod print-object ((m protobuf-method) stream) - (print-unreadable-object (m stream :type t :identity t) - (format stream "~S (~S) => (~S)" - (proto-class m) - (when (slot-boundp m 'itype) (proto-input-type m)) - (when (slot-boundp m 'otype) (proto-output-type m))))) + (if *print-escape* + (print-unreadable-object (m stream :type t :identity t) + (format stream "~S (~S) => (~S)" + (proto-class m) + (and (slot-boundp m 'itype) (proto-input-type m)) + (and (slot-boundp m 'otype) (proto-output-type m)))) + (format stream "~S" (proto-class m)))) ;;; Lisp-only extensions @@ -773,10 +789,12 @@ (make-load-form-saving-slots m :environment environment)) (defmethod print-object ((m protobuf-type-alias) stream) - (print-unreadable-object (m stream :type t :identity t) - (format stream "~S (maps ~S to ~S)" - (proto-class m) - (proto-lisp-type m) (proto-proto-type m)))) + (if *print-escape* + (print-unreadable-object (m stream :type t :identity t) + (format stream "~S (maps ~S to ~S)" + (proto-class m) + (proto-lisp-type m) (proto-proto-type m))) + (format stream "~S" (proto-class m)))) (defgeneric find-type-alias (protobuf type) (:documentation diff --git a/parser.lisp b/parser.lisp index 167978b594587cf213ad24352fb345d7bae86cd0..991181bce2af3d1a4afa37a5d2f0fc1ceb1d8b19 100644 --- a/parser.lisp +++ b/parser.lisp @@ -288,9 +288,10 @@ :start-pos start :end-pos end))) (defgeneric resolve-lisp-names (protobuf) - (:documentation "Second pass of schema parsing which recursively resolves protobuf type names to - lisp type names in all messages and services contained within 'protobuf'. No - return value.")) + (:documentation + "Second pass of schema parsing which recursively resolves Protobuf type names + to Lisp type names in all messages and services contained within 'protobuf'. + No return value.")) ;; The syntax for Protocol Buffers is so simple that it doesn't seem worth ;; writing a sophisticated parser @@ -521,8 +522,7 @@ token (file-position stream)))))))) (defmethod resolve-lisp-names ((message protobuf-message)) - "Recursively resolves protobuf type names to lisp type names in nested messages and fields of - 'message'." + "Recursively resolves protobuf type names to lisp type names in nested messages and fields of 'message'." (map () #'resolve-lisp-names (proto-messages message)) (map () #'resolve-lisp-names (proto-fields message))) diff --git a/tests/lisp-reference-tests.lisp b/tests/lisp-reference-tests.lisp index d73c4ae380ed64b43f1912fa6923ff302b5f156e..f3b9cab0edf0ab05fa3ff01004846c16b77d51f1 100644 --- a/tests/lisp-reference-tests.lisp +++ b/tests/lisp-reference-tests.lisp @@ -152,11 +152,11 @@ message DefinedMessage { :conc-name nil))) (parse-message-with-field-type (type) (parse-schema-containing (format nil "message MessageWithUndefinedFieldType {~%~ - ~& optional ~a bar = 1;~%~ + ~& optional ~A bar = 1;~%~ }~%" type))) (parse-service-with-rpc (rpc) (parse-schema-containing (format nil "service ServiceWithUndefinedMethodType {~%~ - ~& ~a~%~ + ~& ~A~%~ }~%" rpc))) (poor-mans-assert-regex-equal (expected-strings actual-string) (assert-true @@ -169,28 +169,28 @@ message DefinedMessage { (let ((condition (assert-error undefined-field-type (parse-message-with-field-type field-type)))) (poor-mans-assert-regex-equal - (list "Undefined type: Field #<" - "PROTOBUF-FIELD PROTOBUFS-TEST::BAR :: NIL = 1" - "in message #<" - "PROTOBUF-MESSAGE PROTOBUFS-TEST::MESSAGE-WITH-UNDEFINED-FIELD-TYPE" - (format nil "has unknown type \"~a\"." field-type)) + (list "Undefined type: Field " + "BAR" + "in message " + "MESSAGE-WITH-UNDEFINED-FIELD-TYPE" + (format nil "has unknown type ~A" field-type)) (princ-to-string condition)) (assert-equal field-type (error-type-name condition)) (assert-equal "bar" (proto-name (error-field condition))))) (method-test-assertions (condition where method-lisp-name method-proto-name type) (poor-mans-assert-regex-equal - (list (format nil "Undefined type: ~a type for rpc #<" where) - (format nil "PROTOBUF-METHOD PROTOBUFS-TEST::~a" method-lisp-name) - "in service #<" - "PROTOBUF-SERVICE ServiceWithUndefinedMethodType" - (format nil "has unknown type \"~a\"." type)) + (list (format nil "Undefined type: ~A type for RPC " where) + (format nil "~A" method-lisp-name) + "in service " + "ServiceWithUndefinedMethodType" + (format nil "has unknown type ~A" type)) (princ-to-string condition)) (assert-equal type (error-type-name condition)) (assert-equal method-proto-name (proto-name (error-method condition)))) (do-method-input-test (input-type) (let ((condition (assert-error undefined-input-type (parse-service-with-rpc - (format nil "rpc MethodWithUndefinedInput (~a) ~ + (format nil "rpc MethodWithUndefinedInput (~A) ~ returns (DefinedMessage);" input-type))))) (method-test-assertions condition "Input" "METHOD-WITH-UNDEFINED-INPUT" "MethodWithUndefinedInput" input-type))) @@ -198,7 +198,7 @@ message DefinedMessage { (let ((condition (assert-error undefined-output-type (parse-service-with-rpc (format nil "rpc MethodWithUndefinedOutput (DefinedMessage) ~ - returns (~a);" output-type))))) + returns (~A);" output-type))))) (method-test-assertions condition "Output" "METHOD-WITH-UNDEFINED-OUTPUT" "MethodWithUndefinedOutput" output-type))) (do-method-stream-test (stream-type) @@ -206,7 +206,7 @@ message DefinedMessage { (parse-service-with-rpc (format nil "rpc MethodWithUndefinedStream (DefinedMessage) ~ returns (DefinedMessage) {~ - ~& option stream_type = \"~a\";~ + ~& option stream_type = \"~A\";~ ~& };" stream-type))))) (method-test-assertions condition "Stream" "METHOD-WITH-UNDEFINED-STREAM" "MethodWithUndefinedStream" stream-type))))