Fix some printers, etc

diff --git a/conditions.lisp b/conditions.lisp
index 012c3bb45ae91af3f47bb31eca1b9d25ff3a6e58..9eef5ee97010d8fd21e973ba630b7bb6fa1859ab 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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))))