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 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 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 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 a schema 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 (~{\"~A\"~^ ~})" spaces imports)))
 184         (when (or options documentation)
 185           (terpri stream))
 186         (setq spaces "     "))
 187       (when options
 188         (format stream "~A:options (~{~@/protobuf-option/~^ ~})" spaces options)
 189         (when documentation
 190           (terpri stream))
 191         (setq spaces "     "))
 192       (when documentation
 193         (format stream "~A:documentation ~S" spaces documentation)))
 194     (format stream ")")
 195     (dolist (enum (proto-enums protobuf))
 196       (write-protobuf-as type enum stream :indentation 2))
 197     (dolist (msg (proto-messages protobuf))
 198       (write-protobuf-as type msg stream :indentation 2))
 199     (dolist (svc (proto-services protobuf))
 200       (write-protobuf-as type svc stream :indentation 2))
 201     (format stream ")~%")))
 202
 203 (defmethod write-protobuf-documentation ((type (eql :lisp)) docstring stream
 204                                          &key (indentation 0))
 205   (let ((lines (split-string docstring :separators '(#\newline #\return))))
 206     (dolist (line lines)
 207       (format stream "~&~@[~VT~];; ~A~%"
 208               (and (not (zerop indentation)) indentation) line))))
 209
 210
 211 (defmethod write-protobuf-as ((type (eql :lisp)) (enum protobuf-enum) stream
 212                               &key (indentation 0))
 213   (terpri stream)
 214   (with-prefixed-accessors (class documentation) (proto- enum)
 215     (when documentation
 216       (write-protobuf-documentation type documentation stream :indentation indentation))
 217     (format stream "~@[~VT~](proto:define-enum ~(~S~)"
 218             (and (not (zerop indentation)) indentation) class)
 219     (cond (documentation
 220            (format stream "~%~@[~VT~](:documentation ~S)"
 221                    (+ indentation 4) documentation))
 222           (t
 223            (format stream " ()")))
 224     (loop for (value . more) on (proto-values enum) doing
 225       (write-protobuf-as type value stream :indentation (+ indentation 2))
 226       (when more
 227         (terpri stream)))
 228     (format stream ")")))
 229
 230 (defmethod write-protobuf-as ((type (eql :lisp)) (val protobuf-enum-value) stream
 231                               &key (indentation 0))
 232   (with-prefixed-accessors (value index) (proto- val)
 233     (format stream "~&~@[~VT~](~(~A~) ~D)"
 234             (and (not (zerop indentation)) indentation) value index)))
 235
 236
 237 (defmethod write-protobuf-as ((type (eql :lisp)) (message protobuf-message) stream
 238                               &key (indentation 0))
 239   (with-prefixed-accessors (class conc-name documentation) (proto- message)
 240     (when documentation
 241       (write-protobuf-documentation type documentation stream :indentation indentation))
 242     (format stream "~&~@[~VT~](proto:define-message ~(~S~)"
 243             (and (not (zerop indentation)) indentation) class)
 244     (if (or conc-name documentation)
 245       (format stream "~%~VT(" (+ indentation 4))
 246       (format stream " ("))
 247     (when (or conc-name documentation)
 248       (when conc-name
 249         (format stream ":conc-name ~(~A~)" conc-name))
 250       (when documentation
 251         (if conc-name
 252           (format stream "~%~VT:documentation ~S"
 253                   (+ indentation 5) documentation)
 254           (format stream ":documentation ~S" documentation))))
 255     (format stream ")")
 256     (loop for (enum . more) on (proto-enums message) doing
 257       (write-protobuf-as type enum stream :indentation (+ indentation 2))
 258       (when more
 259         (terpri stream)))
 260     (loop for (msg . more) on (proto-messages message) doing
 261       (write-protobuf-as type msg stream :indentation (+ indentation 2))
 262       (when more
 263         (terpri stream)))
 264     (loop for (field . more) on (proto-fields message) doing
 265       (write-protobuf-as type field stream :indentation (+ indentation 2))
 266       (when more
 267         (terpri stream)))
 268     (loop for (extension . more) on (proto-extensions message) doing
 269       (write-protobuf-as type extension stream :indentation (+ indentation 2))
 270       (when more
 271         (terpri stream)))
 272     (format stream ")")))
 273
 274 (defparameter *protobuf-slot-comment-column* 56)
 275 (defmethod write-protobuf-as ((type (eql :lisp)) (field protobuf-field) stream
 276                               &key (indentation 0))
 277   (with-prefixed-accessors (value type class documentation required default) (proto- field)
 278     (let ((dflt (cond ((or (null default)
 279                            (and (stringp default) (string-empty-p default)))
 280                        nil)
 281                       ((member class '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 282                                        :fixed32 :sfixed32 :fixed64 :sfixed64
 283                                        :single :double))
 284                        (read-from-string default))
 285                       ((eq class :bool)
 286                        (if (string= default "true") t nil))
 287                       (t default)))
 288           (clss (let ((cl (case class
 289                             ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 290                               :fixed32 :sfixed32 :fixed64 :sfixed64) 'integer)
 291                             ((:single) 'float)
 292                             ((:double) 'double-float)
 293                             ((:bool)   'boolean)
 294                             ((:string) 'string)
 295                             ((:symbol) 'symbol)
 296                             (otherwise class))))
 297                   (cond ((eq required :optional)
 298                          `(or null ,cl))
 299                         ((eq required :repeated)
 300                          `(list-of ,cl))
 301                         (t cl)))))
 302       (format stream (if (keywordp class)
 303                        ;; Keyword means a primitive type, print default with ~S
 304                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~S~])~:[~*~*~;~VT; ~A~]"
 305                        ;; Non-keyword means an enum type, print default with ~A
 306                        "~&~@[~VT~](~(~S~) :type ~(~S~)~@[ :default ~(:~A~)~])~:[~*~*~;~VT; ~A~]")
 307               (and (not (zerop indentation)) indentation)
 308               value clss dflt
 309               documentation *protobuf-slot-comment-column* documentation))))
 310
 311 (defmethod write-protobuf-as ((type (eql :lisp)) (extension protobuf-extension) stream
 312                               &key (indentation 0))
 313   (with-prefixed-accessors (from to) (proto-extension- extension)
 314     (format stream "~&~@[~VT~](define-extension ~D ~D)"
 315             (and (not (zerop indentation)) indentation)
 316             from to)))
 317
 318
 319 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
 320                               &key (indentation 0))
 321   (with-prefixed-accessors (class documentation conc-name) (proto- service)
 322     (when documentation
 323       (write-protobuf-documentation type documentation stream :indentation indentation))
 324     (format stream "~&~@[~VT~](proto:define-service ~(~S~)"
 325             (and (not (zerop indentation)) indentation) (proto-class service))
 326     (cond (documentation
 327            (format stream "~%~@[~VT~](:documentation ~S)"
 328                    (+ indentation 4) documentation))
 329           (t
 330            (format stream " ()")))
 331     (loop for (rpc . more) on (proto-rpcs service) doing
 332       (write-protobuf-as type rpc stream :indentation (+ indentation 2))
 333       (when more
 334         (terpri stream)))
 335     (format stream ")")))
 336
 337 (defmethod write-protobuf-as ((type (eql :lisp)) (rpc protobuf-rpc) stream
 338                               &key (indentation 0))
 339   (with-prefixed-accessors
 340       (function documentation input-type input-class output-type output-class options) (proto- rpc)
 341     (when documentation
 342       (write-protobuf-documentation type documentation stream :indentation indentation))
 343     (let ((input  (or input-class
 344                       (let ((m (find-message-for-class *protobuf* input-type)))
 345                         (and m (proto-class m)))))
 346           (output (or output-class
 347                       (let ((m (find-message-for-class *protobuf* output-type)))
 348                         (and m (proto-class m))))))
 349       (format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
 350               (and (not (zerop indentation)) indentation)
 351               function input output)
 352       (when options
 353         (format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
 354                 (+ indentation 2) options))
 355       (format stream ")"))))