clos-transform.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 ;;; Protocol buffer generation from ordinary CLOS classes
  15
  16 ;; Doing this can't really work perfectly, there's not enough information
  17 ;;  - How do we decide if there's an ownership hierarchy that should produce embedded messages?
  18 ;;  - How do we decide if there are volatile slots that should not be included in the message?
  19 (defun write-protobuf-schema-for-classes (classes
  20                                           &key (stream *standard-output*)
  21                                                package slot-filter type-filter enum-filter value-filter)
  22   (let* ((messages (mapcar #'(lambda (c)
  23                                (class-to-protobuf-message c :slot-filter slot-filter
  24                                                             :type-filter type-filter
  25                                                             :enum-filter enum-filter
  26                                                             :value-filter value-filter))
  27                            classes))
  28          (protobuf (make-instance 'protobuf
  29                      :package package
  30                      :messages messages)))
  31     (fresh-line stream)
  32     (write-protobuf protobuf stream)
  33     (terpri stream)
  34     protobuf))
  35
  36
  37 (defun class-to-protobuf-message (class &key slot-filter type-filter enum-filter value-filter)
  38   (let* ((class (find-class class))
  39          (slots (class-slots class)))
  40     (with-collectors ((enums  collect-enum)
  41                       (msgs   collect-msg)
  42                       (fields collect-field))
  43       (loop with index = 1
  44             for s in slots doing
  45         (multiple-value-bind (field msg enum)
  46             (slot-to-protobuf-field s index slots
  47                                     :slot-filter slot-filter
  48                                     :type-filter type-filter
  49                                     :enum-filter enum-filter
  50                                     :value-filter value-filter)
  51           (when enum
  52             (collect-enum enum))
  53           (when msg
  54             (collect-msg msg))
  55           (when field
  56             (incf index 1)
  57             (collect-field field))))
  58       (make-instance 'protobuf-message
  59         :name  (proto-class-name (class-name class))
  60         :class (class-name class)
  61         :enums (delete-duplicates enums :key #'proto-name :test #'string-equal)
  62         :messages (delete-duplicates msgs :key #'proto-name :test #'string-equal)
  63         :fields fields))))
  64
  65 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
  66 (defun slot-to-protobuf-field (slot index slots &key slot-filter type-filter enum-filter value-filter)
  67   (when (or (null slot-filter)
  68             (funcall slot-filter slot slots))
  69     (multiple-value-bind (type class packed enums)
  70         (clos-type-to-protobuf-type (slot-definition-type slot) type-filter enum-filter)
  71       (let* ((ename (and enums
  72                          (format nil "~A-~A" 'enum (slot-definition-name slot))))
  73              (enum  (and enums
  74                          (let* ((names (mapcar #'proto-enum-name enums))
  75                                 (prefix (and (> (length names) 1)
  76                                              (subseq (first names)
  77                                                      0 (mismatch (first names) (second names))))))
  78                            (when (and prefix (> (length prefix) 2)
  79                                       (every #'(lambda (name) (starts-with name prefix)) names))
  80                              (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
  81                            (make-instance 'protobuf-enum
  82                              :name   (proto-class-name ename)
  83                              :class  (intern ename (symbol-package (slot-definition-name slot)))
  84                              :values (loop for name in names
  85                                            for val in enums
  86                                            for index upfrom 1
  87                                            collect (make-instance 'protobuf-enum-value
  88                                                      :name name
  89                                                      :index index
  90                                                      :value val))))))
  91              (field (make-instance 'protobuf-field
  92                       :name  (proto-field-name (slot-definition-name slot))
  93                       :type  (if enum (proto-class-name ename) type)
  94                       :class (if enum (intern ename (symbol-package (slot-definition-name slot))) class)
  95                       :required (clos-type-to-protobuf-required (slot-definition-type slot) type-filter)
  96                       :index index
  97                       :value (slot-definition-name slot)
  98                       :default (clos-init-to-protobuf-default (slot-definition-initform slot) value-filter)
  99                       :packed packed)))
 100         (values field nil enum)))))
 101
 102 ;; Returns Protobuf type, a class or primitive type, whether or not to pack the field,
 103 ;; and (optionally) a set of enum values
 104 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 105   (let ((type (if type-filter (funcall type-filter type) type)))
 106     (flet ((type->protobuf-type (type)
 107              (case type
 108                ((boolean)
 109                 (values "bool" :bool))
 110                ((integer)
 111                 (values "int64" :int64))
 112                ((float)
 113                 (values "float" :float))
 114                ((double-float)
 115                 (values "double" :double))
 116                ((symbol keyword)
 117                 (values "string" :symbol))
 118                (otherwise
 119                 (if (ignore-errors
 120                       (subtypep type '(or string character)))
 121                   (values "string" :string)
 122                   (values (proto-class-name type) type))))))
 123       (if (listp type)
 124         (destructuring-bind (head &rest tail) type
 125           (case head
 126             ((or)
 127              (when (or (> (length tail) 2)
 128                        (not (member 'null tail)))
 129                (warn "Can't handle the complicated OR type ~S" type))
 130              (if (eq (first tail) 'null)
 131                (clos-type-to-protobuf-type (second tail))
 132                (clos-type-to-protobuf-type (first tail))))
 133             ((and)
 134              (if (subtypep type '(list-of t))   ;special knowledge of Quux list-of
 135                (let ((satisfies (find 'satisfies tail :key #'car)))
 136                  (let* ((pred (second satisfies))
 137                         (type (if (starts-with (string pred) "LIST-OF-")
 138                                 (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
 139                                 pred)))
 140                    (multiple-value-bind (type class)
 141                        (type->protobuf-type type)
 142                      (values type class (packed-type-p class)))))
 143                (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 144                  (assert (= (length new-tail) 1) ()
 145                          "Can't handle the complicated AND type ~S" type)
 146                  (type->protobuf-type (first tail)))))
 147             ((member)                           ;maybe generate an enum type
 148              (if (or (equal type '(member t nil))
 149                      (equal type '(member nil t)))
 150                (values "bool" :bool)
 151                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 152                  (cond ((every #'(lambda (x)
 153                                    (or (null x) (characterp x) (stringp x))) values)
 154                         (values "string" :string))
 155                        ((every #'(lambda (x)
 156                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 157                         (values "uint32" :uint32))
 158                        ((every #'(lambda (x)
 159                                    (or (null x) (integerp x))) values)
 160                         (values "int32" :int32))
 161                        (t
 162                         (warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S" type)
 163                         (let ((values (remove-if #'null values)))
 164                           (values (proto-class-name type)
 165                                   type
 166                                   nil           ;don't pack enums
 167                                   (if enum-filter (funcall enum-filter values) values))))))))
 168             ((list-of)                          ;special knowledge of Quux list-of
 169              (multiple-value-bind (type class)
 170                  (type->protobuf-type (first tail))
 171                (values type class (packed-type-p class))))
 172             ((integer)
 173              (let ((lo (or (first tail) '*))
 174                    (hi (or (second tail) '*)))
 175                (if (or (eq lo '*) (< lo 0))
 176                  (if (eq hi '*)
 177                    (values "int64" :int64)
 178                    (if (<= (integer-length hi) 32)
 179                      (values "int32" :int32)
 180                      (values "int64" :int64)))
 181                  (if (eq hi '*)
 182                    (values "uint64" :uint64)
 183                    (if (<= (integer-length hi) 32)
 184                      (values "uint32" :uint32)
 185                      (values "uint64" :uint64))))))
 186             ((signed-byte)
 187              (let ((len (first tail)))
 188                (if (<= len 32)
 189                  (values "int32" :int32)
 190                  (values "int64" :int64))))
 191             ((unsigned-byte)
 192              (let ((len (first tail)))
 193                (if (<= len 32)
 194                  (values "uint32" :uint32)
 195                  (values "uint64" :uint64))))
 196             ((float double-float)
 197              (type->protobuf-type head))
 198             (otherwise
 199              (if (subtypep head '(or string character))
 200                (values "string" :string)
 201                (error "Don't know how to translate the type ~S" head)))))
 202         (type->protobuf-type type)))))
 203
 204 (defun packed-type-p (class)
 205   (not (null (member class '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 206                              :fixed32 :fixed64 :sfixed32 :sfixed64
 207                              :float :double)))))
 208
 209 (defun clos-type-to-protobuf-required (type &optional type-filter)
 210   (let ((type (if type-filter (funcall type-filter type) type)))
 211     (if (listp type)
 212       (destructuring-bind (head &rest tail) type
 213         (case head
 214           ((or)
 215            (let ((optional (member 'null (cdr type))))
 216              (if (loop for r in tail
 217                        thereis (eq (clos-type-to-protobuf-required r) :repeated))
 218                :repeated
 219                (if optional :optional :required))))
 220           ((and)
 221            (if (subtypep type '(list-of t))     ;special knowledge of Quux list-of
 222              :repeated
 223              :required))
 224           ((member)
 225            (if (or (equal type '(member t nil))
 226                    (equal type '(member nil t)))
 227              :required
 228              (if (member nil tail) :optional :required)))
 229           (list-of
 230            :repeated)
 231           (otherwise
 232            :required)))
 233       :required)))
 234
 235 (defun clos-init-to-protobuf-default (value &optional value-filter)
 236   (let ((value (if value-filter (funcall value-filter value) value)))
 237     (and value (constantp value)
 238          (format nil "~A" value))))