clos-transform.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, 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 ;; Controls whether or not to use ':alias-for' for the Protobuf generated
  17 ;; for an existing Lisp class
  18 ;; The default is presently true because, at least initially, we'll be using
  19 ;; the generated Protobufs code in the Lisp world that includes that classes
  20 ;; from which the code was generated
  21 (defvar *alias-existing-classes* t)
  22
  23 ;; Doing this can't really work perfectly, there's not enough information
  24 ;;  - How do we decide if there's an ownership hierarchy that should produce embedded messages?
  25 ;;  - How do we decide if there are volatile slots that should not be included in the message?
  26 (defun write-schema-for-classes (classes
  27                                  &key (stream *standard-output*) (type :proto)
  28                                       name package lisp-package install
  29                                       slot-filter type-filter enum-filter value-filter
  30                                       (alias-existing-classes *alias-existing-classes*))
  31   "Given a set of CLOS classes, generates a Protobufs schema for the classes
  32    and pretty prints the schema to the stream.
  33    The return value is the schema."
  34   (let ((schema (generate-schema-for-classes classes
  35                   :name name
  36                   :package package
  37                   :lisp-package (or lisp-package package)
  38                   :install install
  39                   :slot-filter slot-filter
  40                   :type-filter type-filter
  41                   :enum-filter enum-filter
  42                   :value-filter value-filter
  43                   :alias-existing-classes alias-existing-classes)))
  44     (fresh-line stream)
  45     (write-schema schema :stream stream :type type)
  46     (terpri stream)
  47     schema))
  48
  49 (defun generate-schema-for-classes (classes
  50                                     &key name package lisp-package install
  51                                          slot-filter type-filter enum-filter value-filter
  52                                          (alias-existing-classes *alias-existing-classes*))
  53   "Given a set of CLOS classes, generates a Protobufs schema for the classes.
  54    The return value is the schema."
  55   (let* ((*alias-existing-classes* alias-existing-classes)
  56          (package  (and package (if (stringp package) package (string-downcase (string package)))))
  57          (lisp-pkg (string (or lisp-package package)))
  58          (schema   (make-instance 'protobuf-schema
  59                      :name name
  60                      :package package
  61                      :lisp-package lisp-pkg
  62                      :syntax "proto2"))
  63          (messages (mapcar #'(lambda (c)
  64                                (class-to-protobuf-message c schema
  65                                 :slot-filter slot-filter
  66                                 :type-filter type-filter
  67                                 :enum-filter enum-filter
  68                                 :value-filter value-filter))
  69                            classes)))
  70     (setf (proto-messages schema) messages)
  71     (when install
  72       (record-protobuf schema)
  73       (with-collectors ((messages collect-message))
  74         (labels ((collect-messages (message)
  75                    (collect-message message)
  76                    (map () #'collect-messages (proto-messages message))))
  77           (map () #'collect-messages (proto-messages schema)))
  78         (map () #'record-protobuf messages)))
  79     schema))
  80
  81
  82 (defun class-to-protobuf-message (class schema
  83                                   &key slot-filter type-filter enum-filter value-filter)
  84   "Given a CLOS class, return a Protobufs model object for it."
  85   (let* ((class (let ((c (find-class class)))
  86                   (unless (class-finalized-p c)
  87                     (finalize-inheritance c))           ;so the rest of the MOP will work
  88                   c))
  89          (slots (class-slots class)))
  90     (with-collectors ((enums  collect-enum)
  91                       (msgs   collect-msg)
  92                       (fields collect-field))
  93       (loop with index = 1
  94             for s in slots doing
  95         (multiple-value-bind (field msg enum)
  96             (slot-to-protobuf-field class s index slots
  97               :slot-filter slot-filter
  98               :type-filter type-filter
  99               :enum-filter enum-filter
 100               :value-filter value-filter)
 101           (when enum
 102             (collect-enum enum))
 103           (when msg
 104             (collect-msg msg))
 105           (when field
 106             (incf index 1)                              ;don't worry about the 19000-19999 restriction
 107             (collect-field field))))
 108       (make-instance 'protobuf-message
 109         :class (class-name class)
 110         :name  (class-name->proto (class-name class))
 111         :parent schema
 112         :alias-for (and *alias-existing-classes* (class-name class))
 113         :enums    (delete-duplicates enums :key #'proto-name :test #'string=)
 114         :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
 115         :fields   fields))))
 116
 117 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
 118 (defun slot-to-protobuf-field (class slot index slots
 119                                &key slot-filter type-filter enum-filter value-filter)
 120   "Given a CLOS slot, return a Protobufs model object for it."
 121   (when (or (null slot-filter)
 122             (funcall slot-filter slot slots))
 123     (multiple-value-bind (expanded-type unexpanded-type)
 124        (find-slot-definition-type class slot)
 125       (multiple-value-bind (type pclass packed enums)
 126           (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
 127         (multiple-value-bind (reqd vectorp)
 128             (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter)
 129           (let* ((ename (and enums
 130                              (if (and unexpanded-type (symbolp unexpanded-type))
 131                                (symbol-name unexpanded-type)
 132                                (format nil "~A-~A" 'enum (slot-definition-name slot)))))
 133                  (etype (and enums
 134                              (if (and unexpanded-type (symbolp unexpanded-type))
 135                                unexpanded-type
 136                                (intern ename (symbol-package (slot-definition-name slot))))))
 137                  (enum  (and enums
 138                              (let* ((names (mapcar #'enum-name->proto enums))
 139                                     (prefix (and (> (length names) 1)
 140                                                  (subseq (first names)
 141                                                          0 (mismatch (first names) (car (last names)))))))
 142                                (when (and prefix (> (length prefix) 2)
 143                                           (every #'(lambda (name) (starts-with name prefix)) names))
 144                                  (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
 145                                (unless (and unexpanded-type (symbolp unexpanded-type))
 146                                  #+ignore         ;this happens constantly, the warning is not useful
 147                                  (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
 148                                                  expanded-type))
 149                                (make-instance 'protobuf-enum
 150                                  :class  etype
 151                                  :name   (class-name->proto ename)
 152                                  :values (loop for name in names
 153                                                for val in enums
 154                                                for index upfrom 0
 155                                                collect (make-instance 'protobuf-enum-value
 156                                                          :name name
 157                                                          :index index
 158                                                          :value val))))))
 159                  (default (if (slot-definition-initfunction slot)
 160                             (clos-init-to-protobuf-default
 161                              (slot-definition-initform slot) expanded-type value-filter)
 162                             (if (eq reqd :repeated)
 163                               (if vectorp $empty-vector $empty-list)
 164                               $empty-default)))
 165                  (field   (make-instance 'protobuf-field
 166                             :name  (slot-name->proto (slot-definition-name slot))
 167                             :type  (if enum (class-name->proto ename) type)
 168                             :class (if enum etype pclass)
 169                             :required reqd
 170                             :index  index
 171                             :value  (slot-definition-name slot)
 172                             :reader (let ((reader (find-slot-definition-reader class slot)))
 173                                       ;; Only use the reader if it is "interesting"
 174                                       (unless (string= (symbol-name reader)
 175                                                        (format nil "~A-~A"
 176                                                                (class-name class) (slot-definition-name slot)))
 177                                         reader))
 178                             :default default
 179                             :packed  packed)))
 180             (values field nil enum)))))))
 181
 182 (defun find-slot-definition-type (class slotd)
 183   "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
 184   (let* ((slot-name    (slot-definition-name slotd))
 185          (direct-slotd (some #'(lambda (c)
 186                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 187                              (class-precedence-list class))))
 188     (if direct-slotd
 189       ;; The direct slotd will have an unexpanded definition
 190       ;; Prefer it for 'list-of' so we can get the base type
 191       (let ((type (slot-definition-type direct-slotd))
 192             (quux-list-of (and (find-package :quux)
 193                                (intern "LIST-OF" (find-package :quux)))))
 194         (values (if (and (listp type) (member (car type) `(list-of vector-of ,quux-list-of)))
 195                   type
 196                   (slot-definition-type slotd))
 197                 (if (symbolp type)
 198                   type
 199                   (when (and (listp type)
 200                              (eq (car type) 'or)
 201                              (member 'null (cdr type)))
 202                     (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
 203       (values (slot-definition-type slotd) nil))))
 204
 205 (defun find-slot-definition-reader (class slotd)
 206   "Given a class and a slot descriptor, find the name of a reader method for the slot."
 207   (let* ((slot-name    (slot-definition-name slotd))
 208          (direct-slotd (some #'(lambda (c)
 209                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 210                              (class-precedence-list class))))
 211     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 212
 213 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 214   "Given a Lisp type, returns a Protobuf type, a class or primitive type,
 215    whether or not to pack the field, and (optionally) a set of enum values."
 216   (let ((type (if type-filter (funcall type-filter type) type))
 217         ;; Hideous, but useful, kludge for those of us at ITA-by-Google
 218         (quux-list-of (and (find-package :quux)
 219                            (intern "LIST-OF" (find-package :quux)))))
 220     (flet ((type->protobuf-type (type)
 221              (case type
 222                ((int32)    (values "int32" :int32))
 223                ((int64)    (values "int64" :int64))
 224                ((uint32)   (values "uint32" :uint32))
 225                ((uint64)   (values "uint64" :uint64))
 226                ((sint32)   (values "sint32" :sint32))
 227                ((sint64)   (values "sint64" :sint64))
 228                ((fixed32)  (values "fixed32" :fixed32))
 229                ((fixed64)  (values "fixed64" :fixed64))
 230                ((sfixed32) (values "sfixed32" :sfixed32))
 231                ((sfixed64) (values "sfixed64" :sfixed64))
 232                ((integer)  (values "int64" :int64))
 233                ((single-float float)
 234                 (values "float" :float))
 235                ((double-float)
 236                 (values "double" :double))
 237                ((boolean)
 238                 (values "bool" :bool))
 239                ((symbol keyword)
 240                 (values "string" :symbol))
 241                (otherwise
 242                 (cond ((ignore-errors
 243                         (or (eql type 'symbol)
 244                             (subtypep type '(or string character))))
 245                        (values "string" :string))
 246                       ((ignore-errors
 247                         (subtypep type 'byte-vector))
 248                        (values "bytes" :bytes))
 249                       (t
 250                        (values (class-name->proto type) type)))))))
 251       (if (listp type)
 252         (destructuring-bind (head &rest tail) type
 253           (case head
 254             ((or)
 255              (when (or (> (length tail) 2)
 256                        (not (member 'null tail)))
 257                (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
 258              (if (eq (first tail) 'null)
 259                (clos-type-to-protobuf-type (second tail))
 260                (clos-type-to-protobuf-type (first tail))))
 261             ((and)
 262              (cond ((and quux-list-of
 263                          (ignore-errors
 264                           (subtypep type `(,quux-list-of t))))
 265                     ;; Special knowledge of 'quux:list-of', which uses (and list (satisfies <t>))
 266                     (let* ((satisfies (find 'satisfies tail :key #'car))
 267                            (pred (second satisfies))
 268                            (type (if (starts-with (string pred) "LIST-OF-")
 269                                    (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
 270                                    pred)))
 271                       (multiple-value-bind (type class)
 272                           (type->protobuf-type type)
 273                         (values type class (packed-type-p class)))))
 274                    (t
 275                     (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 276                       (when (> (length new-tail) 1)
 277                         (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
 278                       (type->protobuf-type (first tail))))))
 279             ((member)                           ;maybe generate an enum type
 280              (if (or (equal type '(member t nil))
 281                      (equal type '(member nil t)))
 282                (values "bool" :bool)
 283                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 284                  (cond ((every #'(lambda (x)
 285                                    (or (null x) (characterp x) (stringp x))) values)
 286                         (values "string" :string))
 287                        ((every #'(lambda (x)
 288                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 289                         (values "uint32" :uint32))
 290                        ((every #'(lambda (x)
 291                                    (or (null x) (integerp x))) values)
 292                         (values "int32" :int32))
 293                        ((every #'(lambda (x) (symbolp x)) values)
 294                         (let ((values (remove-if #'null values)))
 295                           (values (class-name->proto (format nil "~A" type))
 296                                   type
 297                                   nil           ;don't pack enums
 298                                   (if enum-filter (funcall enum-filter values) values))))
 299                        (t
 300                         (error "The MEMBER type ~S is too complicated" type))))))
 301             ((list-of vector-of)
 302              (multiple-value-bind (type class)
 303                  (type->protobuf-type (first tail))
 304                (values type class (packed-type-p class))))
 305             ((integer)
 306              (let ((lo (or (first tail) '*))
 307                    (hi (or (second tail) '*)))
 308                (if (or (eq lo '*) (< lo 0))
 309                  (if (eq hi '*)
 310                    (values "int64" :int64)
 311                    (if (<= (integer-length hi) 32)
 312                      (values "int32" :int32)
 313                      (values "int64" :int64)))
 314                  (if (eq hi '*)
 315                    (values "uint64" :uint64)
 316                    (if (<= (integer-length hi) 32)
 317                      (values "uint32" :uint32)
 318                      (values "uint64" :uint64))))))
 319             ((signed-byte)
 320              (let ((len (first tail)))
 321                (if (<= len 32)
 322                  (values "int32" :int32)
 323                  (values "int64" :int64))))
 324             ((unsigned-byte)
 325              (let ((len (first tail)))
 326                (if (<= len 32)
 327                  (values "uint32" :uint32)
 328                  (values "uint64" :uint64))))
 329             ((float single-float double-float)
 330              (type->protobuf-type head))
 331             (otherwise
 332              (if (eq head quux-list-of)
 333                (multiple-value-bind (type class)
 334                    (type->protobuf-type (first tail))
 335                  (values type class (packed-type-p class)))
 336                (type->protobuf-type type)))))
 337         (type->protobuf-type type)))))
 338
 339 (defun packed-type-p (type)
 340   "Returns true if the given Protobufs type can use a packed field."
 341   (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 342                             :fixed32 :fixed64 :sfixed32 :sfixed64
 343                             :bool :float :double)))))
 344
 345 (defun clos-type-to-protobuf-required (type &optional type-filter)
 346   "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
 347    If the sceond returned value is true, it's a repeated field that should use a vector."
 348   (let ((type (if type-filter (funcall type-filter type) type))
 349         (quux-list-of (and (find-package :quux)
 350                            (intern "LIST-OF" (find-package :quux)))))
 351     (if (listp type)
 352       (destructuring-bind (head &rest tail) type
 353         (case head
 354           ((or)
 355            (let ((optional (member 'null tail))
 356                  (repeated (find-if #'(lambda (r)
 357                                         (eq (clos-type-to-protobuf-required r) :repeated)) tail)))
 358              (if repeated
 359                (clos-type-to-protobuf-required repeated)
 360                (values (if optional :optional :required) nil))))
 361           ((and)
 362            (cond ((or (subtypep type '(list-of t))
 363                       (and quux-list-of (subtypep type `(,quux-list-of t))))
 364                   (values :repeated nil))
 365                  ((subtypep type '(vector-of t))
 366                   (values :repeated t))
 367                  (t
 368                   (values :required nil))))
 369           ((member)
 370            (if (or (equal type '(member t nil))
 371                    (equal type '(member nil t)))
 372              (values :required nil)
 373              (values (if (member nil tail) :optional :required) nil)))
 374           ((list-of)
 375            (values :repeated nil))
 376           ((vector-of)
 377            (values :repeated t))
 378           (otherwise
 379            (if (eq head quux-list-of)
 380              (values :repeated nil)
 381              (values :required nil)))))
 382       (values :required nil))))
 383
 384 (defun clos-init-to-protobuf-default (value type &optional value-filter)
 385   "Given an initform and a Lisp type, returns a plausible default value.
 386    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 387   (let ((value (if value-filter (funcall value-filter value) value)))
 388     (and (constantp value)
 389          (ignore-errors (typep value type))
 390          (values value t))))
 391
 392 (defun protobuf-default-to-clos-init (default type)
 393   "Given a Protobufs type and default, return a CLOS initform value.
 394    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 395   (cond ((ignore-errors (typep default type))
 396          default)
 397         ((symbolp default)
 398          (cond ((eq type :bool)
 399                 (boolean-true-p default))
 400                ;; If we've got a symbol, it must be to initialize an enum type
 401                ;; whose values are represented by keywords in Lisp
 402                (t (kintern (symbol-name default)))))
 403         ((stringp default)
 404          (cond ((eq type :bool)
 405                 (boolean-true-p default))
 406                ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 407                                :fixed32 :sfixed32 :fixed64 :sfixed64))
 408                 (let ((default (read-from-string default)))
 409                   (and (integerp default) default)))
 410                ((member type '(:float :double))
 411                 (let ((default (read-from-string default)))
 412                   (and (floatp default) default)))
 413                (t default)))))
 414
 415 (defun boolean-true-p (x)
 416   "Returns t or nil given a value that might be a boolean."
 417   (etypecase x
 418     ((member t nil) x)
 419     (integer   (not (eql x 0)))
 420     (character (char-equal x #\t))
 421     (string    (or (string-equal x "true")
 422                    (string-equal x "yes")
 423                    (string-equal x "t")
 424                    (string-equal x "1")))
 425     (symbol    (string-equal (string x) "true"))))