printer.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, 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 (name 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 (msg . more) on (proto-messages schema) doing
  65       (write-schema-as type msg stream :indentation indentation :more more)
  66       (terpri stream))
  67     (loop for (svc . more) on (proto-services schema) doing
  68       (write-schema-as type svc stream :indentation indentation :more more)
  69       (terpri stream))))
  70
  71 (defmethod write-schema-documentation ((type (eql :proto)) docstring stream
  72                                        &key (indentation 0))
  73   (let ((lines (split-string docstring :separators '(#\newline #\return))))
  74     (dolist (line lines)
  75       (format stream "~&~@[~VT~]// ~A~%"
  76               (and (not (zerop indentation)) indentation) line))))
  77
  78 ;; Lisp was born in 1958 :-)
  79 (defvar *lisp-options* '(("lisp_package" string 195801)
  80                          ("lisp_name"    string 195802)
  81                          ("lisp_alias"   string 195803)
  82                          ("lisp_type"    string 195804)
  83                          ("lisp_class"   string 195805)
  84                          ("lisp_slot"    string 195806)))
  85
  86 (defvar *option-types* '(("optimize_for"          symbol)
  87                          ("deprecated"            symbol)
  88                          ;; Keep the rest of these in alphabetical order
  89                          ("cc_api_version"       integer)
  90                          ("cc_generic_services"   symbol)
  91                          ("ctype"                 symbol)
  92                          ("go_package"            string)
  93                          ("java_api_version"     integer)
  94                          ("java_generic_services" symbol)
  95                          ("java_java5_enums"     boolean)
  96                          ("java_multiple_files"  boolean)
  97                          ("java_outer_classname"  string)
  98                          ("java_package"          string)
  99                          ("java_use_javaproto2"  boolean)
 100                          ("py_api_version"       integer)
 101                          ("py_generic_services"   symbol)))
 102
 103 (defmethod write-schema-header ((type (eql :proto)) (schema protobuf-schema) stream)
 104   (when (any-lisp-option schema)
 105     (format stream "~&import \"net/proto2/proto/descriptor.proto\";~%~%")
 106     (format stream "~&extend proto2.MessageOptions {~%")
 107     (loop for (option type index) in *lisp-options* doing
 108       (format stream "~&  optional ~(~A~) ~A = ~D;~%" type option index))
 109     (format stream "~&}~%~%")))
 110
 111 (defgeneric any-lisp-option (schema)
 112   (:documentation
 113    "Returns true iff there is anything in the schema that would require that
 114     the .proto file include and extend 'MessageOptions'.")
 115   (:method ((schema protobuf-schema))
 116     (labels ((find-one (protobuf)
 117                (dolist (enum (proto-enums protobuf))
 118                  (with-prefixed-accessors (name class alias-for) (proto- enum)
 119                    (when (or alias-for
 120                              (and class (not (string-equal name (class-name->proto class))) class))
 121                      (return-from any-lisp-option t))))
 122                (dolist (msg (proto-messages protobuf))
 123                  (with-prefixed-accessors (name class alias-for) (proto- msg)
 124                    (when (or alias-for
 125                              (and class (not (string-equal name (class-name->proto class))) class))
 126                      (return-from any-lisp-option t))))
 127                (map () #'find-one (proto-messages protobuf))))
 128       (find-one schema)
 129       nil)))
 130
 131 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
 132   (let ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
 133                   (proto-type option))))
 134     (cond (colon-p                              ;~:/protobuf-option/ -- .proto format
 135            (let ((fmt-control
 136                   (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
 137                          (if (eq type 'symbol) "(~A)~@[ = ~A~]" "(~A)~@[ = ~S~]"))
 138                         (t
 139                          (if (eq type 'symbol) "~A~@[ = ~A~]" "~A~@[ = ~S~]")))))
 140              (format stream fmt-control (proto-name option) (proto-value option))))
 141           (atsign-p                             ;~@/protobuf-option/ -- .lisp format
 142            (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
 143              (format stream fmt-control (proto-name option) (proto-value option))))
 144           (t                                    ;~/protobuf-option/  -- keyword/value format
 145            (let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S")))
 146              (format stream fmt-control (proto-name option) (proto-value option)))))))
 147
 148 (defmethod write-schema-as ((type (eql :proto)) (enum protobuf-enum) stream
 149                             &key (indentation 0) more)
 150   (declare (ignore more))
 151   (with-prefixed-accessors (name class alias-for documentation options) (proto- enum)
 152     (when documentation
 153       (write-schema-documentation type documentation stream :indentation indentation))
 154     (format stream "~&~@[~VT~]enum ~A {~%"
 155             (and (not (zerop indentation)) indentation) name)
 156     (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 157       (when other
 158         (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 159                 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 160     (when alias-for
 161       (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 162               (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 163     (dolist (option options)
 164       (format stream "~&option ~:/protobuf-option/;~%" option))
 165     (loop for (value . more) on (proto-values enum) doing
 166       (write-schema-as type value stream :indentation (+ indentation 2) :more more))
 167     (format stream "~&~@[~VT~]}~%"
 168             (and (not (zerop indentation)) indentation))))
 169
 170 (defparameter *protobuf-enum-comment-column* 56)
 171 (defmethod write-schema-as ((type (eql :proto)) (val protobuf-enum-value) stream
 172                             &key (indentation 0) more)
 173   (declare (ignore more))
 174   (with-prefixed-accessors (name documentation index) (proto- val)
 175     (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
 176             (and (not (zerop indentation)) indentation) name index
 177             documentation *protobuf-enum-comment-column* documentation)))
 178
 179
 180 (defmethod write-schema-as ((type (eql :proto)) (message protobuf-message) stream
 181                             &key (indentation 0) more index arity)
 182   (declare (ignore more arity))
 183   (with-prefixed-accessors (name class alias-for message-type documentation options) (proto- message)
 184     (cond ((eq message-type :group)
 185            ;; If we've got a group, the printer for fields has already
 186            ;; printed a partial line (nice modularity, huh?)
 187            (format stream "group ~A = ~D {~%" name index)
 188            (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 189              (when other
 190                (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 191                        (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 192            (when alias-for
 193              (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 194                      (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 195            (dolist (option options)
 196              (format stream "~&~VToption ~:/protobuf-option/;~%"
 197                      (+ indentation 2) option))
 198            (loop for (enum . more) on (proto-enums message) doing
 199              (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
 200            (loop for (field . more) on (proto-fields message) doing
 201              (write-schema-as type field stream
 202                               :indentation (+ indentation 2) :more more :message message))
 203            (format stream "~&~@[~VT~]}~%"
 204                    (and (not (zerop indentation)) indentation)))
 205           (t
 206            (when documentation
 207              (write-schema-documentation type documentation stream :indentation indentation))
 208            (format stream "~&~@[~VT~]~A ~A {~%"
 209                    (and (not (zerop indentation)) indentation)
 210                    (if (eq message-type :message) "message" "extend") name)
 211            (let ((other (and class (not (string-equal name (class-name->proto class))) class)))
 212              (when other
 213                (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 214                        (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 215            (when alias-for
 216              (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 217                      (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 218            (dolist (option options)
 219              (format stream "~&~VToption ~:/protobuf-option/;~%"
 220                      (+ indentation 2) option))
 221            (cond ((eq message-type :extends)
 222                   (loop for (field . more) on (proto-extended-fields message) doing
 223                     (write-schema-as type field stream
 224                                      :indentation (+ indentation 2) :more more
 225                                      :message message)))
 226                  (t
 227                   (loop for (enum . more) on (proto-enums message) doing
 228                     (write-schema-as type enum stream :indentation (+ indentation 2) :more more))
 229                   (loop for (msg . more) on (proto-messages message) doing
 230                     (unless (eq (proto-message-type msg) :group)
 231                       (write-schema-as type msg stream :indentation (+ indentation 2) :more more)))
 232                   (loop for (field . more) on (proto-fields message) doing
 233                     (write-schema-as type field stream
 234                                      :indentation (+ indentation 2) :more more
 235                                      :message message))
 236                   (loop for (extension . more) on (proto-extensions message) doing
 237                     (write-schema-as type extension stream :indentation (+ indentation 2) :more more))))
 238            (format stream "~&~@[~VT~]}~%"
 239                    (and (not (zerop indentation)) indentation))))))
 240
 241 (defparameter *protobuf-field-comment-column* 56)
 242 (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream
 243                             &key (indentation 0) more message)
 244   (declare (ignore more))
 245   (with-prefixed-accessors (name documentation required type index packed options) (proto- field)
 246     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 247            (msg   (and (not (keywordp class))
 248                        (or (find-message message class) (find-enum message class)))))
 249       (cond ((and (typep msg 'protobuf-message)
 250                   (eq (proto-message-type msg) :group))
 251              (format stream "~&~@[~VT~]~(~A~) "
 252                      (and (not (zerop indentation)) indentation) required)
 253              (write-schema-as :proto msg stream :indentation indentation :index index :arity required))
 254             (t
 255              (let* ((defaultp (if (proto-alias-for message)
 256                                 ;; Special handling for imported CLOS classes
 257                                 (if (eq (proto-required field) :optional)
 258                                   nil
 259                                   (and (proto-default field)
 260                                        (not (equalp (proto-default field) #()))
 261                                        (not (empty-default-p field))))
 262                                 (not (empty-default-p field))))
 263                     (default  (proto-default field))
 264                     (default  (and defaultp
 265                                    (cond ((and (typep msg 'protobuf-enum)
 266                                                (or (stringp default) (symbolp default)))
 267                                           (let ((e (find default (proto-values msg)
 268                                                          :key #'proto-name :test #'string=)))
 269                                             (and e (proto-name e))))
 270                                          ((eq class :bool)
 271                                           (if (boolean-true-p default) "true" "false"))
 272                                          (t default))))
 273                     (default  (and defaultp
 274                                    (if (stringp default) (escape-string default) default))))
 275                (format stream (if (and (keywordp class) (not (eq class :bool)))
 276                                 ;; Keyword class means a primitive type, print default with ~S
 277                                 "~&~@[~VT~]~(~A~) ~A ~A = ~D~
 278                                  ~:[~*~; [default = ~S]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
 279                                  ~:[~*~*~;~VT// ~A~]~%"
 280                                 ;; Non-keyword class means an enum type, print default with ~A"
 281                                 "~&~@[~VT~]~(~A~) ~A ~A = ~D~
 282                                  ~:[~*~; [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
 283                                  ~:[~*~*~;~VT// ~A~]~%")
 284                        (and (not (zerop indentation)) indentation)
 285                        required type name index defaultp default packed options
 286                        documentation *protobuf-field-comment-column* documentation)))))))
 287
 288 (defun escape-string (string)
 289   (if (every #'(lambda (ch) (and (standard-char-p ch) (graphic-char-p ch))) string)
 290     string
 291     (with-output-to-string (s)
 292       (loop for ch across string
 293             as esc = (escape-char ch)
 294             do (format s "~A" esc)))))
 295
 296 (defmethod write-schema-as ((type (eql :proto)) (extension protobuf-extension) stream
 297                             &key (indentation 0) more)
 298   (declare (ignore more))
 299   (with-prefixed-accessors (from to) (proto-extension- extension)
 300     (format stream "~&~@[~VT~]extensions ~D~:[~*~; to ~D~];~%"
 301             (and (not (zerop indentation)) indentation)
 302             from (not (eql from to)) (if (eql to #.(1- (ash 1 29))) "max" to))))
 303
 304
 305 (defmethod write-schema-as ((type (eql :proto)) (service protobuf-service) stream
 306                             &key (indentation 0) more)
 307   (declare (ignore more))
 308   (with-prefixed-accessors (name documentation) (proto- service)
 309     (when documentation
 310       (write-schema-documentation type documentation stream :indentation indentation))
 311     (format stream "~&~@[~VT~]service ~A {~%"
 312             (and (not (zerop indentation)) indentation) name)
 313     (loop for (method . more) on (proto-methods service) doing
 314       (write-schema-as type method stream :indentation (+ indentation 2) :more more))
 315     (format stream "~&~@[~VT~]}~%"
 316             (and (not (zerop indentation)) indentation))))
 317
 318 (defmethod write-schema-as ((type (eql :proto)) (method protobuf-method) stream
 319                             &key (indentation 0) more)
 320   (declare (ignore more))
 321   (with-prefixed-accessors (name documentation input-name output-name options) (proto- method)
 322     (when documentation
 323       (write-schema-documentation type documentation stream :indentation indentation))
 324     (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
 325             (and (not (zerop indentation)) indentation)
 326             name input-name output-name)
 327     (cond (options
 328            (format stream " {~%")
 329            (dolist (option options)
 330              (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
 331                      (+ indentation 2) option))
 332            (format stream "~@[~VT~]}"
 333                    (and (not (zerop indentation)) indentation)))
 334           (t
 335            (format stream ";~%")))))
 336
 337
 338 ;;; Pretty print a schema as a .lisp file
 339
 340 (defvar *show-lisp-enum-indexes* t)
 341 (defvar *show-lisp-field-indexes* t)
 342
 343 (defmethod write-schema-as ((type (eql :lisp)) (schema protobuf-schema) stream
 344                             &key (indentation 0)
 345                                  (show-field-indexes *show-lisp-field-indexes*)
 346                                  (show-enum-indexes *show-lisp-enum-indexes*))
 347   (with-prefixed-accessors (name class documentation package lisp-package imports) (proto- schema)
 348     (let* ((optimize (let ((opt (find-option schema "optimize_for")))
 349                        (and opt (cond ((string= opt "SPEED") :speed)
 350                                       ((string= opt "CODE_SIZE") :space)
 351                                       (t nil)))))
 352            (options  (remove-if #'(lambda (x) (string= (proto-name x) "optimize_for"))
 353                                 (proto-options schema)))
 354            (pkg      (and package (if (stringp package) package (string package))))
 355            (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
 356            (*show-lisp-enum-indexes* show-enum-indexes)
 357            (*show-lisp-field-indexes* show-field-indexes)
 358            (*protobuf-package* (or (find-package lisp-pkg)
 359                                    (find-package (string-upcase lisp-pkg))
 360                                    *package*))
 361            (*package* *protobuf-package*))
 362       (when (or lisp-pkg pkg)
 363         (let ((pkg (string-upcase (or lisp-pkg pkg))))
 364           (format stream "~&(eval-when (:execute :compile-toplevel :load-toplevel) ~
 365                           ~%  (unless (find-package \"~A\") ~
 366                           ~%    (defpackage ~A (:use :COMMON-LISP :PROTOBUFS)))) ~
 367                           ~%(in-package \"~A\")~%~%"
 368                   pkg pkg pkg)))
 369       (when documentation
 370         (write-schema-documentation type documentation stream :indentation indentation))
 371       (format stream "~&(proto:define-schema ~(~A~)" (or class name))
 372       (if (or pkg lisp-pkg imports optimize options documentation)
 373         (format stream "~%    (")
 374         (format stream " ("))
 375       (let ((spaces ""))
 376         (when pkg
 377           (format stream "~A:package \"~A\"" spaces pkg)
 378           (when (or lisp-pkg imports optimize options documentation)
 379             (terpri stream))
 380           (setq spaces "     "))
 381         (when lisp-pkg
 382           (format stream "~A:lisp-package \"~A\"" spaces lisp-pkg)
 383           (when (or imports optimize options documentation)
 384             (terpri stream))
 385           (setq spaces "     "))
 386         (when imports
 387           (cond ((= (length imports) 1)
 388                  (format stream "~A:import \"~A\"" spaces (car imports)))
 389                 (t
 390                  (format stream "~A:import (~{\"~A\"~^ ~})" spaces imports)))
 391           (when (or optimize options documentation)
 392             (terpri stream))
 393           (setq spaces "     "))
 394         (when optimize
 395           (format stream "~A:optimize ~(~S~)" spaces optimize)
 396           (when (or options documentation)
 397             (terpri stream))
 398           (setq spaces "     "))
 399         (when options
 400           (format stream "~A:options (~{~@/protobuf-option/~^ ~})" spaces options)
 401           (when documentation
 402             (terpri stream))
 403           (setq spaces "     "))
 404         (when documentation
 405           (format stream "~A:documentation ~S" spaces documentation)))
 406       (format stream ")")
 407       (loop for (enum . more) on (proto-enums schema) doing
 408         (write-schema-as type enum stream :indentation 2 :more more))
 409       (loop for (msg . more) on (proto-messages schema) doing
 410         (write-schema-as type msg stream :indentation 2 :more more))
 411       (loop for (svc . more) on (proto-services schema) doing
 412         (write-schema-as type svc stream :indentation 2 :more more)))
 413     (format stream ")~%")))
 414
 415 (defmethod write-schema-documentation ((type (eql :lisp)) docstring stream
 416                                        &key (indentation 0))
 417   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 418     (dolist (line lines)
 419       (format stream "~&~@[~VT~];; ~A~%"
 420               (and (not (zerop indentation)) indentation) line))))
 421
 422 (defmethod write-schema-header ((type (eql :lisp)) (schema protobuf-schema) stream)
 423   (declare (ignorable type stream))
 424   nil)
 425
 426 (defmethod write-schema-as ((type (eql :lisp)) (enum protobuf-enum) stream
 427                             &key (indentation 0) more)
 428   (declare (ignore more))
 429   (terpri stream)
 430   (with-prefixed-accessors (name class alias-for documentation) (proto- enum)
 431     (when documentation
 432       (write-schema-documentation type documentation stream :indentation indentation))
 433     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 434             (and (not (zerop indentation)) indentation) class)
 435     (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
 436       (cond ((or other alias-for documentation)
 437              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 438                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 439                                         ~:[~*~;:documentation ~S~])"
 440                      (+ indentation 4)
 441                      other other (and (or alias-for documentation) (+ indentation 5))
 442                      alias-for alias-for (and documentation (+ indentation 5))
 443                      documentation documentation))
 444             (t
 445              (format stream " ()"))))
 446     (loop for (value . more) on (proto-values enum) doing
 447       (write-schema-as type value stream :indentation (+ indentation 2) :more more)
 448       (when more
 449         (terpri stream)))
 450     (format stream ")")))
 451
 452 (defmethod write-schema-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 453                             &key (indentation 0) more)
 454   (declare (ignore more))
 455   (with-prefixed-accessors (value index) (proto- val)
 456     (if *show-lisp-enum-indexes*
 457       (format stream "~&~@[~VT~](~(~A~) ~D)"
 458               (and (not (zerop indentation)) indentation) value index)
 459       (format stream "~&~@[~VT~]~(~A~)"
 460               (and (not (zerop indentation)) indentation) value))))
 461
 462
 463 (defmethod write-schema-as ((type (eql :lisp)) (message protobuf-message) stream
 464                             &key (indentation 0) more index arity)
 465   (declare (ignore more))
 466   (with-prefixed-accessors (name class alias-for conc-name message-type documentation) (proto- message)
 467     (cond ((eq message-type :group)
 468            (when documentation
 469              (write-schema-documentation type documentation stream :indentation indentation))
 470            (format stream "~&~@[~VT~](proto:define-group ~(~S~)"
 471                    (and (not (zerop indentation)) indentation) class)
 472            (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
 473              (format stream "~%~@[~VT~](:index ~D~@[~%~VT~]~
 474                                         :arity ~(~S~)~@[~%~VT~]~
 475                                         ~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 476                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 477                                         ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 478                                         ~:[~*~;:documentation ~S~])"
 479                      (+ indentation 4)
 480                      index (+ indentation 5)
 481                      arity (and (or other alias-for conc-name documentation) (+ indentation 5))
 482                      other other (and (or alias-for conc-name documentation) (+ indentation 5))
 483                      alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
 484                      conc-name conc-name (and documentation (+ indentation 5))
 485                      documentation documentation))
 486            (loop for (enum . more) on (proto-enums message) doing
 487              (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
 488              (when more
 489                (terpri stream)))
 490            (loop for (field . more) on (proto-fields message) doing
 491              (write-schema-as type field stream
 492                               :indentation (+ indentation 2) :more more
 493                               :message message)
 494              (when more
 495                (terpri stream))))
 496           (t
 497            (when documentation
 498              (write-schema-documentation type documentation stream :indentation indentation))
 499            (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
 500                    (and (not (zerop indentation)) indentation)
 501                    (if (eq message-type :message) "message" "extend") class)
 502            (let ((other (and name (not (string-equal name (class-name->proto class))) name)))
 503              (cond ((eq message-type :extends)
 504                     (format stream " ()"))
 505                    ((or other alias-for conc-name documentation)
 506                     (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 507                                                ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 508                                                ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 509                                                ~:[~*~;:documentation ~S~])"
 510                             (+ indentation 4)
 511                             other other (and (or alias-for conc-name documentation) (+ indentation 5))
 512                             alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
 513                             conc-name conc-name (and documentation (+ indentation 5))
 514                             documentation documentation))
 515                    (t
 516                     (format stream " ()"))))
 517            (cond ((eq message-type :extends)
 518                   (loop for (field . more) on (proto-extended-fields message) doing
 519                     (write-schema-as type field stream
 520                                      :indentation (+ indentation 2) :more more
 521                                      :message message)
 522                     (when more
 523                       (terpri stream))))
 524                  (t
 525                   (loop for (enum . more) on (proto-enums message) doing
 526                     (write-schema-as type enum stream :indentation (+ indentation 2) :more more)
 527                     (when more
 528                       (terpri stream)))
 529                   (loop for (msg . more) on (proto-messages message) doing
 530                     (unless (eq (proto-message-type msg) :group)
 531                       (write-schema-as type msg stream :indentation (+ indentation 2) :more more)
 532                       (when more
 533                         (terpri stream))))
 534                   (loop for (field . more) on (proto-fields message) doing
 535                     (write-schema-as type field stream
 536                                      :indentation (+ indentation 2) :more more
 537                                      :message message)
 538                     (when more
 539                       (terpri stream)))
 540                   (loop for (extension . more) on (proto-extensions message) doing
 541                     (write-schema-as type extension stream :indentation (+ indentation 2) :more more)
 542                     (when more
 543                       (terpri stream)))))))
 544     (format stream ")")))
 545
 546 (defparameter *protobuf-slot-comment-column* 56)
 547 (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream
 548                             &key (indentation 0) more message)
 549   (with-prefixed-accessors (value required index packed options documentation) (proto- field)
 550     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 551            (msg   (and (not (keywordp class))
 552                        (or (find-message message class) (find-enum message class))))
 553            (type  (let ((cl (case class
 554                               ((:int32)       'int32)
 555                               ((:int64)       'int64)
 556                               ((:uint32)     'uint32)
 557                               ((:uint64)     'uint64)
 558                               ((:sint32)     'sint32)
 559                               ((:sint64)     'sint64)
 560                               ((:fixed32)   'fixed32)
 561                               ((:fixed64)   'fixed64)
 562                               ((:sfixed32) 'sfixed32)
 563                               ((:sfixed64) 'sfixed64)
 564                               ((:float)  'float)
 565                               ((:double) 'double-float)
 566                               ((:bool)   'boolean)
 567                               ((:string) 'string)
 568                               ((:bytes)  'byte-vector)
 569                               ((:symbol) 'symbol)
 570                               (otherwise class))))
 571                     (cond ((eq required :optional)
 572                            `(or null ,cl))
 573                           ((eq required :repeated)
 574                            (if (eq (proto-default field) $empty-vector)
 575                              `(vector-of ,cl)
 576                              `(list-of ,cl)))
 577                           (t cl)))))
 578       (cond ((and (typep msg 'protobuf-message)
 579                   (eq (proto-message-type msg) :group))
 580              (write-schema-as :lisp msg stream :indentation indentation :index index :arity required))
 581             (t
 582              (let* ((defaultp (if (proto-alias-for message)
 583                                 (if (eq (proto-required field) :optional)
 584                                   nil
 585                                   (and (proto-default field)
 586                                        (not (equalp (proto-default field) #()))
 587                                        (not (empty-default-p field))))
 588                                 (not (empty-default-p field))))
 589                     (default  (proto-default field))
 590                     (default  (and defaultp
 591                                    (cond ((and (typep msg 'protobuf-enum)
 592                                                (or (stringp default) (symbolp default)))
 593                                           (let ((e (find default (proto-values msg)
 594                                                          :key #'proto-name :test #'string=)))
 595                                             (and e (proto-value e))))
 596                                          ((eq class :bool)
 597                                           (boolean-true-p default))
 598                                          (t default))))
 599                     (default  (and defaultp
 600                                    (if (stringp default) (escape-string default) default)))
 601                     (reader (unless (eq (proto-reader field) value) (proto-reader field)))
 602                     (writer (unless (eq (proto-writer field) value) (proto-writer field)))
 603                     (slot-name (if *show-lisp-field-indexes*
 604                                  (format nil "(~(~S~) ~D)" value index)
 605                                  (format nil "~(~S~)" value))))
 606                (format stream (if (and (keywordp class) (not (eq class :bool)))
 607                                 ;; Keyword class means a primitive type, print default with ~S
 608                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~S~]~
 609                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
 610                                  ~@[ :options (~{~@/protobuf-option/~^ ~})~])~
 611                                  ~:[~*~*~;~VT; ~A~]"
 612                                 ;; Non-keyword class means an enum type, print default with ~(~S~)
 613                                 "~&~@[~VT~](~A :type ~(~S~)~:[~*~; :default ~(~S~)~]~
 614                                  ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~]~@[ :packed ~(~S~)~]~
 615                                  ~@[ :options (~{~@/protobuf-option/~^ ~})~])~
 616                                  ~:[~*~*~;~VT; ~A~]")
 617                        (and (not (zerop indentation)) indentation)
 618                        slot-name type defaultp default reader writer packed options
 619                        ;; Don't write the comment if we'll insert a close paren after it
 620                        (and more documentation) *protobuf-slot-comment-column* documentation)))))))
 621
 622 (defmethod write-schema-as ((type (eql :lisp)) (extension protobuf-extension) stream
 623                             &key (indentation 0) more)
 624   (declare (ignore more))
 625   (with-prefixed-accessors (from to) (proto-extension- extension)
 626     (format stream "~&~@[~VT~](proto:define-extension ~D ~D)"
 627             (and (not (zerop indentation)) indentation)
 628             from (if (eql to #.(1- (ash 1 29))) "max" to))))
 629
 630
 631 (defmethod write-schema-as ((type (eql :lisp)) (service protobuf-service) stream
 632                             &key (indentation 0) more)
 633   (declare (ignore more))
 634   (with-prefixed-accessors (class documentation conc-name) (proto- service)
 635     (when documentation
 636       (write-schema-documentation type documentation stream :indentation indentation))
 637     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 638             (and (not (zerop indentation)) indentation) (proto-class service))
 639     (cond (documentation
 640            (format stream "~%~@[~VT~](:documentation ~S)"
 641                    (+ indentation 4) documentation))
 642           (t
 643            (format stream " ()")))
 644     (loop for (method . more) on (proto-methods service) doing
 645       (write-schema-as type method stream :indentation (+ indentation 2) :more more)
 646       (when more
 647         (terpri stream)))
 648     (format stream ")")))
 649
 650 (defmethod write-schema-as ((type (eql :lisp)) (method protobuf-method) stream
 651                             &key (indentation 0) more)
 652   (declare (ignore more))
 653   (with-prefixed-accessors
 654       (function documentation input-type output-type options) (proto- method)
 655     (when documentation
 656       (write-schema-documentation type documentation stream :indentation indentation))
 657     (format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
 658             (and (not (zerop indentation)) indentation)
 659             function input-type output-type)
 660     (when options
 661       (format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
 662               (+ indentation 2) options))
 663     (format stream ")")))