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