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 (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 (type pclass packed enums)
 104         (clos-type-to-protobuf-type (find-slot-definition-type class slot) type-filter enum-filter)
 105       (let* ((ename (and enums
 106                          (format nil "~A-~A" 'enum (slot-definition-name slot))))
 107              (enum  (and enums
 108                          (let* ((names (mapcar #'enum-name->proto enums))
 109                                 (prefix (and (> (length names) 1)
 110                                              (subseq (first names)
 111                                                      0 (mismatch (first names) (second names))))))
 112                            (when (and prefix (> (length prefix) 2)
 113                                       (every #'(lambda (name) (starts-with name prefix)) names))
 114                              (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
 115                            (make-instance 'protobuf-enum
 116                              :class  (intern ename (symbol-package (slot-definition-name slot)))
 117                              :name   (class-name->proto ename)
 118                              :values (loop for name in names
 119                                            for val in enums
 120                                            for index upfrom 1
 121                                            collect (make-instance 'protobuf-enum-value
 122                                                      :name name
 123                                                      :index index
 124                                                      :value val))))))
 125              (reqd  (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter))
 126              (field (make-instance 'protobuf-field
 127                       :name  (slot-name->proto (slot-definition-name slot))
 128                       :type  (if enum (class-name->proto ename) type)
 129                       :class (if enum (intern ename (symbol-package (slot-definition-name slot))) pclass)
 130                       :required reqd
 131                       :index index
 132                       :value   (slot-definition-name slot)
 133                       :reader  (let ((reader (find-slot-definition-reader class slot)))
 134                                  ;; Only use the reader if it is "interesting"
 135                                  (unless (string= (symbol-name reader)
 136                                                   (format nil "~A-~A"
 137                                                           (class-name class) (slot-definition-name slot)))
 138                                    reader))
 139                       :default (clos-init-to-protobuf-default (slot-definition-initform slot) value-filter)
 140                       :packed  packed)))
 141         (values field nil enum)))))
 142
 143 ;; Given a class and a slot descriptor, find the unexpanded type definition for the slot
 144 (defun find-slot-definition-type (class slotd)
 145   (let* ((slot-name    (slot-definition-name slotd))
 146          (direct-slotd (some #'(lambda (c)
 147                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 148                              (class-precedence-list class))))
 149     (if direct-slotd
 150       (let ((type (slot-definition-type direct-slotd)))
 151         (if (and (listp type) (member (car type) '(list-of #+quux quux:list-of)))
 152           type
 153           (slot-definition-type slotd)))
 154       (slot-definition-type slotd))))
 155
 156 ;; Given a class and a slot descriptor, find the name of a reader method for the slot
 157 (defun find-slot-definition-reader (class slotd)
 158   (let* ((slot-name    (slot-definition-name slotd))
 159          (direct-slotd (some #'(lambda (c)
 160                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 161                              (class-precedence-list class))))
 162     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 163
 164 ;; Returns Protobuf type, a class or primitive type, whether or not to pack the field,
 165 ;; and (optionally) a set of enum values
 166 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 167   (let ((type (if type-filter (funcall type-filter type) type)))
 168     (flet ((type->protobuf-type (type)
 169              (case type
 170                ((boolean)
 171                 (values "bool" :bool))
 172                ((integer)
 173                 (values "int64" :int64))
 174                ((float)
 175                 (values "float" :float))
 176                ((double-float)
 177                 (values "double" :double))
 178                ((symbol keyword)
 179                 (values "string" :symbol))
 180                (otherwise
 181                 (if (ignore-errors
 182                       (subtypep type '(or string character)))
 183                   (values "string" :string)
 184                   (values (class-name->proto type) type))))))
 185       (if (listp type)
 186         (destructuring-bind (head &rest tail) type
 187           (case head
 188             ((or)
 189              (when (or (> (length tail) 2)
 190                        (not (member 'null tail)))
 191                (protobufs-warn "Can't handle the complicated OR type ~S" type))
 192              (if (eq (first tail) 'null)
 193                (clos-type-to-protobuf-type (second tail))
 194                (clos-type-to-protobuf-type (first tail))))
 195             ((and)
 196              (cond #+quux
 197                    ((subtypep type '(quux:list-of t))
 198                     ;; Special knowledge of Quux 'list-of', which uses (and list (satisfies <t>))
 199                     (let* ((satisfies (find 'satisfies tail :key #'car))
 200                            (pred (second satisfies))
 201                            (type (if (starts-with (string pred) "LIST-OF-")
 202                                    (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
 203                                    pred)))
 204                       (multiple-value-bind (type class)
 205                           (type->protobuf-type type)
 206                         (values type class (packed-type-p class)))))
 207                    (t
 208                     (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 209                       (assert (= (length new-tail) 1) ()
 210                               "Can't handle the complicated AND type ~S" type)
 211                       (type->protobuf-type (first tail))))))
 212             ((member)                           ;maybe generate an enum type
 213              (if (or (equal type '(member t nil))
 214                      (equal type '(member nil t)))
 215                (values "bool" :bool)
 216                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 217                  (cond ((every #'(lambda (x)
 218                                    (or (null x) (characterp x) (stringp x))) values)
 219                         (values "string" :string))
 220                        ((every #'(lambda (x)
 221                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 222                         (values "uint32" :uint32))
 223                        ((every #'(lambda (x)
 224                                    (or (null x) (integerp x))) values)
 225                         (values "int32" :int32))
 226                        (t
 227                         (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S" type)
 228                         (let ((values (remove-if #'null values)))
 229                           (values (class-name->proto type)
 230                                   type
 231                                   nil           ;don't pack enums
 232                                   (if enum-filter (funcall enum-filter values) values))))))))
 233             ((list-of #+quux quux:list-of)      ;special knowledge of 'list-of'
 234              (multiple-value-bind (type class)
 235                  (type->protobuf-type (first tail))
 236                (values type class (packed-type-p class))))
 237             ((integer)
 238              (let ((lo (or (first tail) '*))
 239                    (hi (or (second tail) '*)))
 240                (if (or (eq lo '*) (< lo 0))
 241                  (if (eq hi '*)
 242                    (values "int64" :int64)
 243                    (if (<= (integer-length hi) 32)
 244                      (values "int32" :int32)
 245                      (values "int64" :int64)))
 246                  (if (eq hi '*)
 247                    (values "uint64" :uint64)
 248                    (if (<= (integer-length hi) 32)
 249                      (values "uint32" :uint32)
 250                      (values "uint64" :uint64))))))
 251             ((signed-byte)
 252              (let ((len (first tail)))
 253                (if (<= len 32)
 254                  (values "int32" :int32)
 255                  (values "int64" :int64))))
 256             ((unsigned-byte)
 257              (let ((len (first tail)))
 258                (if (<= len 32)
 259                  (values "uint32" :uint32)
 260                  (values "uint64" :uint64))))
 261             ((float double-float)
 262              (type->protobuf-type head))
 263             (otherwise
 264              (if (subtypep head '(or string character))
 265                (values "string" :string)
 266                (error "Don't know how to translate the type ~S" head)))))
 267         (type->protobuf-type type)))))
 268
 269 (defun packed-type-p (class)
 270   (not (null (member class '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 271                              :fixed32 :fixed64 :sfixed32 :sfixed64
 272                              :float :double)))))
 273
 274 (defun clos-type-to-protobuf-required (type &optional type-filter)
 275   (let ((type (if type-filter (funcall type-filter type) type)))
 276     (if (listp type)
 277       (destructuring-bind (head &rest tail) type
 278         (case head
 279           ((or)
 280            (let ((optional (member 'null (cdr type))))
 281              (if (loop for r in tail
 282                        thereis (eq (clos-type-to-protobuf-required r) :repeated))
 283                :repeated
 284                (if optional :optional :required))))
 285           ((and)
 286            (if (or (subtypep type '(list-of t))
 287                    #+quux (subtypep type '(quux:list-of t)))
 288              :repeated
 289              :required))
 290           ((member)
 291            (if (or (equal type '(member t nil))
 292                    (equal type '(member nil t)))
 293              :required
 294              (if (member nil tail) :optional :required)))
 295           ((list-of #+quux quux:list-of)
 296            :repeated)
 297           (otherwise
 298            :required)))
 299       :required)))
 300
 301 (defun clos-init-to-protobuf-default (value &optional value-filter)
 302   (let ((value (if value-filter (funcall value-filter value) value)))
 303     (and value (constantp value)
 304          (format nil "~A" value))))
 305
 306 (defun protobuf-default-to-clos-init (default type)
 307   (cond ((or (null default)
 308              (and (stringp default) (i= (length default) 0)))
 309          nil)
 310         ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 311                         :fixed32 :sfixed32 :fixed64 :sfixed64
 312                         :single :double))
 313          (read-from-string default))
 314         ((eq type :bool)
 315          (if (string= default "true") t nil))
 316         (t default)))