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