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