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