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 &key (stream *standard-output*) (type :proto))
  17   "Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
  18    the given stream 'stream'in the format given by 'type' (:proto, :text, etc)."
  19    (let ((*protobuf* protobuf))
  20      (write-protobuf-as type protobuf stream)))
  21
  22 (defgeneric write-protobuf-as (type protobuf stream &key indentation)
  23   (:documentation
  24    "Writes the protobuf object 'protobuf' (schema, message, enum, etc) onto
  25     the given stream 'stream' in the format given by 'type' (:proto, :text, etc)."))
  26
  27 (defgeneric write-protobuf-documentation (type docstring stream &key indentation)
  28   (:documentation
  29    "Writes the docstring as a \"block comment\" onto the given stream 'stream'
  30     in the format given by 'type' (:proto, :text, etc)."))
  31
  32
  33 ;;; Pretty print a schema as a .proto file
  34
  35 (defmethod write-protobuf-as ((type (eql :proto)) (protobuf protobuf) stream
  36                               &key (indentation 0))
  37   (with-prefixed-accessors (name documentation syntax package imports optimize options) (proto- protobuf)
  38     (when documentation
  39       (write-protobuf-documentation type documentation stream :indentation indentation))
  40     (when syntax
  41       (format stream "~&syntax = \"~A\";~%~%" syntax))
  42     (when package
  43       (format stream "~&package ~A;~%~%" (substitute #\_ #\- package)))
  44     (when imports
  45       (dolist (import imports)
  46         (format stream "~&import \"~A\";~%" import))
  47       (terpri stream))
  48     (write-protobuf-header type stream)
  49     (when optimize
  50       (format stream "~&option optimize_for ~A;~%~%"
  51               (if (eq optimize :space) "CODE_SIZE" "SPEED")))
  52     (when options
  53       (dolist (option options)
  54         (format stream "~&option ~:/protobuf-option/;~%" option))
  55       (terpri stream))
  56     (dolist (enum (proto-enums protobuf))
  57       (write-protobuf-as type enum stream :indentation indentation)
  58       (terpri stream))
  59     (dolist (msg (proto-messages protobuf))
  60       (write-protobuf-as type msg stream :indentation indentation)
  61       (terpri stream))
  62     (dolist (svc (proto-services protobuf))
  63       (write-protobuf-as type svc stream :indentation indentation)
  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
  77 (defmethod write-protobuf-header ((type (eql :proto)) stream)
  78   (format stream "~&import \"net/proto2/proto/descriptor.proto\"~%~%")
  79   (format stream "~&extend proto2.MessageOptions {~%")
  80   (loop for (option type index) in *lisp-options* doing
  81     (format stream "~&  optional ~A ~A = ~D;~%" type option index))
  82   (format stream "~&}~%~%"))
  83
  84 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
  85   (cond (colon-p                                ;~:/protobuf-option/ -- .proto format
  86          (if (find (proto-name option) *lisp-options* :key #'first :test #'string=)
  87            (format stream "(~A)~@[ = ~S~]" (proto-name option) (proto-value option))
  88            (format stream "~A~@[ = ~S~]" (proto-name option) (proto-value option))))
  89         (atsign-p                               ;~@/protobuf-option/ -- .lisp format
  90          (format stream "~S ~S" (proto-name option) (proto-value option)))
  91         (t                                      ;~/protobuf-option/  -- keyword/value format
  92          (format stream "~(:~A~) ~S" (proto-name option) (proto-value option)))))
  93
  94 (defmethod write-protobuf-as ((type (eql :proto)) (enum protobuf-enum) stream
  95                               &key (indentation 0))
  96   (with-prefixed-accessors (name class alias-for documentation options) (proto- enum)
  97     (when documentation
  98       (write-protobuf-documentation type documentation stream :indentation indentation))
  99     (format stream "~&~@[~VT~]enum ~A {~%"
 100             (and (not (zerop indentation)) indentation) name)
 101     (let ((other (and class (not (string= name (class-name->proto class))) class)))
 102       (when other
 103         (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 104                 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 105     (when alias-for
 106       (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 107               (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 108     (dolist (option options)
 109       (format stream "~&option ~:/protobuf-option/;~%" option))
 110     (dolist (value (proto-values enum))
 111       (write-protobuf-as type value stream :indentation (+ indentation 2)))
 112     (format stream "~&~@[~VT~]}~%"
 113             (and (not (zerop indentation)) indentation))))
 114
 115 (defparameter *protobuf-enum-comment-column* 56)
 116 (defmethod write-protobuf-as ((type (eql :proto)) (val protobuf-enum-value) stream
 117                               &key (indentation 0))
 118   (with-prefixed-accessors (name documentation index) (proto- val)
 119     (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
 120             (and (not (zerop indentation)) indentation) name index
 121             documentation *protobuf-enum-comment-column* documentation)))
 122
 123
 124 (defmethod write-protobuf-as ((type (eql :proto)) (message protobuf-message) stream
 125                               &key (indentation 0))
 126   (with-prefixed-accessors (name class alias-for extension-p documentation options) (proto- message)
 127     (when documentation
 128       (write-protobuf-documentation type documentation stream :indentation indentation))
 129     (format stream "~&~@[~VT~]~A ~A {~%"
 130             (and (not (zerop indentation)) indentation)
 131             (if extension-p "extend" "message") name)
 132     (let ((other (and class (not (string= name (class-name->proto class))) class)))
 133       (when other
 134         (format stream "~&~VToption (lisp_name) = \"~A:~A\";~%"
 135                 (+ indentation 2) (package-name (symbol-package class)) (symbol-name class))))
 136     (when alias-for
 137       (format stream "~&~VToption (lisp_alias) = \"~A:~A\";~%"
 138               (+ indentation 2) (package-name (symbol-package alias-for)) (symbol-name alias-for)))
 139     (dolist (option options)
 140       (format stream "~&~VToption ~:/protobuf-option/;~%"
 141               (+ indentation 2) option))
 142     (cond (extension-p
 143            (dolist (field (proto-fields message))
 144              (when (proto-extension-p field)
 145                (write-protobuf-as type field stream :indentation (+ indentation 2)))))
 146           (t
 147            (dolist (enum (proto-enums message))
 148              (write-protobuf-as type enum stream :indentation (+ indentation 2)))
 149            (dolist (msg (proto-messages message))
 150              (write-protobuf-as type msg stream :indentation (+ indentation 2)))
 151            (dolist (field (proto-fields message))
 152              (write-protobuf-as type field stream :indentation (+ indentation 2)))
 153            (dolist (extension (proto-extensions message))
 154              (write-protobuf-as type extension stream :indentation (+ indentation 2)))))
 155     (format stream "~&~@[~VT~]}~%"
 156             (and (not (zerop indentation)) indentation))))
 157
 158 (defparameter *protobuf-field-comment-column* 56)
 159 (defmethod write-protobuf-as ((type (eql :proto)) (field protobuf-field) stream
 160                               &key (indentation 0))
 161   (with-prefixed-accessors (name documentation required index default packed) (proto- field)
 162     (let ((dflt (if (stringp default)
 163                   (if (i= (length default) 0) nil default)
 164                   default)))
 165       (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
 166               (and (not (zerop indentation)) indentation)
 167               required (proto-type field) name index dflt packed
 168               documentation *protobuf-field-comment-column* documentation))))
 169
 170 (defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
 171                               &key (indentation 0))
 172   (with-prefixed-accessors (from to) (proto-extension- extension)
 173     (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
 174             (and (not (zerop indentation)) indentation)
 175             from (if (eql to #.(1- (ash 1 29))) "max" to))))
 176
 177
 178 (defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
 179                               &key (indentation 0))
 180   (with-prefixed-accessors (name documentation) (proto- service)
 181     (when documentation
 182       (write-protobuf-documentation type documentation stream :indentation indentation))
 183     (format stream "~&~@[~VT~]service ~A {~%"
 184             (and (not (zerop indentation)) indentation) name)
 185     (dolist (method (proto-methods service))
 186       (write-protobuf-as type method stream :indentation (+ indentation 2)))
 187     (format stream "~&~@[~VT~]}~%"
 188             (and (not (zerop indentation)) indentation))))
 189
 190 (defmethod write-protobuf-as ((type (eql :proto)) (method protobuf-method) stream
 191                               &key (indentation 0))
 192   (with-prefixed-accessors (name documentation input-name output-name options) (proto- method)
 193     (when documentation
 194       (write-protobuf-documentation type documentation stream :indentation indentation))
 195     (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
 196             (and (not (zerop indentation)) indentation)
 197             name input-name output-name)
 198     (cond (options
 199            (format stream " {~%")
 200            (dolist (option options)
 201              (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
 202                      (+ indentation 2) option))
 203            (format stream "~@[~VT~]}"
 204                    (and (not (zerop indentation)) indentation)))
 205           (t
 206            (format stream ";~%")))))
 207
 208
 209 ;;; Pretty print a schema as a .lisp file
 210
 211 (defmethod write-protobuf-as ((type (eql :lisp)) (protobuf protobuf) stream
 212                               &key (indentation 0))
 213   (with-prefixed-accessors (name class documentation package lisp-package imports optimize options) (proto- protobuf)
 214     (let ((lisp-pkg (and lisp-package
 215                          (or (null package) (not (string-equal lisp-package package))))))
 216       (when (or lisp-pkg package)
 217         (format stream "~&(in-package \"~A\")~%~%" (or lisp-pkg package)))
 218       (when documentation
 219         (write-protobuf-documentation type documentation stream :indentation indentation))
 220       (format stream "~&(proto:define-proto ~(~A~)" (or class name))
 221       (if (or package lisp-pkg imports optimize options documentation)
 222         (format stream "~%    (")
 223         (format stream " ("))
 224       (let ((spaces ""))
 225         (when package
 226           (format stream "~A:package ~A" spaces package)
 227           (when (or lisp-pkg imports optimize options documentation)
 228             (terpri stream))
 229           (setq spaces "     "))
 230         (when lisp-pkg
 231           (format stream "~A:lisp-package ~A" spaces lisp-pkg)
 232           (when (or imports optimize options documentation)
 233             (terpri stream))
 234           (setq spaces "     "))
 235         (when imports
 236           (cond ((= (length imports) 1)
 237                  (format stream "~A:import \"~A\"" spaces (car imports)))
 238                 (t
 239                  (format stream "~A:import (~{\"~A\"~^ ~})" spaces imports)))
 240           (when (or optimize options documentation)
 241             (terpri stream))
 242           (setq spaces "     "))
 243         (when optimize
 244           (format stream "~A:optimize ~(~S~)" spaces optimize)
 245           (when (or options documentation)
 246             (terpri stream))
 247           (setq spaces "     "))
 248         (when options
 249           (format stream "~A:options (~{~@/protobuf-option/~^ ~})" spaces options)
 250           (when documentation
 251             (terpri stream))
 252           (setq spaces "     "))
 253         (when documentation
 254           (format stream "~A:documentation ~S" spaces documentation)))
 255       (format stream ")"))
 256     (dolist (enum (proto-enums protobuf))
 257       (write-protobuf-as type enum stream :indentation 2))
 258     (dolist (msg (proto-messages protobuf))
 259       (write-protobuf-as type msg stream :indentation 2))
 260     (dolist (svc (proto-services protobuf))
 261       (write-protobuf-as type svc stream :indentation 2))
 262     (format stream ")~%")))
 263
 264 (defmethod write-protobuf-documentation ((type (eql :lisp)) docstring stream
 265                                          &key (indentation 0))
 266   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 267     (dolist (line lines)
 268       (format stream "~&~@[~VT~];; ~A~%"
 269               (and (not (zerop indentation)) indentation) line))))
 270
 271 (defmethod write-protobuf-header ((type (eql :lisp)) stream)
 272   (declare (ignorable type stream))
 273   nil)
 274
 275 (defmethod write-protobuf-as ((type (eql :lisp)) (enum protobuf-enum) stream
 276                               &key (indentation 0))
 277   (terpri stream)
 278   (with-prefixed-accessors (name class alias-for documentation) (proto- enum)
 279     (when documentation
 280       (write-protobuf-documentation type documentation stream :indentation indentation))
 281     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 282             (and (not (zerop indentation)) indentation) class)
 283     (let ((other (and name (not (string= name (class-name->proto class))) name)))
 284       (cond ((or other alias-for documentation)
 285              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 286                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 287                                         ~:[~*~;:documentation ~S~])"
 288                      (+ indentation 4)
 289                      other other (and (or alias-for documentation) (+ indentation 5))
 290                      alias-for alias-for (and documentation (+ indentation 5))
 291                      documentation documentation))
 292             (t
 293              (format stream " ()"))))
 294     (loop for (value . more) on (proto-values enum) doing
 295       (write-protobuf-as type value stream :indentation (+ indentation 2))
 296       (when more
 297         (terpri stream)))
 298     (format stream ")")))
 299
 300 (defmethod write-protobuf-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 301                               &key (indentation 0))
 302   (with-prefixed-accessors (value index) (proto- val)
 303     (format stream "~&~@[~VT~](~(~A~) ~D)"
 304             (and (not (zerop indentation)) indentation) value index)))
 305
 306
 307 (defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
 308                               &key (indentation 0))
 309   (with-prefixed-accessors (name class alias-for conc-name extension-p documentation) (proto- message)
 310     (when documentation
 311       (write-protobuf-documentation type documentation stream :indentation indentation))
 312     (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
 313             (and (not (zerop indentation)) indentation)
 314             (if extension-p "extend" "message") class)
 315     (let ((other (and name (not (string= name (class-name->proto class))) name)))
 316       (cond (extension-p
 317              (format stream " ()"))
 318             ((or alias-for conc-name documentation)
 319              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 320                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 321                                         ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 322                                         ~:[~*~;:documentation ~S~])"
 323                      (+ indentation 4)
 324                      other other (and (or alias-for conc-name documentation) (+ indentation 5))
 325                      alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
 326                      conc-name conc-name (and documentation (+ indentation 5))
 327                      documentation documentation))
 328             (t
 329              (format stream " ()"))))
 330     (cond (extension-p
 331            (loop for (field . more) on (proto-fields message) doing
 332              (when (proto-extension-p field)
 333                (write-protobuf-as type field stream :indentation (+ indentation 2))
 334                (when more
 335                  (terpri stream)))))
 336           (t
 337            (loop for (enum . more) on (proto-enums message) doing
 338              (write-protobuf-as type enum stream :indentation (+ indentation 2))
 339              (when more
 340                (terpri stream)))
 341            (loop for (msg . more) on (proto-messages message) doing
 342              (write-protobuf-as type msg stream :indentation (+ indentation 2))
 343              (when more
 344                (terpri stream)))
 345            (loop for (field . more) on (proto-fields message) doing
 346              (write-protobuf-as type field stream :indentation (+ indentation 2))
 347              (when more
 348                (terpri stream)))
 349            (loop for (extension . more) on (proto-extensions message) doing
 350              (write-protobuf-as type extension stream :indentation (+ indentation 2))
 351              (when more
 352                (terpri stream)))))
 353     (format stream ")")))
 354
 355 (defparameter *protobuf-slot-comment-column* 56)
 356 (defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
 357                               &key (indentation 0))
 358   (with-prefixed-accessors (value reader writer class documentation required default) (proto- field)
 359     (let ((dflt (protobuf-default-to-clos-init default class))
 360           (clss (let ((cl (case class
 361                             ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 362                               :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
 363                             ((:single) 'float)
 364                             ((:double) 'double-float)
 365                             ((:bool)   'boolean)
 366                             ((:string) 'string)
 367                             ((:symbol) 'symbol)
 368                             (otherwise class))))
 369                   (cond ((eq required :optional)
 370                          `(or null ,cl))
 371                         ((eq required :repeated)
 372                          `(list-of ,cl))
 373                         (t cl)))))
 374       (format stream (if (keywordp class)
 375                        ;; Keyword means a primitive type, print default with ~S
 376                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~]~
 377                         ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]"
 378                        ;; Non-keyword must mean an enum type, print default with ~A
 379                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~]~
 380                         ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]")
 381               (and (not (zerop indentation)) indentation)
 382               value clss dflt reader writer
 383               documentation *protobuf-slot-comment-column* documentation))))
 384
 385 (defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
 386                               &key (indentation 0))
 387   (with-prefixed-accessors (from to) (proto-extension- extension)
 388     (format stream "~&~@[~VT~](define-extension ~D ~D)"
 389             (and (not (zerop indentation)) indentation)
 390             from (if (eql to #.(1- (ash 1 29))) "max" to))))
 391
 392
 393 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
 394                               &key (indentation 0))
 395   (with-prefixed-accessors (class documentation conc-name) (proto- service)
 396     (when documentation
 397       (write-protobuf-documentation type documentation stream :indentation indentation))
 398     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 399             (and (not (zerop indentation)) indentation) (proto-class service))
 400     (cond (documentation
 401            (format stream "~%~@[~VT~](:documentation ~S)"
 402                    (+ indentation 4) documentation))
 403           (t
 404            (format stream " ()")))
 405     (loop for (method . more) on (proto-methods service) doing
 406       (write-protobuf-as type method stream :indentation (+ indentation 2))
 407       (when more
 408         (terpri stream)))
 409     (format stream ")")))
 410
 411 (defmethod write-protobuf-as ((type (eql :lisp)) (method protobuf-method) stream
 412                               &key (indentation 0))
 413   (with-prefixed-accessors
 414       (function documentation input-type output-type options) (proto- method)
 415     (when documentation
 416       (write-protobuf-documentation type documentation stream :indentation indentation))
 417     (format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
 418             (and (not (zerop indentation)) indentation)
 419             function input-type output-type)
 420     (when options
 421       (format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
 422               (+ indentation 2) options))
 423     (format stream ")")))