examples.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 ;;; Examples, for manual testing
  15
  16 ;;--- Turn these into a test suite
  17
  18 #||
  19 (setq pnr-schema (proto:write-protobuf-schema-for-classes
  20                   '(qres-core::legacy-pnr
  21                     qres-core::legacy-pnr-pax
  22                     qres-core::legacy-pnr-segment
  23                     qres-core::legacy-pnr-pax-segment)
  24                   :slot-filter #'quake::quake-slot-filter
  25                   :type-filter #'quake::quake-type-filter
  26                   :enum-filter #'quake::quake-enum-filter
  27                   :value-filter #'quake::quake-value-filter))
  28
  29 (proto:write-protobuf pnr-schema)
  30 (proto:write-protobuf pnr-schema :type :lisp)
  31
  32 (proto:serialize-object-to-stream pnr 'qres-core::legacy-pnr :stream nil)
  33 ||#
  34
  35 #||
  36 (setq sched-schema (proto:write-protobuf-schema-for-classes
  37                     '(quux::zoned-time
  38                       sched::scheduled-flight
  39                       sched::flight-designator
  40                       sched::flight-key
  41                       sched::scheduled-segment
  42                       sched::segment-key
  43                       sched::subsegment-key
  44                       sched::scheduled-leg
  45                       sched::leg-key
  46                       sched::revision-entry)
  47                     :package :qres-sched
  48                     :slot-filter #'quake::quake-slot-filter
  49                     :type-filter #'quake::quake-type-filter
  50                     :enum-filter #'quake::quake-enum-filter
  51                     :value-filter #'quake::quake-value-filter))
  52
  53 (proto:write-protobuf sched-schema)
  54 (proto:write-protobuf sched-schema :type :lisp)
  55 ||#
  56
  57 #||
  58 (defclass geodata ()
  59   ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
  60    (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
  61    (cities :type (proto:list-of qres-core::city) :initform () :initarg :cities)
  62    (airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports)))
  63
  64 (setq bizd-schema (proto:generate-protobuf-schema-for-classes
  65                    '(qres-core::country
  66                      qres-core::region
  67                      qres-core::region-key
  68                      qres-core::city
  69                      qres-core::airport
  70                      qres-core::timezone
  71                      qres-core::tz-variation
  72                      qres-core::currency
  73                      qres-core::country-currencies
  74                      qres-core::carrier
  75                      geodata)))
  76
  77 (proto:write-protobuf bizd-schema)
  78 (proto:write-protobuf bizd-schema :type :lisp)
  79
  80 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
  81        (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
  82        (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
  83        (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v))))
  84   (setq geodata (make-instance 'geodata
  85                   :countries countries
  86                   :regions regions
  87                   :cities cities
  88                   :airports airports)))
  89
  90 (dolist (class '(qres-core::country
  91                  qres-core::region
  92                  qres-core::region-key
  93                  qres-core::city
  94                  qres-core::airport
  95                  qres-core::timezone
  96                  qres-core::tz-variation
  97                  qres-core::currency
  98                  qres-core::country-currencies
  99                  qres-core::carrier
 100                  geodata))
 101   (let ((message (proto-impl:find-message bizd-schema class)))
 102     (eval (proto-impl:generate-object-size  message))
 103     (eval (proto-impl:generate-serializer   message))
 104     (eval (proto-impl:generate-deserializer message))))
 105
 106 (time (progn (setq gser (proto:serialize-object-to-stream geodata 'geodata :stream nil)) nil))
 107 (time (proto:deserialize-object 'geodata gser))
 108
 109 (equalp gser (proto:serialize-object-to-stream
 110               (proto:deserialize-object 'geodata gser)
 111               'geodata :stream nil))
 112 ||#
 113
 114 #||
 115 (setq pschema (proto:generate-protobuf-schema-for-classes
 116                '(proto:protobuf proto:protobuf-option
 117                  proto:protobuf-enum proto:protobuf-enum-value
 118                  proto:protobuf-message proto:protobuf-field proto:protobuf-extension
 119                  proto:protobuf-service proto:protobuf-method)))
 120
 121 (proto:write-protobuf pschema)
 122 (proto:write-protobuf pschema :type :lisp)
 123
 124 (progn (setq pser (proto:serialize-object-to-stream pschema 'proto:protobuf :stream nil)) nil)
 125 (describe (proto:deserialize-object 'proto:protobuf pser))
 126
 127 (proto:print-text-format pschema)
 128 (proto:print-text-format (proto:deserialize-object 'proto:protobuf pser))
 129
 130 (dolist (class '(proto:protobuf
 131                  proto:protobuf-option
 132                  proto:protobuf-enum
 133                  proto:protobuf-enum-value
 134                  proto:protobuf-message
 135                  proto:protobuf-field
 136                  proto:protobuf-extension
 137                  proto:protobuf-service
 138                  proto:protobuf-method))
 139   (let ((message (proto-impl:find-message pschema class)))
 140     (eval (proto-impl:generate-object-size  message))
 141     (eval (proto-impl:generate-serializer   message))
 142     (eval (proto-impl:generate-deserializer message))))
 143 ||#
 144
 145 #||
 146 (defclass proto-test1 ()
 147   ((intval :type (integer -2147483648 +2147483647)
 148            :initarg :intval)))
 149
 150 (defclass proto-test2 ()
 151   ((intval :type (or null (integer -2147483648 +2147483647))
 152            :initform nil
 153            :initarg :intval)
 154    (strval :type (or null string)
 155            :initform nil
 156            :initarg :strval)))
 157
 158 (defclass proto-test3 ()
 159   ((intval :type (or null (integer -2147483648 +2147483647))
 160            :initform nil
 161            :initarg :intval)
 162    (strval :type (or null string)
 163            :initform nil
 164            :initarg :strval)
 165    (recval :type (or null proto-test1)
 166            :initform nil
 167            :initarg :recval)))
 168
 169 (defclass proto-test4 ()
 170   ((intval :type (or null (integer -2147483648 +2147483647))
 171            :initform nil
 172            :initarg :intval)
 173    (strval :type (or null string)
 174            :initform nil
 175            :initarg :strval)
 176    (recval :type (or null proto-test2)
 177            :initform nil
 178            :initarg :recval)))
 179
 180 (defclass proto-test5 ()
 181   ((color   :type (member :red :green :blue)
 182             :initarg :color)
 183    (intvals :type (proto:list-of integer)
 184             :initform ()
 185             :initarg :intvals)
 186    (strvals :type (proto:list-of string)
 187             :initform ()
 188             :initarg :strvals)))
 189
 190 (defclass proto-test6 ()
 191   ((intvals :type (proto:list-of integer)
 192             :initform ()
 193             :initarg :intvals)
 194    (strvals :type (proto:list-of string)
 195             :initform ()
 196             :initarg :strvals)
 197    (recvals :type (proto:list-of proto-test2)
 198             :initform ()
 199             :initarg :recvals)))
 200
 201 (setq test-schema (proto:generate-protobuf-schema-for-classes
 202                    '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6)))
 203
 204 (proto:write-protobuf test-schema)
 205 (proto:write-protobuf test-schema :type :lisp)
 206
 207 (dolist (class '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6))
 208   (let ((message (proto-impl:find-message test-schema class)))
 209     (eval (proto-impl:generate-object-size  message))
 210     (eval (proto-impl:generate-serializer   message))
 211     (eval (proto-impl:generate-deserializer message))))
 212
 213 (setq test1  (make-instance 'proto-test1 :intval 150))
 214 (setq test2  (make-instance 'proto-test2 :strval "testing"))
 215 (setq test2b (make-instance 'proto-test2 :strval "1 2 3"))
 216 (setq test3  (make-instance 'proto-test3 :recval test1))
 217 (setq test4  (make-instance 'proto-test4 :recval test2))
 218 (setq test5  (make-instance 'proto-test5 :color :red
 219                                          :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
 220 (setq test6  (make-instance 'proto-test6 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")
 221                                          :recvals (list test2 test2b)))
 222
 223 (setq tser1 (proto:serialize-object-to-stream test1 'proto-test1 :stream nil))
 224 (equalp tser1 #(#x08 #x96 #x01))
 225 (describe (proto:deserialize-object 'proto-test1 tser1))
 226
 227 (setq tser2 (proto:serialize-object-to-stream test2 'proto-test2 :stream nil))
 228 (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
 229 (describe (proto:deserialize-object 'proto-test2 tser2))
 230
 231 (setq tser3 (proto:serialize-object-to-stream test3 'proto-test3 :stream nil))
 232 (equalp tser3 #(#x1A #x03 #x08 #x96 #x01))
 233 (describe (proto:deserialize-object 'proto-test3 tser3))
 234 (describe (slot-value (proto:deserialize-object 'proto-test3 tser3) 'recval))
 235
 236 (setq tser4 (proto:serialize-object-to-stream test4 'proto-test4 :stream nil))
 237 (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
 238 (describe (proto:deserialize-object 'proto-test4 tser4))
 239 (describe (slot-value (proto:deserialize-object 'proto-test4 tser4) 'recval))
 240
 241 (setq tser5 (proto:serialize-object-to-stream test5 'proto-test5 :stream nil))
 242 (equalp tser5 #(#x08 #x00
 243                 #x10 #x04 #x02 #x03 #x05 #x07
 244                 #x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E))
 245 (describe (proto:deserialize-object 'proto-test5 tser5))
 246
 247 (setq tser6 (proto:serialize-object-to-stream test6 'proto-test6 :stream nil))
 248 (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33))
 249 (describe (proto:deserialize-object 'proto-test6 tser6))
 250 (describe (slot-value (proto:deserialize-object 'proto-test6 tser6) 'recvals))
 251
 252
 253 (equalp (mapcar #'proto-impl:zig-zag-encode32
 254                 '(0 -1 1 -2 2 -2147483648 2147483647))
 255         '(0 1 2 3 4 4294967295 4294967294))
 256 (equalp (mapcar #'proto-impl:zig-zag-encode64
 257                 '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975))
 258         '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950))
 259
 260 (proto:print-text-format test1)
 261 (proto:print-text-format (proto:deserialize-object 'proto-test1 tser1))
 262 (let ((text (with-output-to-string (s)
 263               (proto:print-text-format test1 'proto-test1 :stream s))))
 264   (with-input-from-string (s text)
 265     (proto:parse-text-format 'proto-test1 :stream s)))
 266
 267 (proto:print-text-format test2)
 268 (proto:print-text-format (proto:deserialize-object 'proto-test2 tser2))
 269 (let ((text (with-output-to-string (s)
 270               (proto:print-text-format test2 'proto-test2 :stream s))))
 271   (with-input-from-string (s text)
 272     (proto:parse-text-format 'proto-test2 :stream s)))
 273
 274 (proto:print-text-format test3)
 275 (proto:print-text-format (proto:deserialize-object 'proto-test3 tser3))
 276 (let ((text (with-output-to-string (s)
 277               (proto:print-text-format test3 'proto-test3 :stream s))))
 278   (with-input-from-string (s text)
 279     (proto:parse-text-format 'proto-test3 :stream s)))
 280
 281 (proto:print-text-format test4)
 282 (proto:print-text-format (proto:deserialize-object 'proto-test4 tser4))
 283 (let ((text (with-output-to-string (s)
 284               (proto:print-text-format test4 'proto-test4 :stream s))))
 285   (with-input-from-string (s text)
 286     (proto:parse-text-format 'proto-test4 :stream s)))
 287
 288 (proto:print-text-format test5)
 289 (proto:print-text-format (proto:deserialize-object 'proto-test5 tser5))
 290 (let ((text (with-output-to-string (s)
 291               (proto:print-text-format test5 'proto-test5 :stream s))))
 292   (with-input-from-string (s text)
 293     (proto:parse-text-format 'proto-test5 :stream s)))
 294
 295 (proto:print-text-format test6)
 296 (proto:print-text-format (proto:deserialize-object 'proto-test6 tser6))
 297 (let ((text (with-output-to-string (s)
 298               (proto:print-text-format test6 'proto-test6 :stream s))))
 299   (with-input-from-string (s text)
 300     (proto:parse-text-format 'proto-test6 :stream s)))
 301 ||#
 302
 303 #||
 304 (let* ((enums (list (make-instance 'proto:protobuf-enum
 305                       :name "ColorName"
 306                       :values (list (make-instance 'proto:protobuf-enum-value
 307                                       :name "RED"
 308                                       :index 1
 309                                       :value :red)
 310                                     (make-instance 'proto:protobuf-enum-value
 311                                       :name "GREEN"
 312                                       :index 2
 313                                       :value :green)
 314                                     (make-instance 'proto:protobuf-enum-value
 315                                       :name "BLUE"
 316                                       :index 3
 317                                       :value :blue)))))
 318        (msgs  (list (make-instance 'proto:protobuf-message
 319                       :name "Color"
 320                       :enums (list (make-instance 'proto:protobuf-enum
 321                                       :name "ContrastName"
 322                                       :values (list (make-instance 'proto:protobuf-enum-value
 323                                                       :name "LOW"
 324                                                       :index 1
 325                                                       :value :high)
 326                                                     (make-instance 'proto:protobuf-enum-value
 327                                                       :name "HIGH"
 328                                                       :index 100
 329                                                       :value :low))))
 330                       :fields (list (make-instance 'proto:protobuf-field
 331                                       :name "color"
 332                                       :type "ColorName"
 333                                       :required :required
 334                                       :index 1)
 335                                     (make-instance 'proto:protobuf-field
 336                                       :name "contrast"
 337                                       :type "ContrastName"
 338                                       :required :optional
 339                                       :index 2
 340                                       :default "LOW")))))
 341        (methods  (list (make-instance 'proto:protobuf-method
 342                          :name "GetColor"
 343                          :input-name "string"
 344                          :output-name "Color")
 345                        (make-instance 'proto:protobuf-method
 346                          :name "SetColor"
 347                          :input-name "Color"
 348                          :output-name "Color"
 349                          :options (list (make-instance 'proto:protobuf-option
 350                                           :name "deadline" :value "1.0")))))
 351        (svcs  (list (make-instance 'proto:protobuf-service
 352                       :name "ColorWheel"
 353                       :methods methods)))
 354        (proto (make-instance 'proto:protobuf
 355                 :package "ita.color"
 356                 :imports '("descriptor.proto")
 357                 :enums enums
 358                 :messages msgs
 359                 :services svcs)))
 360   ;; The output should be example the same as the output of 'write-protobuf' below
 361   (proto:write-protobuf proto))
 362 ||#
 363
 364 #||
 365 (proto:define-proto color-wheel
 366     (:package ita.color
 367      :import "descriptor.proto"
 368      :documentation "Color wheel example")
 369   (proto:define-enum color-name
 370       (:documentation "A color name")
 371     red
 372     green
 373     blue)
 374   (proto:define-message color
 375       (:conc-name color-
 376        :documentation "Color and contrast")
 377     (proto:define-enum contrast-name
 378         (:documentation "A contrast name")
 379       (low    1)
 380       (high 100))
 381     (color    :type color-name)
 382     (contrast :type (or null contrast-name) :default :low))
 383   (proto:define-service color-wheel
 384       (:documentation "Get and set colors")
 385     (get-color (string color))
 386     (set-color (color color)
 387                :options ("deadline" "1.0"))))
 388
 389 => (PROGN
 390      (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE))
 391      (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH))
 392      (DEFCLASS COLOR ()
 393        ((COLOR :TYPE COLOR-NAME :ACCESSOR COLOR-COLOR :INITARG :COLOR)
 394         (CONTRAST :TYPE (OR NULL CONTRAST-NAME) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW)))
 395      (DEFVAR *COLOR-WHEEL*
 396        (MAKE-INSTANCE 'PROTOBUF
 397          :NAME "ColorWheel"
 398          :CLASS 'COLOR-WHEEL
 399          :PACKAGE "ita.color"
 400          :IMPORTS '("descriptor.proto")
 401          :SYNTAX "proto2"
 402          :OPTIONS ()
 403          :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
 404                         :NAME "ColorName"
 405                         :CLASS 'COLOR-NAME
 406                         :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 407                                         :NAME "RED" :INDEX 1 :VALUE :RED)
 408                                       (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 409                                         :NAME "GREEN" :INDEX 2 :VALUE :GREEN)
 410                                       (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 411                                         :NAME "BLUE" :INDEX 3 :VALUE :BLUE))))
 412          :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE
 413                            :NAME "Color"
 414                            :CLASS 'COLOR
 415                            :CONC-NAME "COLOR-"
 416                            :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
 417                                           :NAME "ContrastName"
 418                                           :CLASS 'CONTRAST-NAME
 419                                           :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 420                                                           :NAME "LOW" :INDEX 1 :VALUE :LOW)
 421                                                         (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 422                                                           :NAME "HIGH" :INDEX 100 :VALUE :HIGH))))
 423                            :MESSAGES (LIST)
 424                            :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD
 425                                            :NAME "color"
 426                                            :TYPE "ColorName"
 427                                            :CLASS 'COLOR-NAME
 428                                            :REQUIRED :REQUIRED
 429                                            :INDEX 1
 430                                            :VALUE 'COLOR
 431                                            :DEFAULT NIL
 432                                            :PACKED NIL)
 433                                          (MAKE-INSTANCE 'PROTOBUF-FIELD
 434                                            :NAME "contrast"
 435                                            :TYPE "ContrastName"
 436                                            :CLASS 'CONTRAST-NAME
 437                                            :REQUIRED :OPTIONAL
 438                                            :INDEX 2
 439                                            :VALUE 'CONTRAST
 440                                            :DEFAULT "LOW"
 441                                            :PACKED NIL))))
 442          :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE
 443                            :NAME "ColorWheel"
 444                            :CLASS 'COLOR-WHEEL
 445                            :METHODS (LIST (MAKE-INSTANCE 'PROTOBUF-METHOD
 446                                             :NAME "GetColor"
 447                                             :CLASS 'GET-COLOR
 448                                             :INPUT-NAME "string"
 449                                             :OUTPUT-NAME "Color"
 450                                             :OPTIONS (LIST))
 451                                           (MAKE-INSTANCE 'PROTOBUF-METHOD
 452                                             :NAME "SetColor"
 453                                             :CLASS 'SET-COLOR
 454                                             :INPUT-NAME "Color"
 455                                             :OUTPUT-NAME "Color"
 456                                             :OPTIONS (LIST (MAKE-INSTANCE 'PROTOBUF-OPTION
 457                                                              :NAME "deadline" :VALUE "1.0")))))))))
 458
 459 ;; The output should be example the same as the output of 'write-protobuf' above
 460 (proto:write-protobuf *color-wheel*)
 461
 462 ;; How does the Lisp version look?
 463 (proto:write-protobuf *color-wheel* :type :lisp)
 464
 465 (setq clr (make-instance 'color :color :red))
 466 (setq cser (proto:serialize-object-to-stream clr 'color :stream nil))
 467 (proto:print-text-format clr)
 468 (proto:print-text-format (proto:deserialize-object 'color cser))
 469 ||#
 470
 471 #||
 472 (let ((ps "package ita.color;
 473
 474 import \"descriptor.proto\";
 475
 476 enum ColorName {
 477   RED = 1;
 478   GREEN = 2;
 479   BLUE = 3;
 480 }
 481
 482 message Color {
 483   enum ContrastName {
 484     LOW = 1;
 485     HIGH = 100;
 486   }
 487   required ColorName color = 1;
 488   optional ContrastName contrast = 2 [default = LOW];
 489 }
 490
 491 service ColorWheel {
 492   rpc GetColor (string) returns (Color);
 493   rpc SetColor (Color) returns (Color) {
 494     option deadline = \"1.0\";
 495   }
 496 }"))
 497   (with-input-from-string (s ps)
 498     (setq ppp (proto:parse-protobuf-from-stream s))))
 499
 500 (proto:write-protobuf ppp)
 501 (proto:write-protobuf ppp :type :lisp)
 502 ||#
 503
 504 #||
 505 (proto:define-proto typed-list ()
 506   (proto:define-message typed-list ()
 507     (string-car  :type (or null string)  :reader string-car)
 508     (symbol-car  :type (or null string)  :reader symbol-car)
 509     (integer-car :type (or null integer) :reader integer-car)
 510     (float-car   :type (or null single-float) :reader float-car)
 511     (list-car  :type (or null typed-list) :reader list-car)
 512     (list-cdr  :type (or null typed-list) :reader list-cdr)))
 513
 514 (defun string-car (x)
 515   (and (stringp (car x)) (car x)))
 516
 517 (defun symbol-car (x)
 518   (and (symbolp (car x)) (symbol-name (car x))))
 519
 520 (defun integer-car (x)
 521   (and (integerp (car x)) (car x)))
 522
 523 (defun float-car (x)
 524   (and (floatp (car x)) (car x)))
 525
 526 (defun list-car (x)
 527   (etypecase (car x)
 528     ((or string symbol integer float) nil)
 529     (list (car x))))
 530
 531 (defun list-cdr (x)
 532   (assert (listp (cdr x)) ())
 533   (cdr x))
 534
 535 (let ((list '("this" "is" "a" ("nested" "test"))))
 536   (proto:serialize-object-to-stream list 'typed-list :stream nil)
 537   (proto:print-text-format list 'typed-list)
 538   (proto:print-text-format list 'typed-list :suppress-line-breaks t)
 539   (let ((text (with-output-to-string (s)
 540                 (proto:print-text-format list 'typed-list :stream s))))
 541     (with-input-from-string (s text)
 542       (proto:parse-text-format 'typed-list :stream s))))
 543
 544 (let ((list '((1 one) (2 two) (3 three))))
 545   (proto:serialize-object-to-stream list 'typed-list :stream nil)
 546   (proto:print-text-format list 'typed-list)
 547   (proto:print-text-format list 'typed-list :suppress-line-breaks t)
 548   (let ((text (with-output-to-string (s)
 549                 (proto:print-text-format list 'typed-list :stream s))))
 550     (with-input-from-string (s text)
 551       (proto:parse-text-format 'typed-list :stream s))))
 552 ||#
 553
 554 \f
 555 ;;; Stubby examples
 556
 557 #||
 558 (proto:define-proto color-wheel
 559     (:package color-wheel
 560      :optimize :speed
 561      :documentation "Color wheel example")
 562   (proto:define-message color-wheel
 563       (:conc-name color-wheel-)
 564     (name   :type string)
 565     (colors :type (proto:list-of color) :default ()))
 566   (proto:define-message color
 567       (:conc-name color-
 568        :documentation "A (named) color")
 569     (name    :type (or string null))
 570     (r-value :type integer)
 571     (g-value :type integer)
 572     (b-value :type integer)
 573     (proto:define-extension 1000 max))
 574   (proto:define-extend color ()
 575     ((opacity 1000) :type (or null integer)))
 576   (proto:define-message get-color-request ()
 577     (wheel :type color-wheel)
 578     (name  :type string))
 579   (proto:define-message add-color-request ()
 580     (wheel :type color-wheel)
 581     (color :type color))
 582   (proto:define-service color-wheel ()
 583     (get-color (get-color-request color)
 584       :options ("deadline" "1.0")
 585       :documentation "Look up a color by name")
 586     (add-color (add-color-request color)
 587       :options ("deadline" "1.0")
 588       :documentation "Add a new color to the wheel")))
 589
 590 (proto:write-protobuf *color-wheel*)
 591 (proto:write-protobuf *color-wheel* :type :lisp)
 592
 593 (progn ;with-rpc-channel (rpc)
 594   (let* ((wheel  (make-instance 'color-wheel :name "Colors"))
 595          (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
 596          (rqst1  (make-instance 'add-color-request :wheel wheel :color color1))
 597          (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
 598          (rqst2  (make-instance 'add-color-request :wheel wheel :color color2)))
 599     (setf (color-opacity color2) 50)
 600     #-ignore (progn
 601                (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
 602                (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil)))
 603                  (print ser1)
 604                  (proto:print-text-format rqst1)
 605                  (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
 606     #-ignore (progn
 607                (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
 608                (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil)))
 609                  (print ser2)
 610                  (proto:print-text-format rqst2)
 611                  (proto:print-text-format (proto:deserialize-object 'add-color-request ser2))))
 612     #+stubby (add-color request)
 613     #+ignore (add-color request)))
 614 ||#
 615
 616 #||
 617 (let ((ps "syntax = \"proto2\";
 618
 619 package color_wheel;
 620
 621 option optimize_for = SPEED;
 622
 623 message ColorWheel {
 624   required string name = 1;
 625   repeated Color colors = 2;
 626   optional group Metadata = 3 {
 627     optional string author = 1;
 628     optional string revision = 2;
 629     optional string date = 3;
 630   }
 631 }
 632
 633 message Color {
 634   optional string name = 1;
 635   required int64 r_value = 2;
 636   required int64 g_value = 3;
 637   required int64 b_value = 4;
 638   extensions 1000 to max;
 639 }
 640
 641 extend Color {
 642   optional int64 opacity = 1000;
 643 }
 644
 645 message GetColorRequest {
 646   required ColorWheel wheel = 1;
 647   required string name = 2;
 648 }
 649
 650 message AddColorRequest {
 651   required ColorWheel wheel = 1;
 652   required Color color = 2;
 653 }
 654
 655 service ColorWheel {
 656   rpc GetColor (GetColorRequest) returns (Color) {
 657     option deadline = \"1.0\";
 658   }
 659   rpc AddColor (AddColorRequest) returns (Color) {
 660     option deadline = \"1.0\";
 661   }
 662 }"))
 663   (with-input-from-string (s ps)
 664     (setq cw (proto:parse-protobuf-from-stream s))))
 665
 666 (proto:define-proto color-wheel1
 667     (:package color-wheel
 668      ;; :optimize :speed
 669      :documentation "Color wheel example, with nested")
 670   (proto:define-message color-wheel1 ()
 671     (proto:define-message metadata1 ()
 672       (author :type (or null string))
 673       (revision :type (or null string))
 674       (date :type (or null string)))
 675     (name :type string)
 676     (colors :type (list-of color1))
 677     (metadata1 :type (or null metadata1)))
 678   (proto:define-message color1 ()
 679     (name :type (or null string))
 680     (r-value :type integer)
 681     (g-value :type integer)
 682     (b-value :type integer))
 683   (proto:define-message add-color1 ()
 684     (wheel :type color-wheel1)
 685     (color :type color1)))
 686
 687 (proto:define-proto color-wheel2
 688     (:package color-wheel
 689      ;; :optimize :speed
 690      :documentation "Color wheel example, with group")
 691   (proto:define-message color-wheel2 ()
 692     (name :type string)
 693     (colors :type (list-of color2))
 694     (proto:define-group metadata2
 695         (:index 3
 696          :arity :optional)
 697       (author :type (or null string))
 698       (revision :type (or null string))
 699       (date :type (or null string))))
 700   (proto:define-message color2 ()
 701     (name :type (or null string))
 702     (r-value :type integer)
 703     (g-value :type integer)
 704     (b-value :type integer))
 705   (proto:define-message add-color2 ()
 706     (wheel :type color-wheel2)
 707     (color :type color2)))
 708
 709 (proto:write-protobuf *color-wheel1*)
 710 (proto:write-protobuf *color-wheel2*)
 711
 712 (progn ;with-rpc-channel (rpc)
 713   (let* ((meta1  (make-instance 'metadata1 :revision "1.0"))
 714          (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1))
 715          (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
 716          (rqst1  (make-instance 'add-color1 :wheel wheel1 :color color1))
 717          (meta2  (make-instance 'metadata2 :revision "1.0"))
 718          (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2))
 719          (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
 720          (rqst2  (make-instance 'add-color2 :wheel wheel2 :color color2)))
 721     #-ignore (progn
 722                (format t "~2&Nested")
 723                (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color1 :stream nil)))
 724                  (print ser1)
 725                  (proto:print-text-format rqst1)
 726                  (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
 727     #-ignore (progn
 728                (format t "~2&Group")
 729                (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color2 :stream nil)))
 730                  (print ser2)
 731                  (proto:print-text-format rqst2)
 732                  (proto:print-text-format (proto:deserialize-object 'add-color2 ser2))))))
 733 ||#