printer.lisp

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