text-format.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 ;;; Print objects using Protobufs text format
  15
  16 (defgeneric print-text-format (object type &key stream)
  17   (:documentation
  18    "Prints the object 'object' of type 'type' using message(s) define in the
  19     schema 'protobuf' onto the stream 'stream' using the textual format."))
  20
  21 (defmethod print-text-format (object type &key (stream *standard-output*))
  22   (let ((message (find-message-for-class type)))
  23     (assert message ()
  24             "There is no Protobuf message having the type ~S" type)
  25     (macrolet ((read-slot (object slot reader)
  26                  ;; Don't do a boundp check, we assume the object is fully populated
  27                  ;; Unpopulated slots should be "nullable" and should contain nil
  28                  `(if ,reader
  29                     (funcall ,reader ,object)
  30                     (slot-value ,object ,slot))))
  31       (labels ((do-field (object trace indent field)
  32                  ;; We don't do cycle detection here
  33                  ;; If the client needs it, he can define his own 'print-text-format'
  34                  ;; method to clean things up first
  35                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  36                         (slot   (proto-value field))
  37                         (reader (proto-reader field))
  38                         msg)
  39                    (when (or slot reader)
  40                      (cond ((eq (proto-required field) :repeated)
  41                             (cond ((keywordp type)
  42                                    (map () #'(lambda (v)
  43                                                (print-prim v type field stream indent))
  44                                            (read-slot object slot reader)))
  45                                   ((typep (setq msg (and type (or (find-message trace type)
  46                                                                   (find-enum trace type))))
  47                                           'protobuf-message)
  48                                    (let ((values (if slot (read-slot object slot reader) (list object))))
  49                                      (when values
  50                                        (format stream "~&~VT~A:~%" (+ indent 2) (proto-name field))
  51                                        (let ((indent (+ indent 4)))
  52                                          (dolist (v values)
  53                                            (format stream "~&~VT~A {~%" indent (proto-name msg))
  54                                            (map () (curry #'do-field v msg indent)
  55                                                    (proto-fields msg))
  56                                            (format stream "~&~VT}~%" indent))))))
  57                                   ((typep msg 'protobuf-enum)
  58                                    (map () #'(lambda (v)
  59                                                (print-enum v msg field stream indent))
  60                                            (read-slot object slot reader)))))
  61                            (t
  62                             (cond ((keywordp type)
  63                                    (let ((v (read-slot object slot reader)))
  64                                      (when (or v (eq type :bool))
  65                                        (print-prim v type field stream indent))))
  66                                   ((typep (setq msg (and type (or (find-message trace type)
  67                                                                   (find-enum trace type))))
  68                                           'protobuf-message)
  69                                    (let ((v (if slot (read-slot object slot reader) object)))
  70                                      (when v
  71                                        (format stream "~&~VT~A:~%" (+ indent 2) (proto-name field))
  72                                        (let ((indent (+ indent 4)))
  73                                          (format stream "~&~VT~A {~%" indent (proto-name msg))
  74                                          (map () (curry #'do-field v msg indent)
  75                                                  (proto-fields msg))
  76                                          (format stream "~&~VT}~%" indent)))))
  77                                   ((typep msg 'protobuf-enum)
  78                                    (let ((v (read-slot object slot reader)))
  79                                      (when v
  80                                        (print-enum v msg field stream indent)))))))))))
  81         (declare (dynamic-extent #'do-field))
  82         (format stream "~&~A {~%" (proto-name message))
  83         (map () (curry #'do-field object message 0) (proto-fields message))
  84         (format stream "~&}~%")
  85         nil))))
  86
  87 (defun print-prim (val type field stream &optional (indent 0))
  88   (when val
  89     (format stream "~&~VT~A: " (+ indent 2) (proto-name field))
  90     (ecase type
  91       ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
  92         :fixed32 :sfixed32 :fixed64 :sfixed64)
  93        (format stream "~D~%" val))
  94       ((:string)
  95        (format stream "\"~A\"~%" val))
  96       ((:bytes)
  97        (format stream "~S~%" val))
  98       ((:bool)
  99        (format stream "~A~%" (if val "true" "false")))
 100       ((:float :double)
 101        (format stream "~D~%" val))
 102       ;; A few of our homegrown types
 103       ((:symbol)
 104        (let ((val (if (keywordp val)
 105                     (string val)
 106                     (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
 107          (format stream "\"~A\"~%" val)))
 108       ((:date :time :datetime :timestamp)
 109        (format stream "~D~%" val)))))
 110
 111 (defun print-enum (val enum field stream &optional (indent 0))
 112   (when val
 113     (format stream "~&~VT~A: " (+ indent 2) (proto-name field))
 114     (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
 115                   (and e (proto-name e)))))
 116       (format stream "~A~%" name))))