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)
  21                                                name package lisp-package
  22                                                slot-filter type-filter enum-filter value-filter)
  23   "Given a set of CLOS classes, generates a Protobufs schema for the classes
  24    and pretty prints the schema to the stream.
  25    The return value is the schema."
  26   (let ((protobuf (generate-protobuf-schema-for-classes classes
  27                     :name name
  28                     :package package
  29                     :lisp-package (or lisp-package package)
  30                     :slot-filter slot-filter
  31                     :type-filter type-filter
  32                     :enum-filter enum-filter
  33                     :value-filter value-filter)))
  34     (fresh-line stream)
  35     (write-protobuf protobuf :stream stream :type type)
  36     (terpri stream)
  37     protobuf))
  38
  39 (defun generate-protobuf-schema-for-classes (classes
  40                                              &key name package lisp-package
  41                                                   slot-filter type-filter enum-filter value-filter)
  42   "Given a set of CLOS classes, generates a Protobufs schema for the classes.
  43    The return value is the schema."
  44   (let* ((package  (and package (if (stringp package) package (string-downcase (string package)))))
  45          (lisp-pkg (string (or lisp-package package)))
  46          (protobuf (make-instance 'protobuf
  47                      :name name
  48                      :package package
  49                      :lisp-package lisp-pkg
  50                      :syntax "proto2"))
  51          (messages (mapcar #'(lambda (c)
  52                                (class-to-protobuf-message c protobuf
  53                                 :slot-filter slot-filter
  54                                 :type-filter type-filter
  55                                 :enum-filter enum-filter
  56                                 :value-filter value-filter))
  57                            classes)))
  58     (setf (proto-messages protobuf) messages)
  59     protobuf))
  60
  61
  62 ;; Controls whether or not to use ':alias-for' for the generated Protobuf
  63 ;; Bind this to 'true' when you plan to use the generated Protobufs code in
  64 ;; a Lisp world that includes that classes from which the code was generated
  65 (defvar *alias-existing-classes* nil)
  66
  67 (defun class-to-protobuf-message (class protobuf
  68                                   &key slot-filter type-filter enum-filter value-filter)
  69   (let* ((class (find-class class))
  70          (slots (class-slots class)))
  71     (with-collectors ((enums  collect-enum)
  72                       (msgs   collect-msg)
  73                       (fields collect-field))
  74       (loop with index = 1
  75             for s in slots doing
  76         (multiple-value-bind (field msg enum)
  77             (slot-to-protobuf-field class s index slots
  78               :slot-filter slot-filter
  79               :type-filter type-filter
  80               :enum-filter enum-filter
  81               :value-filter value-filter)
  82           (when enum
  83             (collect-enum enum))
  84           (when msg
  85             (collect-msg msg))
  86           (when field
  87             (incf index 1)                              ;don't worry about the 19000-19999 restriction
  88             (collect-field field))))
  89       (make-instance 'protobuf-message
  90         :class (class-name class)
  91         :name  (class-name->proto (class-name class))
  92         :parent protobuf
  93         :alias-for (and *alias-existing-classes* (class-name class))
  94         :enums    (delete-duplicates enums :key #'proto-name :test #'string=)
  95         :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
  96         :fields   fields))))
  97
  98 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
  99 (defun slot-to-protobuf-field (class slot index slots
 100                                &key slot-filter type-filter enum-filter value-filter)
 101   (when (or (null slot-filter)
 102             (funcall slot-filter slot slots))
 103     (multiple-value-bind (expanded-type unexpanded-type)
 104        (find-slot-definition-type class slot)
 105       (multiple-value-bind (type pclass packed enums)
 106           (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
 107         (let* ((ename (and enums
 108                            (if (and unexpanded-type (symbolp unexpanded-type))
 109                              (symbol-name unexpanded-type)
 110                              (format nil "~A-~A" 'enum (slot-definition-name slot)))))
 111                (etype (and enums
 112                            (if (and unexpanded-type (symbolp unexpanded-type))
 113                              unexpanded-type
 114                              (intern ename (symbol-package (slot-definition-name slot))))))
 115                (enum  (and enums
 116                            (let* ((names (mapcar #'enum-name->proto enums))
 117                                   (prefix (and (> (length names) 1)
 118                                                (subseq (first names)
 119                                                        0 (mismatch (first names) (car (last names)))))))
 120                              (when (and prefix (> (length prefix) 2)
 121                                         (every #'(lambda (name) (starts-with name prefix)) names))
 122                                (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
 123                              (unless (and unexpanded-type (symbolp unexpanded-type))
 124                                (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S" type))
 125                              (make-instance 'protobuf-enum
 126                                :class  etype
 127                                :name   (class-name->proto ename)
 128                                :values (loop for name in names
 129                                              for val in enums
 130                                              for index upfrom 0
 131                                              collect (make-instance 'protobuf-enum-value
 132                                                        :name name
 133                                                        :index index
 134                                                        :value val))))))
 135                (reqd  (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter))
 136                (field (make-instance 'protobuf-field
 137                         :name  (slot-name->proto (slot-definition-name slot))
 138                         :type  (if enum (class-name->proto ename) type)
 139                         :class (if enum etype pclass)
 140                         :required reqd
 141                         :index index
 142                         :value   (slot-definition-name slot)
 143                         :reader  (let ((reader (find-slot-definition-reader class slot)))
 144                                    ;; Only use the reader if it is "interesting"
 145                                    (unless (string= (symbol-name reader)
 146                                                     (format nil "~A-~A"
 147                                                             (class-name class) (slot-definition-name slot)))
 148                                      reader))
 149                         :default (clos-init-to-protobuf-default (slot-definition-initform slot) value-filter)
 150                         :packed  packed)))
 151           (values field nil enum))))))
 152
 153 ;; Given a class and a slot descriptor, find the "best" type definition for the slot
 154 (defun find-slot-definition-type (class slotd)
 155   (let* ((slot-name    (slot-definition-name slotd))
 156          (direct-slotd (some #'(lambda (c)
 157                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 158                              (class-precedence-list class))))
 159     (if direct-slotd
 160       ;; The direct slotd will have an unexpanded definition
 161       ;; Prefer it for 'list-of' so we can get the base type
 162       (let ((type (slot-definition-type direct-slotd)))
 163         (values (if (and (listp type) (member (car type) '(list-of #+quux quux:list-of)))
 164                   type
 165                   (slot-definition-type slotd))
 166                 (if (symbolp type)
 167                   type
 168                   (when (and (listp type)
 169                              (eql (car type) 'or)
 170                              (member 'null (cdr type)))
 171                     (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
 172       (values (slot-definition-type slotd) nil))))
 173
 174 ;; Given a class and a slot descriptor, find the name of a reader method for the slot
 175 (defun find-slot-definition-reader (class slotd)
 176   (let* ((slot-name    (slot-definition-name slotd))
 177          (direct-slotd (some #'(lambda (c)
 178                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 179                              (class-precedence-list class))))
 180     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 181
 182 ;; Returns Protobuf type, a class or primitive type, whether or not to pack the field,
 183 ;; and (optionally) a set of enum values
 184 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 185   (let ((type (if type-filter (funcall type-filter type) type)))
 186     (flet ((type->protobuf-type (type)
 187              (case type
 188                ((boolean)
 189                 (values "bool" :bool))
 190                ((integer)
 191                 (values "int64" :int64))
 192                ((float)
 193                 (values "float" :float))
 194                ((double-float)
 195                 (values "double" :double))
 196                ((symbol keyword)
 197                 (values "string" :symbol))
 198                (otherwise
 199                 (if (ignore-errors
 200                       (subtypep type '(or string character)))
 201                   (values "string" :string)
 202                   (values (class-name->proto type) type))))))
 203       (if (listp type)
 204         (destructuring-bind (head &rest tail) type
 205           (case head
 206             ((or)
 207              (when (or (> (length tail) 2)
 208                        (not (member 'null tail)))
 209                (protobufs-warn "Can't handle the complicated OR type ~S" type))
 210              (if (eq (first tail) 'null)
 211                (clos-type-to-protobuf-type (second tail))
 212                (clos-type-to-protobuf-type (first tail))))
 213             ((and)
 214              (cond #+quux
 215                    ((subtypep type '(quux:list-of t))
 216                     ;; Special knowledge of Quux 'list-of', which uses (and list (satisfies <t>))
 217                     (let* ((satisfies (find 'satisfies tail :key #'car))
 218                            (pred (second satisfies))
 219                            (type (if (starts-with (string pred) "LIST-OF-")
 220                                    (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
 221                                    pred)))
 222                       (multiple-value-bind (type class)
 223                           (type->protobuf-type type)
 224                         (values type class (packed-type-p class)))))
 225                    (t
 226                     (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 227                       (assert (= (length new-tail) 1) ()
 228                               "Can't handle the complicated AND type ~S" type)
 229                       (type->protobuf-type (first tail))))))
 230             ((member)                           ;maybe generate an enum type
 231              (if (or (equal type '(member t nil))
 232                      (equal type '(member nil t)))
 233                (values "bool" :bool)
 234                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 235                  (cond ((every #'(lambda (x)
 236                                    (or (null x) (characterp x) (stringp x))) values)
 237                         (values "string" :string))
 238                        ((every #'(lambda (x)
 239                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 240                         (values "uint32" :uint32))
 241                        ((every #'(lambda (x)
 242                                    (or (null x) (integerp x))) values)
 243                         (values "int32" :int32))
 244                        (t
 245                         (let ((values (remove-if #'null values)))
 246                           (values (class-name->proto type)
 247                                   type
 248                                   nil           ;don't pack enums
 249                                   (if enum-filter (funcall enum-filter values) values))))))))
 250             ((list-of #+quux quux:list-of)      ;special knowledge of 'list-of'
 251              (multiple-value-bind (type class)
 252                  (type->protobuf-type (first tail))
 253                (values type class (packed-type-p class))))
 254             ((integer)
 255              (let ((lo (or (first tail) '*))
 256                    (hi (or (second tail) '*)))
 257                (if (or (eq lo '*) (< lo 0))
 258                  (if (eq hi '*)
 259                    (values "int64" :int64)
 260                    (if (<= (integer-length hi) 32)
 261                      (values "int32" :int32)
 262                      (values "int64" :int64)))
 263                  (if (eq hi '*)
 264                    (values "uint64" :uint64)
 265                    (if (<= (integer-length hi) 32)
 266                      (values "uint32" :uint32)
 267                      (values "uint64" :uint64))))))
 268             ((signed-byte)
 269              (let ((len (first tail)))
 270                (if (<= len 32)
 271                  (values "int32" :int32)
 272                  (values "int64" :int64))))
 273             ((unsigned-byte)
 274              (let ((len (first tail)))
 275                (if (<= len 32)
 276                  (values "uint32" :uint32)
 277                  (values "uint64" :uint64))))
 278             ((float double-float)
 279              (type->protobuf-type head))
 280             (otherwise
 281              (if (subtypep head '(or string character))
 282                (values "string" :string)
 283                (error "Don't know how to translate the type ~S" head)))))
 284         (type->protobuf-type type)))))
 285
 286 (defun packed-type-p (class)
 287   (not (null (member class '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 288                              :fixed32 :fixed64 :sfixed32 :sfixed64
 289                              :float :double)))))
 290
 291 (defun clos-type-to-protobuf-required (type &optional type-filter)
 292   (let ((type (if type-filter (funcall type-filter type) type)))
 293     (if (listp type)
 294       (destructuring-bind (head &rest tail) type
 295         (case head
 296           ((or)
 297            (let ((optional (member 'null (cdr type))))
 298              (if (loop for r in tail
 299                        thereis (eq (clos-type-to-protobuf-required r) :repeated))
 300                :repeated
 301                (if optional :optional :required))))
 302           ((and)
 303            (if (or (subtypep type '(list-of t))
 304                    #+quux (subtypep type '(quux:list-of t)))
 305              :repeated
 306              :required))
 307           ((member)
 308            (if (or (equal type '(member t nil))
 309                    (equal type '(member nil t)))
 310              :required
 311              (if (member nil tail) :optional :required)))
 312           ((list-of #+quux quux:list-of)
 313            :repeated)
 314           (otherwise
 315            :required)))
 316       :required)))
 317
 318 (defun clos-init-to-protobuf-default (value &optional value-filter)
 319   (let ((value (if value-filter (funcall value-filter value) value)))
 320     (and value (constantp value)
 321          (format nil "~A" value))))
 322
 323 (defun protobuf-default-to-clos-init (default type)
 324   (cond ((or (null default)
 325              (and (stringp default) (i= (length default) 0)))
 326          nil)
 327         ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 328                         :fixed32 :sfixed32 :fixed64 :sfixed64
 329                         :single :double))
 330          (read-from-string default))
 331         ((eq type :bool)
 332          (if (string= default "true") t nil))
 333         (t default)))