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 "extends" "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     (dolist (enum (proto-enums message))
 143       (write-protobuf-as type enum stream :indentation (+ indentation 2)))
 144     (dolist (msg (proto-messages message))
 145       (write-protobuf-as type msg stream :indentation (+ indentation 2)))
 146     (dolist (field (proto-fields message))
 147       (write-protobuf-as type field stream :indentation (+ indentation 2)))
 148     (dolist (extension (proto-extensions message))
 149       (write-protobuf-as type extension stream :indentation (+ indentation 2)))
 150     (format stream "~&~@[~VT~]}~%"
 151             (and (not (zerop indentation)) indentation))))
 152
 153 (defparameter *protobuf-field-comment-column* 56)
 154 (defmethod write-protobuf-as ((type (eql :proto)) (field protobuf-field) stream
 155                               &key (indentation 0))
 156   (with-prefixed-accessors (name documentation required index default packed) (proto- field)
 157     (let ((dflt (if (stringp default)
 158                   (if (i= (length default) 0) nil default)
 159                   default)))
 160       (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
 161               (and (not (zerop indentation)) indentation)
 162               required (proto-type field) name index dflt packed
 163               documentation *protobuf-field-comment-column* documentation))))
 164
 165 (defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
 166                               &key (indentation 0))
 167   (with-prefixed-accessors (from to) (proto-extension- extension)
 168     (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
 169             (and (not (zerop indentation)) indentation)
 170             from to)))
 171
 172
 173 (defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
 174                               &key (indentation 0))
 175   (with-prefixed-accessors (name documentation) (proto- service)
 176     (when documentation
 177       (write-protobuf-documentation type documentation stream :indentation indentation))
 178     (format stream "~&~@[~VT~]service ~A {~%"
 179             (and (not (zerop indentation)) indentation) name)
 180     (dolist (method (proto-methods service))
 181       (write-protobuf-as type method stream :indentation (+ indentation 2)))
 182     (format stream "~&~@[~VT~]}~%"
 183             (and (not (zerop indentation)) indentation))))
 184
 185 (defmethod write-protobuf-as ((type (eql :proto)) (method protobuf-method) stream
 186                               &key (indentation 0))
 187   (with-prefixed-accessors (name documentation input-name output-name options) (proto- method)
 188     (when documentation
 189       (write-protobuf-documentation type documentation stream :indentation indentation))
 190     (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
 191             (and (not (zerop indentation)) indentation)
 192             name input-name output-name)
 193     (cond (options
 194            (format stream " {~%")
 195            (dolist (option options)
 196              (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
 197                      (+ indentation 2) option))
 198            (format stream "~@[~VT~]}"
 199                    (and (not (zerop indentation)) indentation)))
 200           (t
 201            (format stream ";~%")))))
 202
 203
 204 ;;; Pretty print a schema as a .lisp file
 205
 206 (defmethod write-protobuf-as ((type (eql :lisp)) (protobuf protobuf) stream
 207                               &key (indentation 0))
 208   (with-prefixed-accessors (name class documentation package lisp-package imports optimize options) (proto- protobuf)
 209     (let ((lisp-pkg (and lisp-package
 210                          (or (null package) (not (string-equal lisp-package package))))))
 211       (when (or lisp-pkg package)
 212         (format stream "~&(in-package \"~A\")~%~%" (or lisp-pkg package)))
 213       (when documentation
 214         (write-protobuf-documentation type documentation stream :indentation indentation))
 215       (format stream "~&(proto:define-proto ~(~A~)" (or class name))
 216       (if (or package lisp-pkg imports optimize options documentation)
 217         (format stream "~%    (")
 218         (format stream " ("))
 219       (let ((spaces ""))
 220         (when package
 221           (format stream "~A:package ~A" spaces package)
 222           (when (or lisp-pkg imports optimize options documentation)
 223             (terpri stream))
 224           (setq spaces "     "))
 225         (when lisp-pkg
 226           (format stream "~A:lisp-package ~A" spaces lisp-pkg)
 227           (when (or imports optimize options documentation)
 228             (terpri stream))
 229           (setq spaces "     "))
 230         (when imports
 231           (cond ((= (length imports) 1)
 232                  (format stream "~A:import \"~A\"" spaces (car imports)))
 233                 (t
 234                  (format stream "~A:import (~{\"~A\"~^ ~})" spaces imports)))
 235           (when (or optimize options documentation)
 236             (terpri stream))
 237           (setq spaces "     "))
 238         (when optimize
 239           (format stream "~A:optimize ~(~S~)" spaces optimize)
 240           (when (or options documentation)
 241             (terpri stream))
 242           (setq spaces "     "))
 243         (when options
 244           (format stream "~A:options (~{~@/protobuf-option/~^ ~})" spaces options)
 245           (when documentation
 246             (terpri stream))
 247           (setq spaces "     "))
 248         (when documentation
 249           (format stream "~A:documentation ~S" spaces documentation)))
 250       (format stream ")"))
 251     (dolist (enum (proto-enums protobuf))
 252       (write-protobuf-as type enum stream :indentation 2))
 253     (dolist (msg (proto-messages protobuf))
 254       (write-protobuf-as type msg stream :indentation 2))
 255     (dolist (svc (proto-services protobuf))
 256       (write-protobuf-as type svc stream :indentation 2))
 257     (format stream ")~%")))
 258
 259 (defmethod write-protobuf-documentation ((type (eql :lisp)) docstring stream
 260                                          &key (indentation 0))
 261   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 262     (dolist (line lines)
 263       (format stream "~&~@[~VT~];; ~A~%"
 264               (and (not (zerop indentation)) indentation) line))))
 265
 266 (defmethod write-protobuf-header ((type (eql :lisp)) stream)
 267   (declare (ignorable type stream))
 268   nil)
 269
 270 (defmethod write-protobuf-as ((type (eql :lisp)) (enum protobuf-enum) stream
 271                               &key (indentation 0))
 272   (terpri stream)
 273   (with-prefixed-accessors (name class alias-for documentation) (proto- enum)
 274     (when documentation
 275       (write-protobuf-documentation type documentation stream :indentation indentation))
 276     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 277             (and (not (zerop indentation)) indentation) class)
 278     (let ((other (and name (not (string= name (class-name->proto class))) name)))
 279       (cond ((or other alias-for documentation)
 280              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 281                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 282                                         ~:[~*~;:documentation ~S~])"
 283                      (+ indentation 4)
 284                      other other (and (or alias-for documentation) (+ indentation 5))
 285                      alias-for alias-for (and documentation (+ indentation 5))
 286                      documentation documentation))
 287             (t
 288              (format stream " ()"))))
 289     (loop for (value . more) on (proto-values enum) doing
 290       (write-protobuf-as type value stream :indentation (+ indentation 2))
 291       (when more
 292         (terpri stream)))
 293     (format stream ")")))
 294
 295 (defmethod write-protobuf-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 296                               &key (indentation 0))
 297   (with-prefixed-accessors (value index) (proto- val)
 298     (format stream "~&~@[~VT~](~(~A~) ~D)"
 299             (and (not (zerop indentation)) indentation) value index)))
 300
 301
 302 (defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
 303                               &key (indentation 0))
 304   (with-prefixed-accessors (name class alias-for conc-name extension-p documentation) (proto- message)
 305     (when documentation
 306       (write-protobuf-documentation type documentation stream :indentation indentation))
 307     (format stream "~&~@[~VT~](proto:define-~A ~(~S~)"
 308             (and (not (zerop indentation)) indentation)
 309             (if extension-p "extends" "message") class)
 310     (let ((other (and name (not (string= name (class-name->proto class))) name)))
 311       (cond ((or alias-for conc-name documentation)
 312              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
 313                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
 314                                         ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
 315                                         ~:[~*~;:documentation ~S~])"
 316                      (+ indentation 4)
 317                      other other (and (or alias-for conc-name documentation) (+ indentation 5))
 318                      alias-for alias-for (and (or documentation conc-name) (+ indentation 5))
 319                      conc-name conc-name (and documentation (+ indentation 5))
 320                      documentation documentation))
 321             (t
 322              (format stream " ()"))))
 323     (loop for (enum . more) on (proto-enums message) doing
 324       (write-protobuf-as type enum stream :indentation (+ indentation 2))
 325       (when more
 326         (terpri stream)))
 327     (loop for (msg . more) on (proto-messages message) doing
 328       (write-protobuf-as type msg stream :indentation (+ indentation 2))
 329       (when more
 330         (terpri stream)))
 331     (loop for (field . more) on (proto-fields message) doing
 332       (write-protobuf-as type field stream :indentation (+ indentation 2))
 333       (when more
 334         (terpri stream)))
 335     (loop for (extension . more) on (proto-extensions message) doing
 336       (write-protobuf-as type extension stream :indentation (+ indentation 2))
 337       (when more
 338         (terpri stream)))
 339     (format stream ")")))
 340
 341 (defparameter *protobuf-slot-comment-column* 56)
 342 (defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
 343                               &key (indentation 0))
 344   (with-prefixed-accessors (value reader writer class documentation required default) (proto- field)
 345     (let ((dflt (protobuf-default-to-clos-init default class))
 346           (clss (let ((cl (case class
 347                             ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 348                               :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
 349                             ((:single) 'float)
 350                             ((:double) 'double-float)
 351                             ((:bool)   'boolean)
 352                             ((:string) 'string)
 353                             ((:symbol) 'symbol)
 354                             (otherwise class))))
 355                   (cond ((eq required :optional)
 356                          `(or null ,cl))
 357                         ((eq required :repeated)
 358                          `(list-of ,cl))
 359                         (t cl)))))
 360       (format stream (if (keywordp class)
 361                        ;; Keyword means a primitive type, print default with ~S
 362                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~]~
 363                         ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]"
 364                        ;; Non-keyword must mean an enum type, print default with ~A
 365                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~]~
 366                         ~@[ :reader ~(~S~)~]~@[ :writer ~(~S~)~])~:[~*~*~;~VT; ~A~]")
 367               (and (not (zerop indentation)) indentation)
 368               value clss dflt reader writer
 369               documentation *protobuf-slot-comment-column* documentation))))
 370
 371 (defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
 372                               &key (indentation 0))
 373   (with-prefixed-accessors (from to) (proto-extension- extension)
 374     (format stream "~&~@[~VT~](define-extension ~D ~D)"
 375             (and (not (zerop indentation)) indentation)
 376             from to)))
 377
 378
 379 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
 380                               &key (indentation 0))
 381   (with-prefixed-accessors (class documentation conc-name) (proto- service)
 382     (when documentation
 383       (write-protobuf-documentation type documentation stream :indentation indentation))
 384     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 385             (and (not (zerop indentation)) indentation) (proto-class service))
 386     (cond (documentation
 387            (format stream "~%~@[~VT~](:documentation ~S)"
 388                    (+ indentation 4) documentation))
 389           (t
 390            (format stream " ()")))
 391     (loop for (method . more) on (proto-methods service) doing
 392       (write-protobuf-as type method stream :indentation (+ indentation 2))
 393       (when more
 394         (terpri stream)))
 395     (format stream ")")))
 396
 397 (defmethod write-protobuf-as ((type (eql :lisp)) (method protobuf-method) stream
 398                               &key (indentation 0))
 399   (with-prefixed-accessors
 400       (function documentation input-type output-type options) (proto- method)
 401     (when documentation
 402       (write-protobuf-documentation type documentation stream :indentation indentation))
 403     (format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
 404             (and (not (zerop indentation)) indentation)
 405             function input-type output-type)
 406     (when options
 407       (format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
 408               (+ indentation 2) options))
 409     (format stream ")")))