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