src/schema-type.lisp

   1 (uiop:define-package #:lw2.schema-type
   2   (:use #:cl #:lw2.utils)
   3   (:export #:define-schema-type #:undefine-schema-type #:find-schema-type #:schema-bind))
   4
   5 (in-package #:lw2.schema-type)
   6
   7 (defvar *schema-types* nil)
   8
   9 (defun delete-schema-type (name)
  10   (setf *schema-types* (delete name *schema-types* :key #'car)))
  11
  12 (defmacro undefine-schema-type (name)
  13   `(eval-when (:compile-toplevel :load-toplevel :execute)
  14      (delete-schema-type ,name)))
  15
  16 (defmacro define-schema-type (name options fields)
  17   (declare (ignore options))
  18   `(eval-when (:compile-toplevel :load-toplevel :execute)
  19      (delete-schema-type ,name)
  20      (setf *schema-types*
  21            (acons ,name (alist :fields ',fields)
  22                   *schema-types*))))
  23
  24 (defun find-schema-type (schema-type-name)
  25   (let ((c (assoc schema-type-name *schema-types*)))
  26     (if c
  27         (cdr c)
  28         (error "Undefined schema-type: ~A" schema-type-name))))
  29
  30 (defmacro schema-bind ((schema-type-name datum bindings &key context) &body body)
  31   (let* ((schema-type (find-schema-type schema-type-name))
  32          (fields (cdr (assoc :fields schema-type))))
  33     `(alist-bind
  34       ,(loop with added = (make-hash-table :test 'eq)
  35           for type-field in fields
  36           nconc (destructuring-bind (binding-sym type &key alias ((:context field-context)) &allow-other-keys) type-field
  37                   (when (and (not (gethash binding-sym added))
  38                              (if (eq bindings :auto)
  39                                  (or (not field-context) (eq field-context context))
  40                                  (member binding-sym bindings :test #'string=)))
  41                     (setf (gethash binding-sym added) t)
  42                     (list (list* (intern (string binding-sym) *package*)
  43                                  (if (eq type 'string) 'simple-string type) ; Optimization, assuming strings coming from the backend
  44                                                                             ; can never be displaced etc.
  45                                  (if alias (list alias)))))))
  46       ,datum
  47       ,@body)))