X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=printer.lisp;h=24578bb7cfe8c83425a1d3f65dd74bd57f3846aa;hb=f44e150c4c2d1647c6c9538da8afba71945d7089;hp=954c1e7eb7b9654caf0e4fd2396dee33c89391ab;hpb=1f50242a0a0725919ddfdda33883843e150e832c;p=cl-protobufs.git

diff --git a/printer.lisp b/printer.lisp
index 954c1e7..24578bb 100644
--- a/printer.lisp
+++ b/printer.lisp
@@ -2,7 +2,7 @@
 ;;;                                                                  ;;;
 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
 ;;;                                                                  ;;;
-;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
+;;; Copyright (c) 2012-2013 Google, Inc.  All rights reserved.       ;;;
 ;;;                                                                  ;;;
 ;;; Original author: Scott McKay                                     ;;;
 ;;;                                                                  ;;;
@@ -213,7 +213,7 @@
                             &key (indentation 0) more)
   (declare (ignore more))
   (with-prefixed-accessors (name documentation index) (proto- val)
-    (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
+    (format stream "~&~@[~VT~]~A = ~D;~:[~2*~;~VT// ~A~]~%"
             (and (not (zerop indentation)) indentation)
             (maybe-qualified-name val) index
             documentation *protobuf-enum-comment-column* documentation)))
@@ -343,7 +343,7 @@
                (if (typep msg 'protobuf-type-alias)
                  (format stream "~&~@[~VT~]~(~A~) ~(~A~) ~A = ~D~
                                  ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
-                                 ~:[~*~*~;~VT// ~A~]~%"
+                                 ~:[~2*~;~VT// ~A~]~%"
                          (and (not (zerop indentation)) indentation)
                          required (proto-proto-type msg) name index
                          defaultp default packed options
@@ -354,11 +354,11 @@
                                   ;; Keyword class means a primitive type, print default with ~S
                                   "~&~@[~VT~]~(~A~) ~A ~A = ~D~
                                    ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
-                                   ~:[~*~*~;~VT// ~A~]~%"
+                                   ~:[~2*~;~VT// ~A~]~%"
                                   ;; Non-keyword class means an enum type, print default with ~A"
                                   "~&~@[~VT~]~(~A~) ~A ~A = ~D~
                                    ~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
-                                   ~:[~*~*~;~VT// ~A~]~%")
+                                   ~:[~2*~;~VT// ~A~]~%")
                          (and (not (zerop indentation)) indentation)
                          required (maybe-qualified-name msg type) name index
                          defaultp default packed options
@@ -440,10 +440,13 @@
                                 (proto-options schema)))
            (pkg      (and package (if (stringp package) package (string package))))
            (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
+           (rpc-pkg  (and (or lisp-pkg pkg)
+                          (format nil "~A-~A" (or lisp-pkg pkg) 'rpc)))
            (*show-lisp-enum-indexes*  show-enum-indexes)
            (*show-lisp-field-indexes* show-field-indexes)
            (*use-common-lisp-package* use-common-lisp)
            (*protobuf-package* (find-proto-package lisp-pkg))
+           (*protobuf-rpc-package* (find-proto-package rpc-pkg))
            ;; If *protobuf-package* has not been defined, print symbols
            ;; from :common-lisp if *use-common-lisp-package* is true; or
            ;; :keyword otherwise.  This ensures that all symbols will be
@@ -453,16 +456,41 @@
            ;; Keywords are always printed as :keyword.)
            (*package* (or *protobuf-package*
                           (when *use-common-lisp-package* (find-package :common-lisp))
-                          (find-package :keyword))))
+                          (find-package :keyword)))
+           (exports (collect-exports schema)))
+      (when rpc-pkg
+        (let* ((pkg (string-upcase rpc-pkg))
+               (rpc-exports (remove-if-not
+                             #'(lambda (sym)
+                                 (string=
+                                  (package-name (symbol-package sym))
+                                  pkg))
+                             exports))
+               (*package* (or *protobuf-rpc-package*
+                              (when *use-common-lisp-package* (find-package :common-lisp))
+                              (find-package :keyword))))
+          (when rpc-exports
+            (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
+                            ~%  (cl:unless (cl:find-package \"~A\")~
+                            ~%    (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
+                            ~%(cl:in-package \"~A\")~
+                            ~%(cl:export '(~{~A~^~%             ~}))~%~%"
+                    pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
+                    rpc-exports))))
       (when (or lisp-pkg pkg)
         (let ((pkg (string-upcase (or lisp-pkg pkg))))
-          (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel) ~
-                          ~%  (unless (cl:find-package \"~A\") ~
-                          ~%    (cl:defpackage ~A (:use~@[ ~(~S~)~])))) ~
-                          ~%(cl:in-package \"~A\") ~
+          (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
+                          ~%  (cl:unless (cl:find-package \"~A\")~
+                          ~%    (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
+                          ~%(cl:in-package \"~A\")~
                           ~%(cl:export '(~{~A~^~%             ~}))~%~%"
                   pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
-                  (collect-exports schema))))
+                  (remove-if-not
+                   #'(lambda (sym)
+                       (string=
+                        (package-name (symbol-package sym))
+                        pkg))
+                   exports))))
       (when documentation
         (write-schema-documentation type documentation stream :indentation indentation))
       (format stream "~&(proto:define-schema ~(~A~)" (or class name))
@@ -532,14 +560,14 @@
       (write-schema-documentation type documentation stream :indentation indentation))
     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
             (and (not (zerop indentation)) indentation) class)
-    (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+    (let ((other (and name (string/= name (class-name->proto class)) name)))
       (cond ((or other alias-for documentation source-location)
-             (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
-                                        ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
-                                        ~:[~*~;:documentation ~S~@[~%~VT~]~]~
+             (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
+                                        ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+                                        ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
                                         ~:[~*~;:source-location ~/source-location/~])"
                      (+ indentation 4)
-                     other other (and (or alias-for documentation) (+ indentation 5))
+                     other other (and (or alias-for documentation source-location) (+ indentation 5))
                      alias-for alias-for (and (or documentation source-location) (+ indentation 5))
                      documentation documentation (and source-location (+ indentation 5))
                      source-location source-location))
@@ -589,13 +617,13 @@
                (write-schema-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-equal name (class-name->proto class))) name)))
+             (let ((other (and name (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~@[~%~VT~]~]~
+                                          ~:[~2*~;:name ~S~@[~%~VT~]~]~
+                                          ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+                                          ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+                                          ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
                                           ~:[~*~;:source-location ~/source-location/~])"
                        (+ indentation 4)
                        index (+ indentation 5)
@@ -621,14 +649,14 @@
              (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
                      (and (not (zerop indentation)) indentation)
                      (if (eq message-type :message) "message" "extend") class)
-             (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
+             (let ((other (and name (string/= name (class-name->proto class)) name)))
                (cond ((eq message-type :extends)
                       (format stream " ()"))
                      ((or other alias-for conc-name documentation source-location)
-                      (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
-                                                 ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
-                                                 ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
-                                                 ~:[~*~;:documentation ~S~@[~%~VT~]~]~
+                      (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
+                                                 ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
+                                                 ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
+                                                 ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
                                                  ~:[~*~;:source-location ~/source-location/~])"
                               (+ indentation 4)
                               other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
@@ -741,12 +769,12 @@
                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
                                  ~@[ :options (~{~/protobuf-option/~^ ~})~])~
-                                 ~:[~*~*~;~VT; ~A~]"
+                                 ~:[~2*~;~VT; ~A~]"
                                 ;; Non-keyword class means an enum type, print default with ~(~S~)
                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
                                  ~@[ :options (~{~/protobuf-option/~^ ~})~])~
-                                 ~:[~*~*~;~VT; ~A~]")
+                                 ~:[~2*~;~VT; ~A~]")
                        (and (not (zerop indentation)) indentation)
                        slot-name type defaultp default reader writer packed options
                        ;; Don't write the comment if we'll insert a close paren after it
@@ -763,19 +791,22 @@
 (defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
                             &key (indentation 0) more)
   (declare (ignore more))
-  (with-prefixed-accessors (class documentation source-location) (proto- service)
+  (with-prefixed-accessors (class documentation name source-location) (proto- service)
     (when documentation
       (write-schema-documentation type documentation stream :indentation indentation))
     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
             (and (not (zerop indentation)) indentation) (proto-class service))
-    (cond ((or documentation source-location)
-           (format stream "~%~@[~VT~](~:[~*~;:documentation ~S~@[~%~VT~]~]~
-                                      ~:[~*~;:source-location ~/source-location/~])"
-                   (+ indentation 4)
-                   documentation documentation (and source-location (+ indentation 5))
-                   source-location source-location))
-          (t
-           (format stream " ()")))
+    (let ((other (and name (string/= name (class-name->proto (proto-class service))) name)))
+      (cond ((or documentation other source-location)
+             (format stream "~%~@[~VT~](~:[~2*~;:documentation ~S~@[~%~VT~]~]~
+                                        ~:[~2*~;:name ~S~@[~%~VT~]~]~
+                                        ~:[~*~;:source-location ~/source-location/~])"
+                     (+ indentation 4)
+                     documentation documentation (and (or documentation source-location) (+ indentation 5))
+                     other other (and source-location (+ indentation 5))
+                     source-location source-location))
+            (t
+             (format stream " ()"))))
     (loop for (method . more) on (proto-methods service) doing
       (write-schema-as type method stream :indentation (+ indentation 2) :more more)
       (when more
@@ -785,13 +816,26 @@
 (defmethod write-schema-as ((type (eql :lisp)) (method protobuf-method) stream
                             &key (indentation 0) more)
   (declare (ignore more))
-  (with-prefixed-accessors (class input-type output-type streams-type options
-                            documentation source-location) (proto- method)
+  (with-prefixed-accessors (class input-type output-type streams-type
+                            name  input-name output-name streams-name
+                            options documentation source-location) (proto- method)
     (when documentation
       (write-schema-documentation type documentation stream :indentation indentation))
-    (format stream "~&~@[~VT~](~(~S~) (~(~S~) => ~(~S~)~@[ :streams ~(~S~)~])"
-            (and (not (zerop indentation)) indentation)
-            class input-type output-type streams-type)
+    (format stream "~&~@[~VT~](~(~S~) (" (and (not (zerop indentation)) indentation) class)
+    (if (and input-name (string/= (class-name->proto input-type) input-name))
+        (format stream "(~(~S~) :name ~S) => " input-type input-name)
+        (format stream "~(~S~) => " input-type))
+    (if (and output-name (string/= (class-name->proto output-type) output-name))
+        (format stream "(~(~S~) :name ~S)" output-type output-name)
+        (format stream "~(~S~)" output-type))
+    (when streams-type
+      (if (and streams-name (string/= (class-name->proto streams-type) streams-name))
+          (format stream " :streams (~(~S~) :name ~S)" streams-type streams-name)
+          (format stream " :streams ~(~S~)" streams-type)))
+    (format stream ")")
+    (when (and name (string/= (class-name->proto name) name))
+      (format stream "~%~VT:name ~S"
+              (+ indentation 2) name))
     (when options
       (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
               (+ indentation 2) options))
@@ -819,6 +863,7 @@
 ;; Export the class name and all of the accessor names
 (defmethod collect-exports ((message protobuf-message))
   (append (list (proto-class message))
+          (mapcan #'collect-exports (proto-messages message))
           (mapcan #'collect-exports (proto-fields message))))
 
 ;; Export just the slot accessor name