printer.lisp

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