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 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 a 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 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 class documentation syntax package imports 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;~%~%" package))
  44     (when imports
  45       (dolist (import imports)
  46         (format stream "~&import \"~A\";~%" import))
  47       (terpri stream))
  48     (when options
  49       (dolist (option options)
  50         (format stream "~&option ~:/protobuf-option/;~%" option))
  51       (terpri stream))
  52     (dolist (enum (proto-enums protobuf))
  53       (write-protobuf-as type enum stream :indentation indentation)
  54       (terpri stream))
  55     (dolist (msg (proto-messages protobuf))
  56       (write-protobuf-as type msg stream :indentation indentation)
  57       (terpri stream))
  58     (dolist (svc (proto-services protobuf))
  59       (write-protobuf-as type svc stream :indentation indentation)
  60       (terpri stream))))
  61
  62 (defmethod write-protobuf-documentation ((type (eql :proto)) docstring stream
  63                                          &key (indentation 0))
  64   (let ((lines (split-string docstring :separators '(#\newline #\return))))
  65     (dolist (line lines)
  66       (format stream "~&~@[~VT~]// ~A~%"
  67               (and (not (zerop indentation)) indentation) line))))
  68
  69
  70 (defmethod write-protobuf-as ((type (eql :proto)) (enum protobuf-enum) stream
  71                               &key (indentation 0))
  72   (with-prefixed-accessors (name documentation) (proto- enum)
  73     (when documentation
  74       (write-protobuf-documentation type documentation stream :indentation indentation))
  75     (format stream "~&~@[~VT~]enum ~A {~%"
  76             (and (not (zerop indentation)) indentation) name)
  77     (dolist (value (proto-values enum))
  78       (write-protobuf-as type value stream :indentation (+ indentation 2)))
  79     (format stream "~&~@[~VT~]}~%"
  80             (and (not (zerop indentation)) indentation))))
  81
  82 (defparameter *protobuf-enum-comment-column* 56)
  83 (defmethod write-protobuf-as ((type (eql :proto)) (val protobuf-enum-value) stream
  84                               &key (indentation 0))
  85   (with-prefixed-accessors (name documentation index) (proto- val)
  86     (format stream "~&~@[~VT~]~A = ~D;~:[~*~*~;~VT// ~A~]~%"
  87             (and (not (zerop indentation)) indentation) name index
  88             documentation *protobuf-enum-comment-column* documentation)))
  89
  90
  91 (defmethod write-protobuf-as ((type (eql :proto)) (message protobuf-message) stream
  92                               &key (indentation 0))
  93   (with-prefixed-accessors (name documentation) (proto- message)
  94     (when documentation
  95       (write-protobuf-documentation type documentation stream :indentation indentation))
  96     (format stream "~&~@[~VT~]message ~A {~%"
  97             (and (not (zerop indentation)) indentation) name)
  98     (dolist (enum (proto-enums message))
  99       (write-protobuf-as type enum stream :indentation (+ indentation 2)))
 100     (dolist (msg (proto-messages message))
 101       (write-protobuf-as type msg stream :indentation (+ indentation 2)))
 102     (dolist (field (proto-fields message))
 103       (write-protobuf-as type field stream :indentation (+ indentation 2)))
 104     (dolist (extension (proto-extensions message))
 105       (write-protobuf-as type extension stream :indentation (+ indentation 2)))
 106     (format stream "~&~@[~VT~]}~%"
 107             (and (not (zerop indentation)) indentation))))
 108
 109 (defparameter *protobuf-field-comment-column* 56)
 110 (defmethod write-protobuf-as ((type (eql :proto)) (field protobuf-field) stream
 111                               &key (indentation 0))
 112   (with-prefixed-accessors (name type documentation required index default packed) (proto- field)
 113     (let ((dflt (if (stringp default)
 114                   (if (string-empty-p default) nil default)
 115                   default)))
 116       (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~@[ [default = ~A]~]~@[ [packed=true]~*~];~:[~*~*~;~VT// ~A~]~%"
 117               (and (not (zerop indentation)) indentation)
 118               required type name index dflt packed
 119               documentation *protobuf-field-comment-column* documentation))))
 120
 121 (defmethod write-protobuf-as ((type (eql :proto)) (extension protobuf-extension) stream
 122                               &key (indentation 0))
 123   (with-prefixed-accessors (from to) (proto-extension- extension)
 124     (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
 125             (and (not (zerop indentation)) indentation)
 126             from to)))
 127
 128
 129 (defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
 130                               &key (indentation 0))
 131   (with-prefixed-accessors (name doc documentation) (proto- service)
 132     (when documentation
 133       (write-protobuf-documentation type documentation stream :indentation indentation))
 134     (format stream "~&~@[~VT~]service ~A {~%"
 135             (and (not (zerop indentation)) indentation) name)
 136     (dolist (rpc (proto-rpcs service))
 137       (write-protobuf-as type rpc stream :indentation (+ indentation 2)))
 138     (format stream "~&~@[~VT~]}~%"
 139             (and (not (zerop indentation)) indentation))))
 140
 141 (defmethod write-protobuf-as ((type (eql :proto)) (rpc protobuf-rpc) stream
 142                               &key (indentation 0))
 143   (with-prefixed-accessors (name documentation input-type output-type options) (proto- rpc)
 144     (when documentation
 145       (write-protobuf-documentation type documentation stream :indentation indentation))
 146     (format stream "~&~@[~VT~]rpc ~A (~@[~A~])~@[ returns (~A)~]"
 147             (and (not (zerop indentation)) indentation)
 148             name input-type output-type)
 149     (cond (options
 150            (format stream " {~%")
 151            (dolist (option options)
 152              (format stream "~&~@[~VT~]option ~:/protobuf-option/;~%"
 153                      (+ indentation 2) option))
 154            (format stream "~@[~VT~]}"
 155                    (and (not (zerop indentation)) indentation)))
 156           (t
 157            (format stream ";~%")))))
 158
 159
 160 ;;; Pretty print as a .lisp file
 161
 162 (defmethod write-protobuf-as ((type (eql :lisp)) (protobuf protobuf) stream
 163                               &key (indentation 0))
 164   (with-prefixed-accessors (name class documentation package imports options) (proto- protobuf)
 165     (when package
 166       (format stream "~&(in-package \"~A\")~%~%" package))
 167     (when documentation
 168       (write-protobuf-documentation type documentation stream :indentation indentation))
 169     (format stream "~&(proto:define-proto ~(~A~)" (or class name))
 170     (if (or package imports options documentation)
 171       (format stream "~%    (")
 172       (format stream " ("))
 173     (let ((spaces ""))
 174       (when package
 175         (format stream "~A:package ~A" spaces package)
 176         (when (or imports options documentation)
 177           (terpri stream))
 178         (setq spaces "     "))
 179       (when imports
 180         (cond ((= (length imports) 1)
 181                (format stream "~A:import \"~A\"" spaces (car imports)))
 182               (t
 183                (format stream "~A:import (" spaces)
 184                (format stream "~{\"~A\"~^ ~}" imports)
 185                (format stream ")")))
 186         (when (or options documentation)
 187           (terpri stream))
 188         (setq spaces "     "))
 189       (when options
 190         (format stream "~A:options (" spaces)
 191         (format stream "~{~/protobuf-option/~^ ~}" options)
 192         (when documentation
 193           (terpri stream))
 194         (setq spaces "     "))
 195       (when documentation
 196         (format stream "~A:documentation ~S" spaces documentation))
 197       (format stream ")")))
 198   (format stream ")")
 199   (dolist (enum (proto-enums protobuf))
 200     (write-protobuf-as type enum stream :indentation 2))
 201   (dolist (msg (proto-messages protobuf))
 202     (write-protobuf-as type msg stream :indentation 2))
 203   (dolist (svc (proto-services protobuf))
 204     (write-protobuf-as type svc stream :indentation 2))
 205   (format stream ")~%"))
 206
 207 (defmethod write-protobuf-documentation ((type (eql :lisp)) docstring stream
 208                                          &key (indentation 0))
 209   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 210     (dolist (line lines)
 211       (format stream "~&~@[~VT~];; ~A~%"
 212               (and (not (zerop indentation)) indentation) line))))
 213
 214
 215 (defmethod write-protobuf-as ((type (eql :lisp)) (enum protobuf-enum) stream
 216                               &key (indentation 0))
 217   (terpri stream)
 218   (with-prefixed-accessors (class documentation) (proto- enum)
 219     (when documentation
 220       (write-protobuf-documentation type documentation stream :indentation indentation))
 221     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 222             (and (not (zerop indentation)) indentation) class)
 223     (cond (documentation
 224            (format stream "~%~@[~VT~](:documentation ~S)"
 225                    (+ indentation 4) documentation))
 226           (t
 227            (format stream " ()")))
 228     (loop for (value . more) on (proto-values enum) doing
 229       (write-protobuf-as type value stream :indentation (+ indentation 2))
 230       (when more
 231         (terpri stream)))
 232     (format stream ")")))
 233
 234 (defmethod write-protobuf-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 235                               &key (indentation 0))
 236   (with-prefixed-accessors (value index) (proto- val)
 237     (format stream "~&~@[~VT~](~(~A~) ~D)"
 238             (and (not (zerop indentation)) indentation) value index)))
 239
 240
 241 (defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
 242                               &key (indentation 0))
 243   (with-prefixed-accessors (class conc-name documentation) (proto- message)
 244     (when documentation
 245       (write-protobuf-documentation type documentation stream :indentation indentation))
 246     (format stream "~&~@[~VT~](proto:define-message ~(~S~)"
 247             (and (not (zerop indentation)) indentation) class)
 248     (if (or conc-name documentation)
 249       (format stream "~%~VT(" (+ indentation 4))
 250       (format stream " ("))
 251     (when (or conc-name documentation)
 252       (when conc-name
 253         (format stream ":conc-name ~(~A~)" conc-name))
 254       (when documentation
 255         (if conc-name
 256           (format stream "~%~VT:documentation ~S"
 257                   (+ indentation 5) documentation)
 258           (format stream ":documentation ~S" documentation))))
 259     (format stream ")")
 260     (loop for (enum . more) on (proto-enums message) doing
 261       (write-protobuf-as type enum stream :indentation (+ indentation 2))
 262       (when more
 263         (terpri stream)))
 264     (loop for (msg . more) on (proto-messages message) doing
 265       (write-protobuf-as type msg stream :indentation (+ indentation 2))
 266       (when more
 267         (terpri stream)))
 268     (loop for (field . more) on (proto-fields message) doing
 269       (write-protobuf-as type field stream :indentation (+ indentation 2))
 270       (when more
 271         (terpri stream)))
 272     (loop for (extension . more) on (proto-extensions message) doing
 273       (write-protobuf-as type extension stream :indentation (+ indentation 2))
 274       (when more
 275         (terpri stream)))
 276     (format stream ")")))
 277
 278 (defparameter *protobuf-slot-comment-column* 56)
 279 (defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
 280                               &key (indentation 0))
 281   (with-prefixed-accessors (value type class documentation required default) (proto- field)
 282     (let ((dflt (cond ((or (null default)
 283                            (and (stringp default) (string-empty-p default)))
 284                        nil)
 285                       ((member class '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 286                                        :fixed32 :sfixed32 :fixed64 :sfixed64
 287                                        :single :double))
 288                        (read-from-string default))
 289                       ((eq class :bool)
 290                        (if (string= default "true") t nil))
 291                       (t default)))
 292           (clss (let ((cl (case class
 293                             ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 294                               :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
 295                             ((:single) 'float)
 296                             ((:double) 'double-float)
 297                             ((:bool)   'boolean)
 298                             ((:string) 'string)
 299                             ((:symbol) 'symbol)
 300                             (otherwise class))))
 301                   (cond ((eq required :optional)
 302                          `(or null ,cl))
 303                         ((eq required :repeated)
 304                          `(list-of ,cl))
 305                         (t cl)))))
 306       (format stream (if (keywordp class)
 307                        ;; Keyword means a primitive type, print default with ~S
 308                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~])~:[~*~*~;~VT; ~A~]"
 309                        ;; Non-keyword means an enum type, print default with ~A
 310                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~])~:[~*~*~;~VT; ~A~]")
 311               (and (not (zerop indentation)) indentation)
 312               value clss dflt
 313               documentation *protobuf-slot-comment-column* documentation))))
 314
 315 (defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
 316                               &key (indentation 0))
 317   (with-prefixed-accessors (from to) (proto-extension- extension)
 318     (format stream "~&~@[~VT~](define-extension ~D ~D)"
 319             (and (not (zerop indentation)) indentation)
 320             from to)))
 321
 322
 323 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
 324                               &key (indentation 0))
 325   (with-prefixed-accessors (class documentation conc-name) (proto- service)
 326     (when documentation
 327       (write-protobuf-documentation type documentation stream :indentation indentation))
 328     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 329             (and (not (zerop indentation)) indentation) (proto-class service))
 330     (cond (documentation
 331            (format stream "~%~@[~VT~](:documentation ~S)"
 332                    (+ indentation 4) documentation))
 333           (t
 334            (format stream " ()")))
 335     (loop for (rpc . more) on (proto-rpcs service) doing
 336       (write-protobuf-as type rpc stream :indentation (+ indentation 2))
 337       (when more
 338         (terpri stream)))
 339     (format stream ")")))
 340
 341 (defmethod write-protobuf-as ((type (eql :lisp)) (rpc protobuf-rpc) stream
 342                               &key (indentation 0))
 343   (with-prefixed-accessors (class documentation input-type output-type options) (proto- rpc)
 344     (when documentation
 345       (write-protobuf-documentation type documentation stream :indentation indentation))
 346     (let ((in  (find-message-for-class *protobuf* input-type))
 347           (out (find-message-for-class *protobuf* output-type)))
 348       (format stream "~&~@[~VT~](~(~S~) ~(~S~) ~(~S~)"
 349               (and (not (zerop indentation)) indentation) class
 350               (if in  (proto-class in)  input-type)
 351               (if out (proto-class out) output-type))
 352       (when options
 353         (format stream "~%~VT:options (~{~/protobuf-option/~^ ~})"
 354                 (+ indentation 2) options))
 355       (format stream ")"))))