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          (expanded-type (type-expand type)))
 271     (cond
 272       ((listp type)
 273         (destructuring-bind (head &rest tail) type
 274           (case head
 275             ((or)
 276              (when (or (> (length tail) 2)
 277                        (not (member 'null tail)))
 278                (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
 279              (if (eq (first tail) 'null)
 280                (clos-type-to-protobuf-type (second tail))
 281                (clos-type-to-protobuf-type (first tail))))
 282             ((and)
 283              ;; Special knowledge of 'list-of:list-of', which uses (and list (satisfies list-of::FOO-p))
 284              (let ((satisfies-list-of
 285                     (and list-of-list-of (find-if #'satisfies-list-of-p tail))))
 286                (if satisfies-list-of
 287                  (multiple-value-bind (type class)
 288                      (lisp-type-to-protobuf-type satisfies-list-of)
 289                    (values type class (packed-type-p class)))
 290                  (let ((new-tail
 291                         (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 292                    (when (> (length new-tail) 1)
 293                      (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
 294                    (lisp-type-to-protobuf-type (first tail))))))
 295             ((member)                           ;maybe generate an enum type
 296              (if (or (equal type '(member t nil))
 297                      (equal type '(member nil t)))
 298                (values "bool" :bool)
 299                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 300                  (cond ((every #'(lambda (x)
 301                                    (or (null x) (characterp x) (stringp x))) values)
 302                         (values "string" :string))
 303                        ((every #'(lambda (x)
 304                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 305                         (values "uint32" :uint32))
 306                        ((every #'(lambda (x)
 307                                    (or (null x) (integerp x))) values)
 308                         (values "int32" :int32))
 309                        ((every #'(lambda (x) (symbolp x)) values)
 310                         (let ((values (remove-if #'null values)))
 311                           (values (class-name->proto (format nil "~A" type))
 312                                   type
 313                                   nil           ;don't pack enums
 314                                   (if enum-filter (funcall enum-filter values) values))))
 315                        (t
 316                         (error "The MEMBER type ~S is too complicated" type))))))
 317             ((list-of vector-of)
 318              (multiple-value-bind (type class)
 319                  (lisp-type-to-protobuf-type (first tail))
 320                (values type class (packed-type-p class))))
 321             ((integer)
 322              (let ((lo (or (first tail) '*))
 323                    (hi (or (second tail) '*)))
 324                (if (or (eq lo '*) (< lo 0))
 325                  (if (eq hi '*)
 326                    (values "int64" :int64)
 327                    (if (<= (integer-length hi) 32)
 328                      (values "int32" :int32)
 329                      (values "int64" :int64)))
 330                  (if (eq hi '*)
 331                    (values "uint64" :uint64)
 332                    (if (<= (integer-length hi) 32)
 333                      (values "uint32" :uint32)
 334                      (values "uint64" :uint64))))))
 335             ((signed-byte)
 336              (let ((len (first tail)))
 337                (if (<= len 32)
 338                  (values "int32" :int32)
 339                  (values "int64" :int64))))
 340             ((unsigned-byte)
 341              (let ((len (first tail)))
 342                (if (<= len 32)
 343                  (values "uint32" :uint32)
 344                  (values "uint64" :uint64))))
 345             ((float single-float double-float)
 346              (lisp-type-to-protobuf-type head))
 347             (otherwise
 348              (if (eq head list-of-list-of)
 349                (multiple-value-bind (type class)
 350                    (lisp-type-to-protobuf-type (first tail))
 351                  (values type class (packed-type-p class)))
 352                (lisp-type-to-protobuf-type type))))))
 353       ((not (or type-enum (equal type expanded-type)))
 354        (clos-type-to-protobuf-type expanded-type))
 355       (t
 356        (lisp-type-to-protobuf-type type)))))
 357
 358 (defun lisp-type-to-protobuf-type (type)
 359   (case type
 360     ((int32)    (values "int32" :int32))
 361     ((int64)    (values "int64" :int64))
 362     ((uint32)   (values "uint32" :uint32))
 363     ((uint64)   (values "uint64" :uint64))
 364     ((sint32)   (values "sint32" :sint32))
 365     ((sint64)   (values "sint64" :sint64))
 366     ((fixed32)  (values "fixed32" :fixed32))
 367     ((fixed64)  (values "fixed64" :fixed64))
 368     ((sfixed32) (values "sfixed32" :sfixed32))
 369     ((sfixed64) (values "sfixed64" :sfixed64))
 370     ((integer)  (values "int64" :int64))
 371     ((single-float float)
 372      (values "float" :float))
 373     ((double-float)
 374      (values "double" :double))
 375     ((boolean)
 376      (values "bool" :bool))
 377     ((symbol keyword)
 378      (values "string" :symbol))
 379     (otherwise
 380      (cond ((ignore-errors
 381              (or (eql type 'symbol)
 382                  (subtypep type '(or string character))))
 383             (values "string" :string))
 384            ((ignore-errors
 385              (subtypep type 'byte-vector))
 386             (values "bytes" :bytes))
 387            (t
 388             (values (class-name->proto type) type))))))
 389
 390 (defun packed-type-p (type)
 391   "Returns true if the given Protobufs type can use a packed field."
 392   (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 393                             :fixed32 :fixed64 :sfixed32 :sfixed64
 394                             :bool :float :double)))))
 395
 396 (defun clos-type-to-protobuf-required (type &optional type-filter)
 397   "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
 398    If the sceond returned value is true, it's a repeated field that should use a vector."
 399   (let ((type (if type-filter (funcall type-filter type) type))
 400         (list-of-list-of (list-of-list-of)))
 401     (if (listp type)
 402       (destructuring-bind (head &rest tail) type
 403         (case head
 404           ((or)
 405            (let ((optional (member 'null tail))
 406                  (repeated (find-if #'(lambda (r)
 407                                         (eq (clos-type-to-protobuf-required r) :repeated)) tail)))
 408              (if repeated
 409                (clos-type-to-protobuf-required repeated)
 410                (values (if optional :optional :required) nil))))
 411           ((and)
 412            (cond ((and (subtypep type 'list)
 413                        (not (subtypep type 'null)))
 414                   (values :repeated nil))
 415                  ((subtypep type '(vector-of t))
 416                   (values :repeated t))
 417                  (t
 418                   (values :required nil))))
 419           ((member)
 420            (if (or (equal type '(member t nil))
 421                    (equal type '(member nil t)))
 422              (values :required nil)
 423              (values (if (member nil tail) :optional :required) nil)))
 424           ((list-of)
 425            (values :repeated nil))
 426           ((vector-of)
 427            (values :repeated t))
 428           (otherwise
 429            (if (eq head list-of-list-of)
 430              (values :repeated nil)
 431              (values :required nil)))))
 432       (values :required nil))))
 433
 434 (defun clos-init-to-protobuf-default (value type &optional value-filter)
 435   "Given an initform and a Lisp type, returns a plausible default value.
 436    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 437   (let ((value (if value-filter (funcall value-filter value) value)))
 438     (and (constantp value)
 439          (ignore-errors (typep value type))
 440          (values value t))))
 441
 442 (defun protobuf-default-to-clos-init (default type)
 443   "Given a Protobufs type and default, return a CLOS initform value.
 444    Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
 445   (cond ((ignore-errors (typep default type))
 446          default)
 447         ((symbolp default)
 448          (cond ((eq type :bool)
 449                 (boolean-true-p default))
 450                ;; If we've got a symbol, it must be to initialize an enum type
 451                ;; whose values are represented by keywords in Lisp
 452                (t (kintern (symbol-name default)))))
 453         ((stringp default)
 454          (cond ((eq type :bool)
 455                 (boolean-true-p default))
 456                ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 457                                :fixed32 :sfixed32 :fixed64 :sfixed64))
 458                 (let ((default (read-from-string default)))
 459                   (and (integerp default) default)))
 460                ((member type '(:float :double))
 461                 (let ((default (read-from-string default)))
 462                   (and (floatp default) default)))
 463                (t default)))))
 464
 465 (defun boolean-true-p (x)
 466   "Returns t or nil given a value that might be a boolean."
 467   (etypecase x
 468     ((member t nil) x)
 469     (integer   (not (eql x 0)))
 470     (character (char-equal x #\t))
 471     (string    (or (string-equal x "true")
 472                    (string-equal x "yes")
 473                    (string-equal x "t")
 474                    (string-equal x "1")))
 475     (symbol    (string-equal (string x) "true"))))