printer.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, Inc.  All rights reserved.       ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protobufs schema pretty printing
  15
  16 (defun write-schema (protobuf &rest keys
  17                      &key (stream *standard-output*) (type :proto) &allow-other-keys)
  18   "Writes the object 'protobuf' (schema, message, enum, etc) onto the
  19    stream 'stream' in the format given by 'type' (:proto, :text, etc)."
  20    (let ((*protobuf* protobuf))
  21      (apply #'write-schema-as type protobuf stream keys)))
  22
  23 (defgeneric write-schema-as (type protobuf stream &key indentation &allow-other-keys)
  24   (:documentation
  25    "Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
  26     the given stream 'stream' in the format given by 'type' (:proto, :text, etc).
  27     If 'more' is true, this means there are more enum values, fields, etc to
  28     be written after the current one."))
  29
  30 (defgeneric write-schema-header (type schema stream)
  31   (:documentation
  32    "Writes a header for the schema onto the given stream 'stream'
  33     in the format given by 'type' (:proto, :text, etc)."))
  34
  35 (defgeneric write-schema-documentation (type docstring stream &key indentation)
  36   (:documentation
  37    "Writes the docstring as a \"block comment\" onto the given stream 'stream'
  38     in the format given by 'type' (:proto, :text, etc)."))
  39
  40
  41 ;;; Pretty print a schema as a .proto file
  42
  43 (defmethod write-schema-as ((type (eql :proto)) (schema protobuf-schema) stream
  44                             &key (indentation 0))
  45   (with-prefixed-accessors (documentation syntax package imports options) (proto- schema)
  46     (when documentation
  47       (write-schema-documentation type documentation stream :indentation indentation))
  48     (when syntax
  49       (format stream "~&syntax = \"~A\";~%~%" syntax))
  50     (when package
  51       (format stream "~&package ~A;~%~%" (substitute #\_ #\- package)))
  52     (when imports
  53       (dolist (import imports)
  54         (format stream "~&import \"~A\";~%" import))
  55       (terpri stream))
  56     (write-schema-header type schema stream)
  57     (when options
  58       (dolist (option options)
  59         (format stream "~&option ~:/protobuf-option/;~%" option))
  60       (terpri stream))
  61     (loop for (enum . more) on (proto-enums schema) doing
  62       (write-schema-as type enum stream :indentation indentation :more more)
  63       (terpri stream))
  64     (loop for (alias . more) on (proto-type-aliases schema) doing
  65       (write-schema-as type alias stream :indentation indentation :more more)
  66       (terpri stream))
  67     (loop for (msg . more) on (proto-messages schema) doing
  68       (write-schema-as type msg stream :indentation indentation :more more)
  69       (terpri stream))
  70     (loop for (svc . more) on (proto-services schema) doing
  71       (write-schema-as type svc stream :indentation indentation :more more)
  72       (terpri stream))))
  73
  74 (defmethod write-schema-documentation ((type (eql :proto)) docstring stream
  75                                        &key (indentation 0))
  76   (let ((lines (split-string docstring :separators '(#\newline #\return))))
  77     (dolist (line lines)
  78       (format stream "~&~@[~VT~]// ~A~%"
  79               (and (not (zerop indentation)) indentation) line))))
  80
  81 ;; Lisp was born in 1958 :-)
  82 (defparameter *lisp-options* '(("lisp_package" string 195801)
  83                                ("lisp_name"    string 195802)
  84                                ("lisp_alias"   string 195803)
  85                                ("lisp_type"    string 195804)
  86                                ("lisp_class"   string 195805)
  87                                ("lisp_slot"    string 195806)))
  88
  89 (defparameter *option-types* '(("allow_alias"          boolean)
  90                                ("ctype"                 symbol)
  91                                ("deadline"               float)
  92                                ("deprecated"            symbol)
  93                                ("optimize_for"          symbol)
  94                                ("packed"               boolean)
  95                                ("protocol"              symbol)
  96                                ("stream_type"           string)
  97                                ;; Keep the rest of these in alphabetical order
  98                                ("cc_api_version"       integer)
  99                                ("cc_generic_services"   symbol)
 100                                ("go_api_version"       integer)
 101                                ("go_generic_services"   symbol)
 102                                ("go_package"            string)
 103                                ("java_api_version"     integer)
 104                                ("java_generic_services" symbol)
 105                                ("java_java5_enums"     boolean)
 106                                ("java_multiple_files"  boolean)
 107                                ("java_outer_classname"  string)
 108                                ("java_package"          string)
 109                                ("java_use_javaproto2"  boolean)
 110                                ("py_api_version"       integer)
 111                                ("py_generic_services"   symbol)))
 112
 113 (defmethod write-schema-header ((type (eql :proto)) (schema protobuf-schema) stream)
 114   (when (any-lisp-option schema)
 115     (format stream "~&import \"net/proto2/proto/descriptor.proto\";~%~%")
 116     (format stream "~&extend proto2.MessageOptions {~%")
 117     (loop for (option type index) in *lisp-options* doing
 118       (format stream "~&  optional ~(~A~) ~A = ~D;~%" type option index))
 119     (format stream "~&}~%~%")))
 120
 121 (defgeneric any-lisp-option (schema)
 122   (:documentation
 123    "Returns true iff there is anything in the schema that would require that
 124     the .proto file include and extend 'MessageOptions'.")
 125   (:method ((schema protobuf-schema))
 126     (labels ((find-one (protobuf)
 127                (dolist (enum (proto-enums protobuf))
 128                  (with-prefixed-accessors (name class alias-for) (proto- enum)
 129                    (when (or alias-for
 130                              (and class (not (string-equal name (class-name->proto class))) class))
 131                      (return-from any-lisp-option t))))
 132                (dolist (msg (proto-messages protobuf))
 133                  (with-prefixed-accessors (name class alias-for) (proto- msg)
 134                    (when (or alias-for
 135                              (and class (not (string-equal name (class-name->proto class))) class))
 136                      (return-from any-lisp-option t))))
 137                (map () #'find-one (proto-messages protobuf))))
 138       (find-one schema)
 139       nil)))
 140
 141 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
 142   (let* ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
 143                    (proto-type option)))
 144          (value (proto-value option)))
 145     (cond (colon-p                              ;~:/protobuf-option/ -- .proto format
 146            (let ((fmt-control
 147                   (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
 148                          (case type
 149                            ((symbol) "(~A)~@[ = ~A~]")
 150                            ((boolean) "(~A)~@[ = ~(~A~)~]")
 151                            (otherwise
 152                             (cond ((typep value 'standard-object)
 153                                    ;; If the value is an instance of some class,
 154                                    ;; then it must be some sort of complex option,
 155                                    ;; so print the value using the text format
 156                                    (setq value
 157                                          (with-output-to-string (s)
 158                                            (print-text-format value nil
 159                                                               :stream s :print-name nil :suppress-line-breaks t)))
 160                                    "(~A)~@[ = ~A~]")
 161                                   (t
 162                                    "(~A)~@[ = ~S~]")))))
 163                         (t
 164                          (case type
 165                            ((symbol) "~A~@[ = ~A~]")
 166                            ((boolean) "~A~@[ = ~(~A~)~]")
 167                            (otherwise
 168                             (cond ((typep value 'standard-object)
 169                                    (setq value
 170                                          (with-output-to-string (s)
 171                                            (print-text-format value nil
 172                                                               :stream s :print-name nil :suppress-line-breaks t)))
 173                                    "~A~@[ = ~A~]")
 174                                   (t "~A~@[ = ~S~]"))))))))
 175              (format stream fmt-control (proto-name option) value)))
 176           (atsign-p                             ;~@/protobuf-option/ -- string/value format
 177            (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
 178              (format stream fmt-control (proto-name option) value)))
 179           (t                                    ;~/protobuf-option/  -- keyword/value format
 180            (let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S")))
 181              (format stream fmt-control (proto-name option) value))))))
 182
 183 (defun cl-user::source-location (stream location colon-p atsign-p)
 184   (declare (ignore colon-p atsign-p))
 185   (format stream "(~S ~D ~D)"
 186           (source-location-pathname location)
 187           (source-location-start-pos location) (source-location-end-pos location)))
 188
 189 (defmethod write-schema-as ((type (eql :proto)) (enum protobuf-enum) stream
 190                             &key (indentation 0) more)
 191   (declare (ignore more))
 192   (with-prefixed-accessors (name class alias-for documentation options) (proto- enum)
 193     (when documentation
 194       (write-schema-documentation type documentation stream :indentation indentation))
 195     (format stream "~&~@[~VT~]enum ~A {~%"
 196             (and (not (zerop indentation)) indentation)
 197             (maybe-qualified-name enum))
 198     (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 199       (when other
 200         (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 201                 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 202     (when alias-for
 203       (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 204               (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 205     (dolist (option options)
 206       (format stream "~&option ~:/protobuf-option/;~%" option))
 207     (loop for (value . more) on (proto-values enum) doing
 208       (write-schema-as type value stream :indentation (+ indentation 2) :more more))
 209     (format stream "~&~@[~VT~]}~%"
 210             (and (not (zerop indentation)) indentation))))
 211
 212 (defparameter *protobuf-enum-comment-column* 56)
 213 (defmethod write-schema-as ((type (eql :proto)) (val protobuf-enum-value) stream
 214                             &key (indentation 0) more)
 215   (declare (ignore more))
 216   (with-prefixed-accessors (name documentation index) (proto- val)
 217     (format stream "~&~@[~VT~]~A = ~D;~:[~2*~;~VT// ~A~]~%"
 218             (and (not (zerop indentation)) indentation)
 219             (maybe-qualified-name val) index
 220             documentation *protobuf-enum-comment-column* documentation)))
 221
 222 (defmethod write-schema-as ((type (eql :proto)) (alias protobuf-type-alias) stream
 223                             &key (indentation 0) more)
 224   (declare (ignore more))
 225   (with-prefixed-accessors (name lisp-type proto-type) (proto- alias)
 226     (let ((comment (format nil "Note: there is an alias ~A that maps Lisp ~(~S~) to Protobufs ~(~A~)"
 227                            name lisp-type proto-type)))
 228       (write-schema-documentation type comment stream :indentation indentation))
 229     (format stream "~&~@[~VT~]~%"
 230             (and (not (zerop indentation)) indentation))))
 231
 232 (defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
 233                             &key (indentation 0) more index arity)
 234   (declare (ignore more arity))
 235   (let ((*protobuf* message))
 236     (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
 237       (cond ((eq message-type :group)
 238              ;; If we've got a group, the printer for fields has already
 239              ;; printed a partial line (nice modularity, huh?)
 240              (format stream "group ~A = ~D {~%" name index)
 241              (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 242                (when other
 243                  (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 244                          (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 245              (when alias-for
 246                (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 247                        (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 248              (dolist (option options)
 249                (format stream "~&~VToption ~:/protobuf-option/;~%"
 250                        (+ indentation 2) option))
 251              (loop for (enum . more) on (proto-enums message) doing
 252                (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
 253              (loop for (field . more) on (proto-fields message) doing
 254                (write-schema-as type field stream
 255                                 :indentation (+ indentation 2) :more more :message message))
 256              (format stream "~&~@[~VT~]}~%"
 257                      (and (not (zerop indentation)) indentation)))
 258             (t
 259              (when documentation
 260                (write-schema-documentation type documentation stream :indentation indentation))
 261              (format stream "~&~@[~VT~]~A ~A {~%"
 262                      (and (not (zerop indentation)) indentation)
 263                      (if (eq message-type :message) "message" "extend")
 264                      (maybe-qualified-name message))
 265              (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 266                (when other
 267                  (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 268                          (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 269              (when alias-for
 270                (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 271                        (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 272              (dolist (option options)
 273                (format stream "~&~VToption ~:/protobuf-option/;~%"
 274                        (+ indentation 2) option))
 275              (cond ((eq message-type :extends)
 276                     (loop for (field . more) on (proto-extended-fields message) doing
 277                       (write-schema-as type field stream
 278                                        :indentation (+ indentation 2) :more more
 279                                        :message message)))
 280                    (t
 281                     (loop for (enum . more) on (proto-enums message) doing
 282                       (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
 283                     (loop for (msg . more) on (proto-messages message) doing
 284                       (unless (eq (proto-message-type msg) :group)
 285                         (write-schema-as type msg stream :indentation (+ indentation 2) :more more)))
 286                     (loop for (field . more) on (proto-fields message) doing
 287                       (write-schema-as type field stream
 288                                        :indentation (+ indentation 2) :more more
 289                                        :message message))
 290                     (loop for (extension . more) on (proto-extensions message) doing
 291                       (write-schema-as type extension stream :indentation (+ indentation 2) :more more))))
 292              (format stream "~&~@[~VT~]}~%"
 293                      (and (not (zerop indentation)) indentation)))))))
 294
 295 (defun maybe-qualified-name (x &optional name)
 296   "Given a message, return a fully qualified name if the short name
 297    is not sufficient to name the message in the current scope."
 298   (etypecase x
 299     ((or protobuf-message protobuf-enum  protobuf-enum-value
 300          protobuf-type-alias)
 301      (cond ((string= (make-qualified-name (proto-parent x) (proto-name x))
 302                      (proto-qualified-name x))
 303             (proto-name x))
 304            (t
 305             (proto-qualified-name x))))
 306     (null name)))
 307
 308 (defparameter *protobuf-field-comment-column* 56)
 309 (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream
 310                             &key (indentation 0) more message)
 311   (declare (ignore more))
 312   (with-prefixed-accessors (name documentation required type index packed options) (proto- field)
 313     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 314            (msg   (and (not (keywordp class))
 315                        (or (find-message message class)
 316                            (find-enum message class)
 317                            (find-type-alias message class)))))
 318       (cond ((and (typep msg 'protobuf-message)
 319                   (eq (proto-message-type msg) :group))
 320              (format stream "~&~@[~VT~]~(~A~) "
 321                      (and (not (zerop indentation)) indentation) required)
 322              (write-schema-as :proto msg stream :indentation indentation :index index :arity required))
 323             (t
 324              (let* ((defaultp (if (proto-alias-for message)
 325                                 ;; Special handling for imported CLOS classes
 326                                 (if (eq (proto-required field) :optional)
 327                                   nil
 328                                   (and (proto-default field)
 329                                        (not (equalp (proto-default field) #()))
 330                                        (not (empty-default-p field))))
 331                                 (not (empty-default-p field))))
 332                     (default  (proto-default field))
 333                     (default  (and defaultp
 334                                    (cond ((and (typep msg 'protobuf-enum)
 335                                                (or (stringp default) (symbolp default)))
 336                                           (let ((e (find default (proto-values msg)
 337                                                          :key #'proto-name :test #'string=)))
 338                                             (and e (proto-name e))))
 339                                          ((eq class :bool)
 340                                           (if (boolean-true-p default) "true" "false"))
 341                                          (t default))))
 342                     (default  (and defaultp
 343                                    (if (stringp default) (escape-string default) default))))
 344                (if (typep msg 'protobuf-type-alias)
 345                  (format stream "~&~@[~VT~]~(~A~) ~(~A~) ~A = ~D~
 346                                  ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
 347                                  ~:[~2*~;~VT// ~A~]~%"
 348                          (and (not (zerop indentation)) indentation)
 349                          required (proto-proto-type msg) name index
 350                          defaultp default packed options
 351                          t *protobuf-field-comment-column*
 352                          (format nil "alias maps Lisp ~(~S~) to Protobufs ~(~A~)"
 353                                  (proto-lisp-type msg) (proto-proto-type msg)))
 354                  (format stream (if (and (keywordp class) (not (eq class :bool)))
 355                                   ;; Keyword class means a primitive type, print default with ~S
 356                                   "~&~@[~VT~]~(~A~) ~A ~A = ~D~
 357                                    ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
 358                                    ~:[~2*~;~VT// ~A~]~%"
 359                                   ;; Non-keyword class means an enum type, print default with ~A"
 360                                   "~&~@[~VT~]~(~A~) ~A ~A = ~D~
 361                                    ~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
 362                                    ~:[~2*~;~VT// ~A~]~%")
 363                          (and (not (zerop indentation)) indentation)
 364                          required (maybe-qualified-name msg type) name index
 365                          defaultp default packed options
 366                          documentation *protobuf-field-comment-column* documentation))))))))
 367
 368 (defun escape-string (string)
 369   (if (every #'(lambda (ch) (and (standard-char-p ch) (graphic-char-p ch))) string)
 370     string
 371     (with-output-to-string (s)
 372       (loop for ch across string
 373             as esc = (escape-char ch)
 374             do (format s "~A" esc)))))
 375
 376 (defmethod write-schema-as ((type (eql :proto)) (extension protobuf-extension) stream
 377                             &key (indentation 0) more)
 378   (declare (ignore more))
 379   (with-prefixed-accessors (from to) (proto-extension- extension)
 380     (format stream "~&~@[~VT~]extensions ~D~:[~*~; to ~D~];~%"
 381             (and (not (zerop indentation)) indentation)
 382             from (not (eql from to)) (if (eql to #.(1- (ash 1 29))) "max" to))))
 383
 384 (defmethod write-schema-as ((type (eql :proto)) (service protobuf-service) stream
 385                             &key (indentation 0) more)
 386   (declare (ignore more))
 387   (with-prefixed-accessors (name documentation) (proto- service)
 388     (when documentation
 389       (write-schema-documentation type documentation stream :indentation indentation))
 390     (format stream "~&~@[~VT~]service ~A {~%"
 391             (and (not (zerop indentation)) indentation) name)
 392     (loop for (method . more) on (proto-methods service) doing
 393       (write-schema-as type method stream :indentation (+ indentation 2) :more more))
 394     (format stream "~&~@[~VT~]}~%"
 395             (and (not (zerop indentation)) indentation))))
 396
 397 (defmethod write-schema-as ((type (eql :proto)) (method protobuf-method) stream
 398                             &key (indentation 0) more)
 399   (declare (ignore more))
 400   (with-prefixed-accessors
 401       (name documentation input-name output-name streams-name options) (proto- method)
 402     (let* ((imsg (find-message *protobuf* input-name))
 403            (omsg (find-message *protobuf* output-name))
 404            (smsg (find-message *protobuf* streams-name))
 405            (iname (maybe-qualified-name imsg))
 406            (oname (maybe-qualified-name omsg))
 407            (sname (maybe-qualified-name smsg)))
 408       (when documentation
 409         (write-schema-documentation type documentation stream :indentation indentation))
 410       (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ streams (~A)~]~@[ returns (~A)~]"
 411               (and (not (zerop indentation)) indentation)
 412               name iname sname oname)
 413       (cond (options
 414              (format stream " {~%")
 415              (dolist (option options)
 416                (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
 417                        (+ indentation 2) option))
 418              (format stream "~@[~VT~]}"
 419                      (and (not (zerop indentation)) indentation)))
 420             (t
 421              (format stream ";~%"))))))
 422
 423
 424 ;;; Pretty print a schema as a .lisp file
 425
 426 (defvar *show-lisp-enum-indexes*  t)
 427 (defvar *show-lisp-field-indexes* t)
 428 (defvar *use-common-lisp-package* nil)
 429
 430 (defmethod write-schema-as ((type (eql :lisp)) (schema protobuf-schema) stream
 431                             &key (indentation 0)
 432                                  (show-field-indexes *show-lisp-field-indexes*)
 433                                  (show-enum-indexes *show-lisp-enum-indexes*)
 434                                  (use-common-lisp *use-common-lisp-package*))
 435   (with-prefixed-accessors (name class documentation package lisp-package imports) (proto- schema)
 436     (let* ((optimize (let ((opt (find-option schema "optimize_for")))
 437                        (and opt (cond ((string= opt "SPEED") :speed)
 438                                       ((string= opt "CODE_SIZE") :space)
 439                                       (t nil)))))
 440            (options  (remove-if #'(lambda (x) (string= (proto-name x) "optimize_for"))
 441                                 (proto-options schema)))
 442            (pkg      (and package (if (stringp package) package (string package))))
 443            (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
 444            (rpc-pkg  (and (or lisp-pkg pkg)
 445                           (format nil "~A-~A" (or lisp-pkg pkg) 'rpc)))
 446            (*show-lisp-enum-indexes*  show-enum-indexes)
 447            (*show-lisp-field-indexes* show-field-indexes)
 448            (*use-common-lisp-package* use-common-lisp)
 449            (*protobuf-package* (find-proto-package lisp-pkg))
 450            (*protobuf-rpc-package* (find-proto-package rpc-pkg))
 451            ;; If *protobuf-package* has not been defined, print symbols
 452            ;; from :common-lisp if *use-common-lisp-package* is true; or
 453            ;; :keyword otherwise.  This ensures that all symbols will be
 454            ;; read back correctly.
 455            ;; (The :keyword package does not use any other packages, so
 456            ;; all symbols will be printed with package prefixes.
 457            ;; Keywords are always printed as :keyword.)
 458            (*package* (or *protobuf-package*
 459                           (when *use-common-lisp-package* (find-package :common-lisp))
 460                           (find-package :keyword)))
 461            (exports (collect-exports schema)))
 462       (when rpc-pkg
 463         (let* ((pkg (string-upcase rpc-pkg))
 464                (rpc-exports (remove-if-not
 465                              #'(lambda (sym)
 466                                  (string=
 467                                   (package-name (symbol-package sym))
 468                                   pkg))
 469                              exports))
 470                (*package* (or *protobuf-rpc-package*
 471                               (when *use-common-lisp-package* (find-package :common-lisp))
 472                               (find-package :keyword))))
 473           (when rpc-exports
 474             (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
 475                             ~%  (cl:unless (cl:find-package \"~A\")~
 476                             ~%    (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
 477                             ~%(cl:in-package \"~A\")~
 478                             ~%(cl:export '(~{~A~^~%             ~}))~%~%"
 479                     pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
 480                     rpc-exports))))
 481       (when (or lisp-pkg pkg)
 482         (let ((pkg (string-upcase (or lisp-pkg pkg))))
 483           (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel)~
 484                           ~%  (cl:unless (cl:find-package \"~A\")~
 485                           ~%    (cl:defpackage ~A (:use~@[ ~(~S~)~]))))~
 486                           ~%(cl:in-package \"~A\")~
 487                           ~%(cl:export '(~{~A~^~%             ~}))~%~%"
 488                   pkg pkg (and *use-common-lisp-package* :common-lisp) pkg
 489                   (remove-if-not
 490                    #'(lambda (sym)
 491                        (string=
 492                         (package-name (symbol-package sym))
 493                         pkg))
 494                    exports))))
 495       (when documentation
 496         (write-schema-documentation type documentation stream :indentation indentation))
 497       (format stream "~&(proto:define-schema ~(~A~)" (or class name))
 498       (if (or pkg lisp-pkg imports optimize options documentation)
 499         (format stream "~%    (")
 500         (format stream " ("))
 501       (let ((spaces ""))
 502         (when pkg
 503           (format stream "~A:package \"~A\"" spaces pkg)
 504           (when (or lisp-pkg imports optimize options documentation)
 505             (terpri stream))
 506           (setq spaces "     "))
 507         (when lisp-pkg
 508           (format stream "~A:lisp-package \"~A\"" spaces lisp-pkg)
 509           (when (or imports optimize options documentation)
 510             (terpri stream))
 511           (setq spaces "     "))
 512         (when imports
 513           (cond ((= (length imports) 1)
 514                  (format stream "~A:import \"~A\"" spaces (car imports)))
 515                 (t
 516                  (format stream "~A:import (~{\"~A\"~^ ~})" spaces imports)))
 517           (when (or optimize options documentation)
 518             (terpri stream))
 519           (setq spaces "     "))
 520         (when optimize
 521           (format stream "~A:optimize ~(~S~)" spaces optimize)
 522           (when (or options documentation)
 523             (terpri stream))
 524           (setq spaces "     "))
 525         (when options
 526           (format stream "~A:options (~{~/protobuf-option/~^ ~})" spaces options)
 527           (when documentation
 528             (terpri stream))
 529           (setq spaces "     "))
 530         (when documentation
 531           (format stream "~A:documentation ~S" spaces documentation)))
 532       (format stream ")")
 533       (loop for (enum . more) on (proto-enums schema) doing
 534         (write-schema-as type enum stream :indentation 2 :more more))
 535       (loop for (alias . more) on (proto-type-aliases schema) doing
 536         (write-schema-as type alias stream :indentation 2 :more more))
 537       (loop for (msg . more) on (proto-messages schema) doing
 538         (write-schema-as type msg stream :indentation 2 :more more))
 539       (loop for (svc . more) on (proto-services schema) doing
 540         (write-schema-as type svc stream :indentation 2 :more more)))
 541     (format stream ")~%")))
 542
 543 (defmethod write-schema-documentation ((type (eql :lisp)) docstring stream
 544                                        &key (indentation 0))
 545   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 546     (dolist (line lines)
 547       (format stream "~&~@[~VT~];; ~A~%"
 548               (and (not (zerop indentation)) indentation) line))))
 549
 550 (defmethod write-schema-header ((type (eql :lisp)) (schema protobuf-schema) stream)
 551   (declare (ignorable type stream))
 552   nil)
 553
 554 (defmethod write-schema-as ((type (eql :lisp)) (enum protobuf-enum) stream
 555                             &key (indentation 0) more)
 556   (declare (ignore more))
 557   (terpri stream)
 558   (with-prefixed-accessors (name class alias-for
 559                             documentation source-location) (proto- enum)
 560     (when documentation
 561       (write-schema-documentation type documentation stream :indentation indentation))
 562     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 563             (and (not (zerop indentation)) indentation) class)
 564     (let ((other (and name (string/= name (class-name->proto class)) name)))
 565       (cond ((or other alias-for documentation source-location)
 566              (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
 567                                         ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 568                                         ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
 569                                         ~:[~*~;:source-location ~/source-location/~])"
 570                      (+ indentation 4)
 571                      other other (and (or alias-for documentation source-location) (+ indentation 5))
 572                      alias-for alias-for (and (or documentation source-location) (+ indentation 5))
 573                      documentation documentation (and source-location (+ indentation 5))
 574                      source-location source-location))
 575             (t
 576              (format stream " ()"))))
 577     (loop for (value . more) on (proto-values enum) doing
 578       (write-schema-as type value stream :indentation (+ indentation 2) :more more)
 579       (when more
 580         (terpri stream)))
 581     (format stream ")")))
 582
 583 (defmethod write-schema-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 584                             &key (indentation 0) more)
 585   (declare (ignore more))
 586   (with-prefixed-accessors (value index) (proto- val)
 587     (if *show-lisp-enum-indexes*
 588       (format stream "~&~@[~VT~](~(~A~) ~D)"
 589               (and (not (zerop indentation)) indentation) value index)
 590       (format stream "~&~@[~VT~]~(~A~)"
 591               (and (not (zerop indentation)) indentation) value))))
 592
 593 (defmethod write-schema-as ((type (eql :lisp)) (alias protobuf-type-alias) stream
 594                             &key (indentation 0) more)
 595   (declare (ignore more))
 596   (terpri stream)
 597   (with-prefixed-accessors (class lisp-type proto-type serializer deserializer) (proto- alias)
 598     (format stream "~@[~VT~](proto:define-type-alias ~(~S~)"
 599             (and (not (zerop indentation)) indentation) class)
 600     (format stream " ()")                       ;no options yet
 601     (format stream "~%~@[~VT~]:lisp-type ~(~S~)~
 602                     ~%~@[~VT~]:proto-type ~(~A~)~
 603                     ~%~@[~VT~]:serializer ~(~S~)~
 604                     ~%~@[~VT~]:deserializer ~(~S~))"
 605             (+ indentation 2) lisp-type
 606             (+ indentation 2) proto-type
 607             (+ indentation 2) serializer
 608             (+ indentation 2) deserializer)))
 609
 610 (defmethod write-schema-as ((type (eql :lisp)) (message protobuf-message) stream
 611                             &key (indentation 0) more index arity)
 612   (declare (ignore more))
 613   (let ((*protobuf* message))
 614     (with-prefixed-accessors (name class alias-for conc-name message-type
 615                               documentation source-location) (proto- message)
 616       (cond ((eq message-type :group)
 617              (when documentation
 618                (write-schema-documentation type documentation stream :indentation indentation))
 619              (format stream "~&~@[~VT~](proto:define-group ~(~S~)"
 620                      (and (not (zerop indentation)) indentation) class)
 621              (let ((other (and name (string/= name (class-name->proto class)) name)))
 622                (format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
 623                                           :arity ~(~S~)~@[~%~VT~]~
 624                                           ~:[~2*~;:name ~S~@[~%~VT~]~]~
 625                                           ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 626                                           ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 627                                           ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
 628                                           ~:[~*~;:source-location ~/source-location/~])"
 629                        (+ indentation 4)
 630                        index (+ indentation 5)
 631                        arity (and (or other alias-for conc-name documentation source-location) (+ indentation 5))
 632                        other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
 633                        alias-for alias-for (and (or conc-name documentation source-location) (+ indentation 5))
 634                        conc-name conc-name (and (or documentation source-location) (+ indentation 5))
 635                        documentation documentation (and source-location (+ indentation 5))
 636                        source-location source-location))
 637              (loop for (enum . more) on (proto-enums message) doing
 638                (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
 639                (when more
 640                  (terpri stream)))
 641              (loop for (field . more) on (proto-fields message) doing
 642                (write-schema-as type field stream
 643                                 :indentation (+ indentation 2) :more more
 644                                 :message message)
 645                (when more
 646                  (terpri stream))))
 647             (t
 648              (when documentation
 649                (write-schema-documentation type documentation stream :indentation indentation))
 650              (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
 651                      (and (not (zerop indentation)) indentation)
 652                      (if (eq message-type :message) "message" "extend") class)
 653              (let ((other (and name (string/= name (class-name->proto class)) name)))
 654                (cond ((eq message-type :extends)
 655                       (format stream " ()"))
 656                      ((or other alias-for conc-name documentation source-location)
 657                       (format stream "~%~@[~VT~](~:[~2*~;:name ~S~@[~%~VT~]~]~
 658                                                  ~:[~2*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 659                                                  ~:[~2*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 660                                                  ~:[~2*~;:documentation ~S~@[~%~VT~]~]~
 661                                                  ~:[~*~;:source-location ~/source-location/~])"
 662                               (+ indentation 4)
 663                               other other (and (or alias-for conc-name documentation source-location) (+ indentation 5))
 664                               alias-for alias-for (and (or conc-name documentation source-location) (+ indentation 5))
 665                               conc-name conc-name (and (or documentation source-location) (+ indentation 5))
 666                               documentation documentation (and source-location (+ indentation 5))
 667                               source-location source-location))
 668                      (t
 669                       (format stream " ()"))))
 670              (cond ((eq message-type :extends)
 671                     (loop for (field . more) on (proto-extended-fields message) doing
 672                       (write-schema-as type field stream
 673                                        :indentation (+ indentation 2) :more more
 674                                        :message message)
 675                       (when more
 676                         (terpri stream))))
 677                    (t
 678                     (loop for (enum . more) on (proto-enums message) doing
 679                       (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
 680                       (when more
 681                         (terpri stream)))
 682                     (loop for (msg . more) on (proto-messages message) doing
 683                       (unless (eq (proto-message-type msg) :group)
 684                         (write-schema-as type msg stream :indentation (+ indentation 2) :more more)
 685                         (when more
 686                           (terpri stream))))
 687                     (loop for (field . more) on (proto-fields message) doing
 688                       (write-schema-as type field stream
 689                                        :indentation (+ indentation 2) :more more
 690                                        :message message)
 691                       (when more
 692                         (terpri stream)))
 693                     (loop for (extension . more) on (proto-extensions message) doing
 694                       (write-schema-as type extension stream :indentation (+ indentation 2) :more more)
 695                       (when more
 696                         (terpri stream)))))))
 697       (format stream ")"))))
 698
 699 (defparameter *protobuf-slot-comment-column* 56)
 700 (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream
 701                             &key (indentation 0) more message)
 702   (with-prefixed-accessors (value required index packed options documentation) (proto- field)
 703     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 704            (msg   (and (not (keywordp class))
 705                        (or (find-message message class)
 706                            (find-enum message class)
 707                            (find-type-alias message class))))
 708            (type  (let ((cl (case class
 709                               ((:int32)       'int32)
 710                               ((:int64)       'int64)
 711                               ((:uint32)     'uint32)
 712                               ((:uint64)     'uint64)
 713                               ((:sint32)     'sint32)
 714                               ((:sint64)     'sint64)
 715                               ((:fixed32)   'fixed32)
 716                               ((:fixed64)   'fixed64)
 717                               ((:sfixed32) 'sfixed32)
 718                               ((:sfixed64) 'sfixed64)
 719                               ((:float)  'float)
 720                               ((:double) 'double-float)
 721                               ((:bool)   'boolean)
 722                               ((:string) 'string)
 723                               ((:bytes)  'byte-vector)
 724                               ((:symbol) 'symbol)
 725                               (otherwise class))))
 726                     (cond ((eq required :optional)
 727                            `(or null ,cl))
 728                           ((eq required :repeated)
 729                            (if (vector-field-p field)
 730                              `(vector-of ,cl)
 731                              `(list-of ,cl)))
 732                           (t cl)))))
 733       (cond ((and (typep msg 'protobuf-message)
 734                   (eq (proto-message-type msg) :group))
 735              (write-schema-as :lisp msg stream :indentation indentation :index index :arity required))
 736             (t
 737              (let* ((defaultp (if (proto-alias-for message)
 738                                 (if (eq (proto-required field) :optional)
 739                                   nil
 740                                   (and (proto-default field)
 741                                        (not (equalp (proto-default field) #()))
 742                                        (not (empty-default-p field))))
 743                                 (not (empty-default-p field))))
 744                     (default  (proto-default field))
 745                     (default  (and defaultp
 746                                    (cond ((and (typep msg 'protobuf-enum)
 747                                                (or (stringp default) (symbolp default)))
 748                                           (let ((e (find default (proto-values msg)
 749                                                          :key #'proto-name :test #'string=)))
 750                                             (and e (proto-value e))))
 751                                          ((eq class :bool)
 752                                           (boolean-true-p default))
 753                                          (t default))))
 754                     (default  (and defaultp
 755                                    (if (stringp default) (escape-string default) default)))
 756                     (conc-name (proto-conc-name message))
 757                     (reader (when (and (not (eq (proto-reader field) value))
 758                                        (not (string-equal (proto-reader field)
 759                                                           (format nil "~A~A" conc-name value))))
 760                               (proto-reader field)))
 761                     (writer (when (and (not (eq (proto-writer field) value))
 762                                        (not (string-equal (proto-writer field)
 763                                                           (format nil "~A~A" conc-name value))))
 764                               (proto-writer field)))
 765                     (slot-name (if *show-lisp-field-indexes*
 766                                  (format nil "(~(~S~) ~D)" value index)
 767                                  (format nil "~(~S~)" value))))
 768                (format stream (if (and (keywordp class) (not (eq class :bool)))
 769                                 ;; Keyword class means a primitive type, print default with ~S
 770                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
 771                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
 772                                  ~@[ :options (~{~/protobuf-option/~^ ~})~])~
 773                                  ~:[~2*~;~VT; ~A~]"
 774                                 ;; Non-keyword class means an enum type, print default with ~(~S~)
 775                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
 776                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
 777                                  ~@[ :options (~{~/protobuf-option/~^ ~})~])~
 778                                  ~:[~2*~;~VT; ~A~]")
 779                        (and (not (zerop indentation)) indentation)
 780                        slot-name type defaultp default reader writer packed options
 781                        ;; Don't write the comment if we'll insert a close paren after it
 782                        (and more documentation) *protobuf-slot-comment-column* documentation)))))))
 783
 784 (defmethod write-schema-as ((type (eql :lisp)) (extension protobuf-extension) stream
 785                             &key (indentation 0) more)
 786   (declare (ignore more))
 787   (with-prefixed-accessors (from to) (proto-extension- extension)
 788     (format stream "~&~@[~VT~](proto:define-extension ~D ~D)"
 789             (and (not (zerop indentation)) indentation)
 790             from (if (eql to #.(1- (ash 1 29))) "max" to))))
 791
 792 (defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
 793                             &key (indentation 0) more)
 794   (declare (ignore more))
 795   (with-prefixed-accessors (class documentation name source-location) (proto- service)
 796     (when documentation
 797       (write-schema-documentation type documentation stream :indentation indentation))
 798     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 799             (and (not (zerop indentation)) indentation) (proto-class service))
 800     (let ((other (and name (string/= name (class-name->proto (proto-class service))) name)))
 801       (cond ((or documentation other source-location)
 802              (format stream "~%~@[~VT~](~:[~2*~;:documentation ~S~@[~%~VT~]~]~
 803                                         ~:[~2*~;:name ~S~@[~%~VT~]~]~
 804                                         ~:[~*~;:source-location ~/source-location/~])"
 805                      (+ indentation 4)
 806                      documentation documentation (and (or documentation source-location) (+ indentation 5))
 807                      other other (and source-location (+ indentation 5))
 808                      source-location source-location))
 809             (t
 810              (format stream " ()"))))
 811     (loop for (method . more) on (proto-methods service) doing
 812       (write-schema-as type method stream :indentation (+ indentation 2) :more more)
 813       (when more
 814         (terpri stream)))
 815     (format stream ")")))
 816
 817 (defmethod write-schema-as ((type (eql :lisp)) (method protobuf-method) stream
 818                             &key (indentation 0) more)
 819   (declare (ignore more))
 820   (with-prefixed-accessors (class input-type output-type streams-type
 821                             name  input-name output-name streams-name
 822                             options documentation source-location) (proto- method)
 823     (when documentation
 824       (write-schema-documentation type documentation stream :indentation indentation))
 825     (format stream "~&~@[~VT~](~(~S~) (" (and (not (zerop indentation)) indentation) class)
 826     (if (and input-name (string/= (class-name->proto input-type) input-name))
 827         (format stream "(~(~S~) :name ~S) => " input-type input-name)
 828         (format stream "~(~S~) => " input-type))
 829     (if (and output-name (string/= (class-name->proto output-type) output-name))
 830         (format stream "(~(~S~) :name ~S)" output-type output-name)
 831         (format stream "~(~S~)" output-type))
 832     (when streams-type
 833       (if (and streams-name (string/= (class-name->proto streams-type) streams-name))
 834           (format stream " :streams (~(~S~) :name ~S)" streams-type streams-name)
 835           (format stream " :streams ~(~S~)" streams-type)))
 836     (format stream ")")
 837     (when (and name (string/= (class-name->proto name) name))
 838       (format stream "~%~VT:name ~S"
 839               (+ indentation 2) name))
 840     (when options
 841       (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
 842               (+ indentation 2) options))
 843     (format stream ")")))
 844
 845
 846 ;;; Collect symbols to be exported
 847
 848 (defgeneric collect-exports (schema)
 849   (:documentation
 850    "Collect all the symbols that should be exported from a Protobufs package"))
 851
 852 (defmethod collect-exports ((schema protobuf-schema))
 853   (delete-duplicates
 854    (delete-if #'null
 855     (append (mapcan #'collect-exports (proto-enums schema))
 856             (mapcan #'collect-exports (proto-messages schema))
 857             (mapcan #'collect-exports (proto-services schema))))
 858    :from-end t))
 859
 860 ;; Export just the type name
 861 (defmethod collect-exports ((enum protobuf-enum))
 862   (list (proto-class enum)))
 863
 864 ;; Export the class name and all of the accessor names
 865 (defmethod collect-exports ((message protobuf-message))
 866   (append (list (proto-class message))
 867           (mapcan #'collect-exports (proto-messages message))
 868           (mapcan #'collect-exports (proto-fields message))))
 869
 870 ;; Export just the slot accessor name
 871 (defmethod collect-exports ((field protobuf-field))
 872   (list (or (proto-reader field)
 873             (proto-slot field))))
 874
 875 ;; Export the names of all the methods
 876 (defmethod collect-exports ((service protobuf-service))
 877   (mapcan #'collect-exports (proto-methods service)))
 878
 879 ;; Export just the method name
 880 (defmethod collect-exports ((method protobuf-method))
 881   (list (proto-client-stub method) (proto-server-stub method)))