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          (*protobuf* schema)
  64          (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
  65          (messages (mapcar #'(lambda (c)
  66                                (class-to-protobuf-message c schema
  67                                 :slot-filter slot-filter
  68                                 :type-filter type-filter
  69                                 :enum-filter enum-filter
  70                                 :value-filter value-filter))
  71                            classes)))
  72     (setf (proto-messages schema) messages)
  73     (when install
  74       (record-protobuf schema)
  75       (with-collectors ((messages collect-message))
  76         (labels ((collect-messages (message)
  77                    (collect-message message)
  78                    (map () #'collect-messages (proto-messages message))))
  79           (map () #'collect-messages (proto-messages schema)))
  80         (map () #'record-protobuf messages)))
  81     schema))
  82
  83
  84 (defun class-to-protobuf-message (class schema
  85                                   &key slot-filter type-filter enum-filter value-filter)
  86   "Given a CLOS class, return a Protobufs model object for it."
  87   (let* ((class (let ((c (find-class class)))
  88                   (unless (class-finalized-p c)
  89                     (finalize-inheritance c))           ;so the rest of the MOP will work
  90                   c))
  91          (slots (class-slots class)))
  92     (with-collectors ((enums  collect-enum)
  93                       (msgs   collect-msg)
  94                       (fields collect-field))
  95       (loop with index = 1
  96             for s in slots doing
  97         (multiple-value-bind (field msg enum)
  98             (slot-to-protobuf-field class s index slots
  99               :slot-filter slot-filter
 100               :type-filter type-filter
 101               :enum-filter enum-filter
 102               :value-filter value-filter)
 103           (when enum
 104             (collect-enum enum))
 105           (when msg
 106             (collect-msg msg))
 107           (when field
 108             (incf index 1)                              ;don't worry about the 19000-19999 restriction
 109             (collect-field field))))
 110       (let* ((cname (class-name class))
 111              (pname (class-name->proto cname))
 112              (message
 113               ;;--- Making the message this late means its children won't
 114               ;;--- have the right qualified names
 115               (make-instance 'protobuf-message
 116                 :class cname
 117                 :name  pname
 118                 :qualified-name (make-qualified-name *protobuf* pname)
 119                 :parent schema
 120                 :alias-for (and *alias-existing-classes* cname)
 121                 :enums    (delete-duplicates enums :key #'proto-name :test #'string=)
 122                 :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
 123                 :fields   fields))
 124              (*protobuf* message))
 125         ;; Give every child a proper parent
 126         (dolist (enum (proto-enums message))
 127           (setf (proto-parent enum) message))
 128         (dolist (msg (proto-messages message))
 129           (setf (proto-parent msg) message))
 130         (dolist (field (proto-fields message))
 131           (setf (proto-parent field) message))
 132         message))))
 133
 134 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
 135 (defun slot-to-protobuf-field (class slot index slots
 136                                &key slot-filter type-filter enum-filter value-filter)
 137   "Given a CLOS slot, return a Protobufs model object for it."
 138   (when (or (null slot-filter)
 139             (funcall slot-filter slot slots))
 140     (multiple-value-bind (expanded-type unexpanded-type)
 141        (find-slot-definition-type class slot)
 142       (multiple-value-bind (type pclass packed enums)
 143           (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
 144         (multiple-value-bind (reqd vectorp)
 145             (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter)
 146           (let* ((ename (and enums
 147                              (if (and unexpanded-type (symbolp unexpanded-type))
 148                                (symbol-name unexpanded-type)
 149                                (format nil "~A-~A" 'enum (slot-definition-name slot)))))
 150                  (etype (and enums
 151                              (if (and unexpanded-type (symbolp unexpanded-type))
 152                                unexpanded-type
 153                                (intern ename (symbol-package (slot-definition-name slot))))))
 154                  (enum  (and enums
 155                              (let* ((names (mapcar #'enum-name->proto enums))
 156                                     (prefix (and (> (length names) 1)
 157                                                  (subseq (first names)
 158                                                          0 (mismatch (first names) (car (last names)))))))
 159                                (when (and prefix (> (length prefix) 2)
 160                                           (every #'(lambda (name) (starts-with name prefix)) names))
 161                                  (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
 162                                (unless (and unexpanded-type (symbolp unexpanded-type))
 163                                  #+ignore         ;this happens constantly, the warning is not useful
 164                                  (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
 165                                                  expanded-type))
 166                                (let* ((pname (class-name->proto ename))
 167                                       (enum
 168                                        (make-instance 'protobuf-enum
 169                                          :class etype
 170                                          :name  pname
 171                                          :qualified-name (make-qualified-name *protobuf* pname)
 172                                          :parent *protobuf*))
 173                                       (values
 174                                        (loop for name in names
 175                                              for val in enums
 176                                              for index upfrom 0
 177                                              collect (make-instance 'protobuf-enum-value
 178                                                        :name name
 179                                                        :qualified-name (make-qualified-name enum name)
 180                                                        :index index
 181                                                        :value val
 182                                                        :parent enum))))
 183                                  (setf (proto-values enum) values)
 184                                  enum))))
 185                  (default (if (slot-definition-initfunction slot)
 186                             (clos-init-to-protobuf-default
 187                              (slot-definition-initform slot) expanded-type value-filter)
 188                             (if (eq reqd :repeated)
 189                               (if vectorp $empty-vector $empty-list)
 190                               $empty-default)))
 191                  (field   (make-instance 'protobuf-field
 192                             :name  (slot-name->proto (slot-definition-name slot))
 193                             :type  (if enum (class-name->proto ename) type)
 194                             :class (if enum etype pclass)
 195                             :required reqd
 196                             :index  index
 197                             :value  (slot-definition-name slot)
 198                             :reader (let ((reader (find-slot-definition-reader class slot)))
 199                                       ;; Only use the reader if it is "interesting"
 200                                       (unless (string= (symbol-name reader)
 201                                                        (format nil "~A-~A"
 202                                                                (class-name class) (slot-definition-name slot)))
 203                                         reader))
 204                             :default default
 205                             :packed  packed)))
 206             (values field nil enum)))))))
 207
 208 (defun list-of-list-of ()
 209   (let ((list-of-package (find-package 'list-of)))
 210     (and list-of-package (find-symbol (string 'list-of) list-of-package))))
 211
 212 (defun find-slot-definition-type (class slotd)
 213   "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
 214   (let* ((slot-name    (slot-definition-name slotd))
 215          (direct-slotd (some #'(lambda (c)
 216                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 217                              (class-precedence-list class))))
 218     (if direct-slotd
 219       ;; The direct slotd will have an unexpanded definition
 220       ;; Prefer it for 'list-of' so we can get the base type
 221       (let ((type (slot-definition-type direct-slotd)))
 222         (values (if (and (listp type)
 223                          (or (member (car type) '(list-of vector-of))
 224                              (let ((list-of-list-of (list-of-list-of)))
 225                                (and list-of-list-of (eq (car type) list-of-list-of)))))
 226                   type
 227                   (slot-definition-type slotd))
 228                 (if (symbolp type)
 229                   type
 230                   (when (and (listp type)
 231                              (eq (car type) 'or)
 232                              (member 'null (cdr type)))
 233                     (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
 234       (values (slot-definition-type slotd) nil))))
 235
 236 (defun find-slot-definition-reader (class slotd)
 237   "Given a class and a slot descriptor, find the name of a reader method for the slot."
 238   (let* ((slot-name    (slot-definition-name slotd))
 239          (direct-slotd (some #'(lambda (c)
 240                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 241                              (class-precedence-list class))))
 242     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 243
 244 (defun satisfies-list-of-p (type)
 245   (and (consp type)
 246        (eq (car type) 'satisfies)
 247        (consp (cdr type))
 248        (null (cddr type))
 249        (let ((function (cadr type)))
 250          (and (symbolp function)
 251               (string= "LIST-OF" (package-name (symbol-package function)))
 252               (let ((name (symbol-name function)))
 253                 (and (<= #.(length "LIST-OF-_-P") (length name))
 254                      (starts-with name "LIST-OF-")
 255                      (ends-with name "-P")
 256                      (let* ((typestring (subseq name #.(length "LIST-OF-") (- (length name) 2)))
 257                             (type (ignore-errors
 258                                     (with-standard-io-syntax
 259                                         (let ((*package* (find-package :cl)))
 260                                           (read-from-string typestring))))))
 261                          (and (typep type 'symbol) type))))))))
 262
 263 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 264   "Given a Lisp type, returns a Protobuf type, a class or primitive type,
 265    whether or not to pack the field, and (optionally) a set of enum values."
 266   (let* ((type (if type-filter (funcall type-filter type) type))
 267          (list-of-list-of (list-of-list-of))
 268          (type-enum (when (and *protobuf* (symbolp type))
 269                       (find-enum *protobuf* type)))
 270          (type-alias (when (and *protobuf* (symbolp type))
 271                        (find-type-alias *protobuf* type)))
 272          (expanded-type (type-expand type)))
 273     (cond
 274       ((listp type)
 275         (destructuring-bind (head &rest tail) type
 276           (case head
 277             ((or)
 278              (when (or (> (length tail) 2)
 279                        (not (member 'null tail)))
 280                (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
 281              (if (eq (first tail) 'null)
 282                (clos-type-to-protobuf-type (second tail))
 283                (clos-type-to-protobuf-type (first tail))))
 284             ((and)
 285              ;; Special knowledge of 'list-of:list-of', which uses (and list (satisfies list-of::FOO-p))
 286              (let ((satisfies-list-of
 287                     (and list-of-list-of (find-if #'satisfies-list-of-p tail))))
 288                (if satisfies-list-of
 289                  (multiple-value-bind (type class)
 290                      (lisp-type-to-protobuf-type satisfies-list-of)
 291                    (values type class (packed-type-p class)))
 292                  (let ((new-tail
 293                         (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 294                    (when (> (length new-tail) 1)
 295                      (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
 296                    (lisp-type-to-protobuf-type (first tail))))))
 297             ((member)                           ;maybe generate an enum type
 298              (if (or (equal type '(member t nil))
 299                      (equal type '(member nil t)))
 300                (values "bool" :bool)
 301                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 302                  (cond ((every #'(lambda (x)
 303                                    (or (null x) (characterp x) (stringp x))) values)
 304                         (values "string" :string))
 305                        ((every #'(lambda (x)
 306                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 307                         (values "uint32" :uint32))
 308                        ((every #'(lambda (x)
 309                                    (or (null x) (integerp x))) values)
 310                         (values "int32" :int32))
 311                        ((every #'(lambda (x) (symbolp x)) values)
 312                         (let ((values (remove-if #'null values)))
 313                           (values (class-name->proto (format nil "~A" type))
 314                                   type
 315                                   nil           ;don't pack enums
 316                                   (if enum-filter (funcall enum-filter values) values))))
 317                        (t
 318                         (error "The MEMBER type ~S is too complicated" type))))))
 319             ((list-of vector-of)
 320              (multiple-value-bind (type class)
 321                  (lisp-type-to-protobuf-type (first tail))
 322                (values type class (packed-type-p class))))
 323             ((integer)
 324              (let ((lo (or (first tail) '*))
 325                    (hi (or (second tail) '*)))
 326                (if (or (eq lo '*) (< lo 0))
 327                  (if (eq hi '*)
 328                    (values "int64" :int64)
 329                    (if (<= (integer-length hi) 32)
 330                      (values "int32" :int32)
 331                      (values "int64" :int64)))
 332                  (if (eq hi '*)
 333                    (values "uint64" :uint64)
 334                    (if (<= (integer-length hi) 32)
 335                      (values "uint32" :uint32)
 336                      (values "uint64" :uint64))))))
 337             ((signed-byte)
 338              (let ((len (first tail)))
 339                (if (<= len 32)
 340                  (values "int32" :int32)
 341                  (values "int64" :int64))))
 342             ((unsigned-byte)
 343              (let ((len (first tail)))
 344                (if (<= len 32)
 345                  (values "uint32" :uint32)
 346                  (values "uint64" :uint64))))
 347             ((float single-float double-float)
 348              (lisp-type-to-protobuf-type head))
 349             (otherwise
 350              (if (eq head list-of-list-of)
 351                (multiple-value-bind (type class)
 352                    (lisp-type-to-protobuf-type (first tail))
 353                  (values type class (packed-type-p class)))
 354                (lisp-type-to-protobuf-type type))))))
 355       (type-alias
 356        (values (proto-proto-type-str type-alias) type))
 357       ((not (or type-enum (equal type expanded-type)))
 358        (clos-type-to-protobuf-type expanded-type))
 359       (t
 360        (lisp-type-to-protobuf-type type)))))
 361
 362 (defun lisp-type-to-protobuf-type (type)
 363   (case type
 364     ((int32)    (values "int32" :int32))
 365     ((int64)    (values "int64" :int64))
 366     ((uint32)   (values "uint32" :uint32))
 367     ((uint64)   (values "uint64" :uint64))
 368     ((sint32)   (values "sint32" :sint32))
 369     ((sint64)   (values "sint64" :sint64))
 370     ((fixed32)  (values "fixed32" :fixed32))
 371     ((fixed64)  (values "fixed64" :fixed64))
 372     ((sfixed32) (values "sfixed32" :sfixed32))
 373     ((sfixed64) (values "sfixed64" :sfixed64))
 374     ((integer)  (values "int64" :int64))
 375     ((single-float float)
 376      (values "float" :float))
 377     ((double-float)
 378      (values "double" :double))
 379     ((boolean)
 380      (values "bool" :bool))
 381     ((symbol keyword)
 382      (values "string" :symbol))
 383     (otherwise
 384      (cond ((ignore-errors
 385              (or (eql type 'symbol)
 386                  (subtypep type '(or string character))))
 387             (values "string" :string))
 388            ((ignore-errors
 389              (subtypep type 'byte-vector))
 390             (values "bytes" :bytes))
 391            (t
 392             (values (class-name->proto type) type))))))
 393
 394 (defun packed-type-p (type)
 395   "Returns true if the given Protobufs type can use a packed field."
 396   (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 397                             :fixed32 :fixed64 :sfixed32 :sfixed64
 398                             :bool :float :double)))))
 399
 400 (defun clos-type-to-protobuf-required (type &optional type-filter)
 401   "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
 402    If the sceond returned value is true, it's a repeated field that should use a vector."
 403   (let ((type (if type-filter (funcall type-filter type) type))
 404         (list-of-list-of (list-of-list-of)))
 405     (if (listp type)
 406       (destructuring-bind (head &rest tail) type
 407         (case head
 408           ((or)
 409            (let ((optional (member 'null tail))
 410                  (repeated (find-if #'(lambda (r)
 411                                         (eq (clos-type-to-protobuf-required r) :repeated)) tail)))
 412              (if repeated
 413                (clos-type-to-protobuf-required repeated)
 414                (values (if optional :optional :required) nil))))
 415           ((and)
 416            (cond ((and (subtypep type 'list)
 417                        (not (subtypep type 'null)))
 418                   (values :repeated nil))
 419                  ((subtypep type '(vector-of t))
 420                   (values :repeated t))
 421                  (t
 422                   (values :required nil))))
 423           ((member)
 424            (if (or (equal type '(member t nil))
 425                    (equal type '(member nil t)))
 426              (values :required nil)
 427              (values (if (member nil tail) :optional :required) nil)))
 428           ((list-of)
 429            (values :repeated nil))
 430           ((vector-of)
 431            (values :repeated t))
 432           (otherwise
 433            (if (eq head list-of-list-of)
 434              (values :repeated nil)
 435              (values :required nil)))))
 436       (values :required nil))))
 437
 438 (defun clos-init-to-protobuf-default (value type &optional value-filter)
 439   "Given an initform and a Lisp type, returns a plausible default value.
 440    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 441   (let ((value (if value-filter (funcall value-filter value) value)))
 442     (and (constantp value)
 443          (ignore-errors (typep value type))
 444          (values value t))))
 445
 446 (defun protobuf-default-to-clos-init (default type)
 447   "Given a Protobufs type and default, return a CLOS initform value.
 448    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 449   (cond ((ignore-errors (typep default type))
 450          default)
 451         ((symbolp default)
 452          (cond ((eq type :bool)
 453                 (boolean-true-p default))
 454                ;; If we've got a symbol, it must be to initialize an enum type
 455                ;; whose values are represented by keywords in Lisp
 456                (t (kintern (symbol-name default)))))
 457         ((stringp default)
 458          (cond ((eq type :bool)
 459                 (boolean-true-p default))
 460                ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 461                                :fixed32 :sfixed32 :fixed64 :sfixed64))
 462                 (let ((default (read-from-string default)))
 463                   (and (integerp default) default)))
 464                ((member type '(:float :double))
 465                 (let ((default (read-from-string default)))
 466                   (and (floatp default) default)))
 467                (t default)))))
 468
 469 (defun boolean-true-p (x)
 470   "Returns t or nil given a value that might be a boolean."
 471   (etypecase x
 472     ((member t nil) x)
 473     (integer   (not (eql x 0)))
 474     (character (char-equal x #\t))
 475     (string    (or (string-equal x "true")
 476                    (string-equal x "yes")
 477                    (string-equal x "t")
 478                    (string-equal x "1")))
 479     (symbol    (string-equal (string x) "true"))))