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
))
5 (in-package #:lw2.schema-type
)
7 (defvar *schema-types
* nil
)
9 (defun delete-schema-type (name)
10 (setf *schema-types
* (delete name
*schema-types
* :key
#'car
)))
12 (defmacro undefine-schema-type
(name)
13 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
14 (delete-schema-type ,name
)))
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
)
21 (acons ,name
(alist :fields
',fields
)
24 (defun find-schema-type (schema-type-name)
25 (let ((c (assoc schema-type-name
*schema-types
*)))
28 (error "Undefined schema-type: ~A" schema-type-name
))))
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
))))
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
)))))))