Skip to content
clos-transform.lisp 23.6 KiB
Newer Older
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;; Free Software published under an MIT-like license. See LICENSE   ;;;
;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
;;;                                                                  ;;;
;;; Original author: Scott McKay                                     ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "PROTO-IMPL")


;;; Protocol buffer generation from ordinary CLOS classes

;; Controls whether or not to use ':alias-for' for the Protobuf generated
;; for an existing Lisp class
;; The default is presently true because, at least initially, we'll be using
;; the generated Protobufs code in the Lisp world that includes that classes
;; from which the code was generated
(defvar *alias-existing-classes* t)

;; Doing this can't really work perfectly, there's not enough information
;;  - How do we decide if there's an ownership hierarchy that should produce embedded messages?
;;  - How do we decide if there are volatile slots that should not be included in the message?
(defun write-schema-for-classes (classes
                                 &key (stream *standard-output*) (type :proto)
                                      name package lisp-package install
                                      slot-filter type-filter enum-filter value-filter
                                      (alias-existing-classes *alias-existing-classes*))
  "Given a set of CLOS classes, generates a Protobufs schema for the classes
   and pretty prints the schema to the stream.
   The return value is the schema."
  (let ((schema (generate-schema-for-classes classes
                  :name name
                  :package package
                  :lisp-package (or lisp-package package)
                  :install install
                  :slot-filter slot-filter
                  :type-filter type-filter
                  :enum-filter enum-filter
                  :value-filter value-filter
                  :alias-existing-classes alias-existing-classes)))
    (write-schema schema :stream stream :type type)
(defun generate-schema-for-classes (classes
                                    &key name package lisp-package install
                                         slot-filter type-filter enum-filter value-filter
                                         (alias-existing-classes *alias-existing-classes*))
  "Given a set of CLOS classes, generates a Protobufs schema for the classes.
   The return value is the schema."
  (let* ((*alias-existing-classes* alias-existing-classes)
         (package  (and package (if (stringp package) package (string-downcase (string package)))))
         (lisp-pkg (string (or lisp-package package)))
         (schema   (make-instance 'protobuf-schema
                     :package package
                     :lisp-package lisp-pkg
         (*protobuf* schema)
         (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
                               (class-to-protobuf-message c schema
                                :slot-filter slot-filter
                                :type-filter type-filter
                                :enum-filter enum-filter
                                :value-filter value-filter))
                           classes)))
    (setf (proto-messages schema) messages)
    (when install
      (record-protobuf schema)
      (with-collectors ((messages collect-message))
        (labels ((collect-messages (message)
                   (collect-message message)
                   (map () #'collect-messages (proto-messages message))))
          (map () #'collect-messages (proto-messages schema)))
        (map () #'record-protobuf messages)))
    schema))
(defun class-to-protobuf-message (class schema
                                  &key slot-filter type-filter enum-filter value-filter)
  "Given a CLOS class, return a Protobufs model object for it."
  (let* ((class (let ((c (find-class class)))
                  (unless (class-finalized-p c)
                    (finalize-inheritance c))           ;so the rest of the MOP will work
                  c))
         (slots (class-slots class)))
    (with-collectors ((enums  collect-enum)
                      (fields collect-field))
      (loop with index = 1
            for s in slots doing
        (multiple-value-bind (field msg enum)
            (slot-to-protobuf-field class s index slots
              :slot-filter slot-filter
              :type-filter type-filter
              :enum-filter enum-filter
              :value-filter value-filter)
          (when enum
            (collect-enum enum))
          (when msg
            (collect-msg msg))
          (when field
            (incf index 1)                              ;don't worry about the 19000-19999 restriction
            (collect-field field))))
      (let* ((cname (class-name class))
             (pname (class-name->proto cname))
             (message
              ;;--- Making the message this late means its children won't
              ;;--- have the right qualified names
              (make-instance 'protobuf-message
                :class cname
                :name  pname
                :qualified-name (make-qualified-name *protobuf* pname)
                :parent schema
                :alias-for (and *alias-existing-classes* cname)
                :enums    (delete-duplicates enums :key #'proto-name :test #'string=)
                :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
                :fields   fields))
             (*protobuf* message))
        ;; Give every child a proper parent
        (dolist (enum (proto-enums message))
          (setf (proto-parent enum) message))
        (dolist (msg (proto-messages message))
          (setf (proto-parent msg) message))
        (dolist (field (proto-fields message))
          (setf (proto-parent field) message))
        message))))

;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
(defun slot-to-protobuf-field (class slot index slots
                               &key slot-filter type-filter enum-filter value-filter)
  "Given a CLOS slot, return a Protobufs model object for it."
  (when (or (null slot-filter)
            (funcall slot-filter slot slots))
    (multiple-value-bind (expanded-type unexpanded-type)
       (find-slot-definition-type class slot)
      (multiple-value-bind (type pclass packed enums)
          (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
        (multiple-value-bind (reqd vectorp)
            (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter)
          (let* ((ename (and enums
                             (if (and unexpanded-type (symbolp unexpanded-type))
                               (symbol-name unexpanded-type)
                               (format nil "~A-~A" 'enum (slot-definition-name slot)))))
                 (etype (and enums
                             (if (and unexpanded-type (symbolp unexpanded-type))
                               unexpanded-type
                               (intern ename (symbol-package (slot-definition-name slot))))))
                 (enum  (and enums
                             (let* ((names (mapcar #'enum-name->proto enums))
                                    (prefix (and (> (length names) 1)
                                                 (subseq (first names)
                                                         0 (mismatch (first names) (car (last names)))))))
                               (when (and prefix (> (length prefix) 2)
                                          (every #'(lambda (name) (starts-with name prefix)) names))
                                 (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
                               (unless (and unexpanded-type (symbolp unexpanded-type))
                                 #+ignore         ;this happens constantly, the warning is not useful
                                 (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
                                                 expanded-type))
                               (let* ((pname (class-name->proto ename))
                                      (enum
                                       (make-instance 'protobuf-enum
                                         :class etype
                                         :name  pname
                                         :qualified-name (make-qualified-name *protobuf* pname)
                                         :parent *protobuf*))
                                      (values
                                       (loop for name in names
                                             for val in enums
                                             for index upfrom 0
                                             collect (make-instance 'protobuf-enum-value
                                                       :name name
                                                       :qualified-name (make-qualified-name enum name)
                                                       :index index
                                                       :value val
                                                       :parent enum))))
                                 (setf (proto-values enum) values)
                                 enum))))
                 (default (if (slot-definition-initfunction slot)
                            (clos-init-to-protobuf-default
                             (slot-definition-initform slot) expanded-type value-filter)
                            (if (eq reqd :repeated)
                              (if vectorp $empty-vector $empty-list)
                              $empty-default)))
                 (field   (make-instance 'protobuf-field
                            :name  (slot-name->proto (slot-definition-name slot))
                            :type  (if enum (class-name->proto ename) type)
                            :class (if enum etype pclass)
                            :required reqd
                            :index  index
                            :value  (slot-definition-name slot)
                            :reader (let ((reader (find-slot-definition-reader class slot)))
                                      ;; Only use the reader if it is "interesting"
                                      (unless (string= (symbol-name reader)
                                                       (format nil "~A-~A" 
                                                               (class-name class) (slot-definition-name slot)))
                                        reader))
                            :default default
                            :packed  packed)))
            (values field nil enum)))))))
(defun list-of-list-of ()
  (let ((list-of-package (find-package 'list-of)))
    (and list-of-package (find-symbol (string 'list-of) list-of-package))))

(defun find-slot-definition-type (class slotd)
  "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
  (let* ((slot-name    (slot-definition-name slotd))
         (direct-slotd (some #'(lambda (c)
                                 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
                             (class-precedence-list class))))
Scott McKay's avatar
Scott McKay committed
      ;; The direct slotd will have an unexpanded definition
      ;; Prefer it for 'list-of' so we can get the base type
      (let ((type (slot-definition-type direct-slotd)))
        (values (if (and (listp type)
                         (or (member (car type) '(list-of vector-of))
                             (let ((list-of-list-of (list-of-list-of)))
                               (and list-of-list-of (eq (car type) list-of-list-of)))))
                  type
                  (slot-definition-type slotd))
                (if (symbolp type)
                  type
                  (when (and (listp type)
                             (eq (car type) 'or)
                             (member 'null (cdr type)))
                    (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
      (values (slot-definition-type slotd) nil))))

(defun find-slot-definition-reader (class slotd)
  "Given a class and a slot descriptor, find the name of a reader method for the slot."
  (let* ((slot-name    (slot-definition-name slotd))
         (direct-slotd (some #'(lambda (c)
                                 (find slot-name (class-direct-slots c) :key #'slot-definition-name))
                             (class-precedence-list class))))
    (and direct-slotd (first (slot-definition-readers direct-slotd)))))
(defun satisfies-list-of-p (type)
  (and (consp type)
       (eq (car type) 'satisfies)
       (consp (cdr type))
       (null (cddr type))
       (let ((function (cadr type)))
         (and (symbolp function)
              (string= "LIST-OF" (package-name (symbol-package function)))
              (let ((name (symbol-name function)))
                (and (<= #.(length "LIST-OF-_-P") (length name))
                     (starts-with name "LIST-OF-")
                     (ends-with name "-P")
                     (let* ((typestring (subseq name #.(length "LIST-OF-") (- (length name) 2)))
                            (type (ignore-errors
                                    (with-standard-io-syntax
                                        (let ((*package* (find-package :cl)))
                                          (read-from-string typestring))))))
                         (and (typep type 'symbol) type))))))))

(defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
  "Given a Lisp type, returns a Protobuf type, a class or primitive type,
   whether or not to pack the field, and (optionally) a set of enum values."
  (let* ((type (if type-filter (funcall type-filter type) type))
         (list-of-list-of (list-of-list-of))
         (type-enum (when (and *protobuf* (symbolp type))
                      (find-enum *protobuf* type)))
         (type-alias (when (and *protobuf* (symbolp type))
                       (find-type-alias *protobuf* type)))
         (expanded-type (type-expand type)))
    (cond
      ((listp type)
        (destructuring-bind (head &rest tail) type
          (case head
            ((or)
             (when (or (> (length tail) 2)
                       (not (member 'null tail)))
               (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
             (if (eq (first tail) 'null)
               (clos-type-to-protobuf-type (second tail))
               (clos-type-to-protobuf-type (first tail))))
            ((and)
             ;; Special knowledge of 'list-of:list-of', which uses (and list (satisfies list-of::FOO-p))
             (let ((satisfies-list-of
                    (and list-of-list-of (find-if #'satisfies-list-of-p tail))))
               (if satisfies-list-of
                 (multiple-value-bind (type class)
                     (lisp-type-to-protobuf-type satisfies-list-of)
                   (values type class (packed-type-p class)))
                 (let ((new-tail
                        (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
                   (when (> (length new-tail) 1)
                     (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
                   (lisp-type-to-protobuf-type (first tail))))))
            ((member)                           ;maybe generate an enum type
             (if (or (equal type '(member t nil))
                     (equal type '(member nil t)))
               (values "bool" :bool)
               (let ((values (if enum-filter (funcall enum-filter tail) tail)))
                 (cond ((every #'(lambda (x)
                                   (or (null x) (characterp x) (stringp x))) values)
                        (values "string" :string))
                       ((every #'(lambda (x)
                                   (or (null x) (and (integerp x) (>= x 0)))) values)
                        (values "uint32" :uint32))
                       ((every #'(lambda (x)
                                   (or (null x) (integerp x))) values)
                        (values "int32" :int32))
                       ((every #'(lambda (x) (symbolp x)) values)
                        (let ((values (remove-if #'null values)))
                          (values (class-name->proto (format nil "~A" type))
                                  (if enum-filter (funcall enum-filter values) values))))
                       (t
                        (error "The MEMBER type ~S is too complicated" type))))))
             (multiple-value-bind (type class)
                 (lisp-type-to-protobuf-type (first tail))
               (values type class (packed-type-p class))))
            ((integer)
             (let ((lo (or (first tail) '*))
                   (hi (or (second tail) '*)))
               (if (or (eq lo '*) (< lo 0))
                 (if (eq hi '*)
                   (values "int64" :int64)
                   (if (<= (integer-length hi) 32)
                     (values "int32" :int32)
                     (values "int64" :int64)))
                 (if (eq hi '*)
                   (values "uint64" :uint64)
                   (if (<= (integer-length hi) 32)
                     (values "uint32" :uint32)
                     (values "uint64" :uint64))))))
            ((signed-byte)
             (let ((len (first tail)))
               (if (<= len 32)
                 (values "int32" :int32)
                 (values "int64" :int64))))
            ((unsigned-byte)
             (let ((len (first tail)))
               (if (<= len 32)
                 (values "uint32" :uint32)
                 (values "uint64" :uint64))))
            ((float single-float double-float)
             (lisp-type-to-protobuf-type head))
             (if (eq head list-of-list-of)
               (multiple-value-bind (type class)
                   (lisp-type-to-protobuf-type (first tail))
                 (values type class (packed-type-p class)))
               (lisp-type-to-protobuf-type type))))))
      (type-alias
       (values (proto-proto-type-str type-alias) type))
      ((not (or type-enum (equal type expanded-type)))
       (clos-type-to-protobuf-type expanded-type))
      (t
       (lisp-type-to-protobuf-type type)))))

(defun lisp-type-to-protobuf-type (type)
  (case type
    ((int32)    (values "int32" :int32))
    ((int64)    (values "int64" :int64))
    ((uint32)   (values "uint32" :uint32))
    ((uint64)   (values "uint64" :uint64))
    ((sint32)   (values "sint32" :sint32))
    ((sint64)   (values "sint64" :sint64))
    ((fixed32)  (values "fixed32" :fixed32))
    ((fixed64)  (values "fixed64" :fixed64))
    ((sfixed32) (values "sfixed32" :sfixed32))
    ((sfixed64) (values "sfixed64" :sfixed64))
    ((integer)  (values "int64" :int64))
    ((single-float float)
     (values "float" :float))
    ((double-float)
     (values "double" :double))
    ((boolean)
     (values "bool" :bool))
    ((symbol keyword)
     (values "string" :symbol))
    (otherwise
     (cond ((ignore-errors
             (or (eql type 'symbol)
                 (subtypep type '(or string character))))
            (values "string" :string))
           ((ignore-errors
             (subtypep type 'byte-vector))
            (values "bytes" :bytes))
           (t
            (values (class-name->proto type) type))))))
(defun packed-type-p (type)
  "Returns true if the given Protobufs type can use a packed field."
  (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
                            :fixed32 :fixed64 :sfixed32 :sfixed64

(defun clos-type-to-protobuf-required (type &optional type-filter)
  "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
   If the sceond returned value is true, it's a repeated field that should use a vector."
  (let ((type (if type-filter (funcall type-filter type) type))
        (list-of-list-of (list-of-list-of)))
    (if (listp type)
      (destructuring-bind (head &rest tail) type
        (case head
          ((or)
           (let ((optional (member 'null tail))
                 (repeated (find-if #'(lambda (r)
                                        (eq (clos-type-to-protobuf-required r) :repeated)) tail)))
             (if repeated
               (clos-type-to-protobuf-required repeated)
               (values (if optional :optional :required) nil))))
           (cond ((and (subtypep type 'list)
                       (not (subtypep type 'null)))
                  (values :repeated nil))
                 ((subtypep type '(vector-of t))
                  (values :repeated t))
                 (t
                  (values :required nil))))
          ((member)
           (if (or (equal type '(member t nil))
                   (equal type '(member nil t)))
             (values :required nil)
             (values (if (member nil tail) :optional :required) nil)))
           (values :repeated nil))
          ((vector-of)
           (values :repeated t))
           (if (eq head list-of-list-of)
             (values :repeated nil)
             (values :required nil)))))
(defun clos-init-to-protobuf-default (value type &optional value-filter)
  "Given an initform and a Lisp type, returns a plausible default value.
   Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
  (let ((value (if value-filter (funcall value-filter value) value)))
    (and (constantp value)
         (ignore-errors (typep value type))

(defun protobuf-default-to-clos-init (default type)
  "Given a Protobufs type and default, return a CLOS initform value.
   Don't call this if the default is empty, because that will confuse 'nil' with 'unbound'."
  (cond ((ignore-errors (typep default type))
         default)
        ((symbolp default)
         (cond ((eq type :bool)
                (boolean-true-p default))
               ;; If we've got a symbol, it must be to initialize an enum type
               ;; whose values are represented by keywords in Lisp
               (t (kintern (symbol-name default)))))
        ((stringp default)
         (cond ((eq type :bool)
                (boolean-true-p default))
               ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
                               :fixed32 :sfixed32 :fixed64 :sfixed64))
                (let ((default (read-from-string default)))
                  (and (integerp default) default)))
               ((member type '(:float :double))
                (let ((default (read-from-string default)))
                  (and (floatp default) default)))
               (t default)))))
(defun boolean-true-p (x)
  "Returns t or nil given a value that might be a boolean."
  (etypecase x
    ((member t nil) x)
    (integer   (not (eql x 0)))
    (character (char-equal x #\t))
    (string    (or (string-equal x "true")
                   (string-equal x "yes")
                   (string-equal x "t")
                   (string-equal x "1")))
    (symbol    (string-equal (string x) "true"))))