clos-transform.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protocol buffer generation from ordinary CLOS classes
  15
  16 ;; 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 (find-class class))
  86          (slots (class-slots class)))
  87     (with-collectors ((enums  collect-enum)
  88                       (msgs   collect-msg)
  89                       (fields collect-field))
  90       (loop with index = 1
  91             for s in slots doing
  92         (multiple-value-bind (field msg enum)
  93             (slot-to-protobuf-field class s index slots
  94               :slot-filter slot-filter
  95               :type-filter type-filter
  96               :enum-filter enum-filter
  97               :value-filter value-filter)
  98           (when enum
  99             (collect-enum enum))
 100           (when msg
 101             (collect-msg msg))
 102           (when field
 103             (incf index 1)                              ;don't worry about the 19000-19999 restriction
 104             (collect-field field))))
 105       (make-instance 'protobuf-message
 106         :class (class-name class)
 107         :name  (class-name->proto (class-name class))
 108         :parent schema
 109         :alias-for (and *alias-existing-classes* (class-name class))
 110         :enums    (delete-duplicates enums :key #'proto-name :test #'string=)
 111         :messages (delete-duplicates msgs :key #'proto-name :test #'string=)
 112         :fields   fields))))
 113
 114 ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum
 115 (defun slot-to-protobuf-field (class slot index slots
 116                                &key slot-filter type-filter enum-filter value-filter)
 117   "Given a CLOS slot, return a Protobufs model object for it."
 118   (when (or (null slot-filter)
 119             (funcall slot-filter slot slots))
 120     (multiple-value-bind (expanded-type unexpanded-type)
 121        (find-slot-definition-type class slot)
 122       (multiple-value-bind (type pclass packed enums)
 123           (clos-type-to-protobuf-type expanded-type type-filter enum-filter)
 124         (let* ((ename (and enums
 125                            (if (and unexpanded-type (symbolp unexpanded-type))
 126                              (symbol-name unexpanded-type)
 127                              (format nil "~A-~A" 'enum (slot-definition-name slot)))))
 128                (etype (and enums
 129                            (if (and unexpanded-type (symbolp unexpanded-type))
 130                              unexpanded-type
 131                              (intern ename (symbol-package (slot-definition-name slot))))))
 132                (enum  (and enums
 133                            (let* ((names (mapcar #'enum-name->proto enums))
 134                                   (prefix (and (> (length names) 1)
 135                                                (subseq (first names)
 136                                                        0 (mismatch (first names) (car (last names)))))))
 137                              (when (and prefix (> (length prefix) 2)
 138                                         (every #'(lambda (name) (starts-with name prefix)) names))
 139                                (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
 140                              (unless (and unexpanded-type (symbolp unexpanded-type))
 141                                (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
 142                                                expanded-type))
 143                              (make-instance 'protobuf-enum
 144                                :class  etype
 145                                :name   (class-name->proto ename)
 146                                :values (loop for name in names
 147                                              for val in enums
 148                                              for index upfrom 0
 149                                              collect (make-instance 'protobuf-enum-value
 150                                                        :name name
 151                                                        :index index
 152                                                        :value val))))))
 153                (reqd  (clos-type-to-protobuf-required (find-slot-definition-type class slot) type-filter))
 154                (field (make-instance 'protobuf-field
 155                         :name  (slot-name->proto (slot-definition-name slot))
 156                         :type  (if enum (class-name->proto ename) type)
 157                         :class (if enum etype pclass)
 158                         :required reqd
 159                         :index index
 160                         :value   (slot-definition-name slot)
 161                         :reader  (let ((reader (find-slot-definition-reader class slot)))
 162                                    ;; Only use the reader if it is "interesting"
 163                                    (unless (string= (symbol-name reader)
 164                                                     (format nil "~A-~A"
 165                                                             (class-name class) (slot-definition-name slot)))
 166                                      reader))
 167                         :default (clos-init-to-protobuf-default
 168                                    (slot-definition-initform slot) expanded-type value-filter)
 169                         :packed  packed)))
 170           (values field nil enum))))))
 171
 172 (defun find-slot-definition-type (class slotd)
 173   "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
 174   (let* ((slot-name    (slot-definition-name slotd))
 175          (direct-slotd (some #'(lambda (c)
 176                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 177                              (class-precedence-list class))))
 178     (if direct-slotd
 179       ;; The direct slotd will have an unexpanded definition
 180       ;; Prefer it for 'list-of' so we can get the base type
 181       (let ((type (slot-definition-type direct-slotd)))
 182         (values (if (and (listp type) (member (car type) '(list-of #+quux quux:list-of)))
 183                   type
 184                   (slot-definition-type slotd))
 185                 (if (symbolp type)
 186                   type
 187                   (when (and (listp type)
 188                              (eq (car type) 'or)
 189                              (member 'null (cdr type)))
 190                     (find-if-not #'(lambda (s) (eq s 'null)) (cdr type))))))
 191       (values (slot-definition-type slotd) nil))))
 192
 193 (defun find-slot-definition-reader (class slotd)
 194   "Given a class and a slot descriptor, find the name of a reader method for the slot."
 195   (let* ((slot-name    (slot-definition-name slotd))
 196          (direct-slotd (some #'(lambda (c)
 197                                  (find slot-name (class-direct-slots c) :key #'slot-definition-name))
 198                              (class-precedence-list class))))
 199     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 200
 201 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
 202   "Given a Lisp type, returns a Protobuf type, a class or primitive type,
 203    whether or not to pack the field, and (optionally) a set of enum values."
 204   (let ((type (if type-filter (funcall type-filter type) type)))
 205     (flet ((type->protobuf-type (type)
 206              (case type
 207                ((int32)    (values "int32" :int32))
 208                ((int64)    (values "int64" :int64))
 209                ((uint32)   (values "uint32" :uint32))
 210                ((uint64)   (values "uint64" :uint64))
 211                ((sint32)   (values "sint32" :sint32))
 212                ((sint64)   (values "sint64" :sint64))
 213                ((fixed32)  (values "fixed32" :fixed32))
 214                ((fixed64)  (values "fixed64" :fixed64))
 215                ((sfixed32) (values "sfixed32" :sfixed32))
 216                ((sfixed64) (values "sfixed64" :sfixed64))
 217                ((integer)  (values "int64" :int64))
 218                ((single-float float)
 219                 (values "float" :float))
 220                ((double-float)
 221                 (values "double" :double))
 222                ((boolean)
 223                 (values "bool" :bool))
 224                ((symbol keyword)
 225                 (values "string" :symbol))
 226                (otherwise
 227                 (cond ((ignore-errors
 228                         (subtypep type '(or string character symbol)))
 229                        (values "string" :string))
 230                       ((ignore-errors
 231                         (subtypep type 'byte-vector))
 232                        (values "bytes" :bytes))
 233                       (t
 234                        (values (class-name->proto type) type)))))))
 235       (if (listp type)
 236         (destructuring-bind (head &rest tail) type
 237           (case head
 238             ((or)
 239              (when (or (> (length tail) 2)
 240                        (not (member 'null tail)))
 241                (protobufs-warn "The OR type ~S is too complicated" type))
 242              (if (eq (first tail) 'null)
 243                (clos-type-to-protobuf-type (second tail))
 244                (clos-type-to-protobuf-type (first tail))))
 245             ((and)
 246              (cond #+quux
 247                    ((ignore-errors
 248                       (subtypep type '(quux:list-of t)))
 249                     ;; Special knowledge of Quux 'list-of', which uses (and list (satisfies <t>))
 250                     (let* ((satisfies (find 'satisfies tail :key #'car))
 251                            (pred (second satisfies))
 252                            (type (if (starts-with (string pred) "LIST-OF-")
 253                                    (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
 254                                    pred)))
 255                       (multiple-value-bind (type class)
 256                           (type->protobuf-type type)
 257                         (values type class (packed-type-p class)))))
 258                    (t
 259                     (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
 260                       (when (> (length new-tail) 1)
 261                         (protobufs-warn "The AND type ~S is too complicated" type))
 262                       (type->protobuf-type (first tail))))))
 263             ((member)                           ;maybe generate an enum type
 264              (if (or (equal type '(member t nil))
 265                      (equal type '(member nil t)))
 266                (values "bool" :bool)
 267                (let ((values (if enum-filter (funcall enum-filter tail) tail)))
 268                  (cond ((every #'(lambda (x)
 269                                    (or (null x) (characterp x) (stringp x))) values)
 270                         (values "string" :string))
 271                        ((every #'(lambda (x)
 272                                    (or (null x) (and (integerp x) (>= x 0)))) values)
 273                         (values "uint32" :uint32))
 274                        ((every #'(lambda (x)
 275                                    (or (null x) (integerp x))) values)
 276                         (values "int32" :int32))
 277                        ((every #'(lambda (x) (symbolp x)) values)
 278                         (let ((values (remove-if #'null values)))
 279                           (values (class-name->proto (format nil "~A" type))
 280                                   type
 281                                   nil           ;don't pack enums
 282                                   (if enum-filter (funcall enum-filter values) values))))
 283                        (t
 284                         (error "The MEMBER type ~S is too complicated" type))))))
 285             ((list-of #+quux quux:list-of)      ;special knowledge of 'list-of'
 286              (multiple-value-bind (type class)
 287                  (type->protobuf-type (first tail))
 288                (values type class (packed-type-p class))))
 289             ((integer)
 290              (let ((lo (or (first tail) '*))
 291                    (hi (or (second tail) '*)))
 292                (if (or (eq lo '*) (< lo 0))
 293                  (if (eq hi '*)
 294                    (values "int64" :int64)
 295                    (if (<= (integer-length hi) 32)
 296                      (values "int32" :int32)
 297                      (values "int64" :int64)))
 298                  (if (eq hi '*)
 299                    (values "uint64" :uint64)
 300                    (if (<= (integer-length hi) 32)
 301                      (values "uint32" :uint32)
 302                      (values "uint64" :uint64))))))
 303             ((signed-byte)
 304              (let ((len (first tail)))
 305                (if (<= len 32)
 306                  (values "int32" :int32)
 307                  (values "int64" :int64))))
 308             ((unsigned-byte)
 309              (let ((len (first tail)))
 310                (if (<= len 32)
 311                  (values "uint32" :uint32)
 312                  (values "uint64" :uint64))))
 313             ((float single-float double-float)
 314              (type->protobuf-type head))
 315             (otherwise
 316              (type->protobuf-type type))))
 317         (type->protobuf-type type)))))
 318
 319 (defun packed-type-p (type)
 320   "Returns true if the given Protobufs type can use a packed field."
 321   (not (null (member type '(:int32 :int64 :uint32 :uint64 :sint32 :sint64
 322                             :fixed32 :fixed64 :sfixed32 :sfixed64
 323                             :bool :float :double)))))
 324
 325 (defun clos-type-to-protobuf-required (type &optional type-filter)
 326   "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated."
 327   (let ((type (if type-filter (funcall type-filter type) type)))
 328     (if (listp type)
 329       (destructuring-bind (head &rest tail) type
 330         (case head
 331           ((or)
 332            (let ((optional (member 'null (cdr type))))
 333              (if (loop for r in tail
 334                        thereis (eq (clos-type-to-protobuf-required r) :repeated))
 335                :repeated
 336                (if optional :optional :required))))
 337           ((and)
 338            (if (or (subtypep type '(list-of t))
 339                    #+quux (subtypep type '(quux:list-of t)))
 340              :repeated
 341              :required))
 342           ((member)
 343            (if (or (equal type '(member t nil))
 344                    (equal type '(member nil t)))
 345              :required
 346              (if (member nil tail) :optional :required)))
 347           ((list-of #+quux quux:list-of)
 348            :repeated)
 349           (otherwise
 350            :required)))
 351       :required)))
 352
 353 (defun clos-init-to-protobuf-default (value type &optional value-filter)
 354   "Given an initform and a Lisp type, returns a plausible default value."
 355   (let ((value (if value-filter (funcall value-filter value) value)))
 356     (and (constantp value)
 357          (ignore-errors (typep value type))
 358          value)))
 359
 360 (defun protobuf-default-to-clos-init (default type)
 361   "Given a Protobufs type and default, return a CLOS initform value."
 362   (cond ((ignore-errors (typep default type))
 363          default)
 364         ((symbolp default)
 365          (cond ((eq type :bool)
 366                 (boolean-true-p default))))
 367         ((stringp default)
 368          (cond ((eq type :bool)
 369                 (boolean-true-p default))
 370                ((member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 371                                :fixed32 :sfixed32 :fixed64 :sfixed64))
 372                 (let ((default (read-from-string default)))
 373                   (and (integerp default) default)))
 374                ((member type '(:float :double))
 375                 (let ((default (read-from-string default)))
 376                   (and (floatp default) default)))
 377                (t default)))))
 378
 379 (defun boolean-true-p (x)
 380   "Returns t or nil given a value that might be a boolean."
 381   (etypecase x
 382     ((member t nil) x)
 383     (integer   (not (eql x 0)))
 384     (character (char-equal x #\t))
 385     (string    (or (string-equal x "true")
 386                    (string-equal x "yes")
 387                    (string-equal x "t")
 388                    (string-equal x "1")))
 389     (symbol    (string-equal (string x) "true"))))