Coverage report: /home/ati/workspace/perec/persistence/type.lisp
Kind | Covered | All | % |
expression | 175 | 425 | 41.2 |
branch | 7 | 28 | 25.0 |
Key
Not instrumented
Conditionalized out
Executed
Not executed
Both branches taken
One branch taken
Neither branch taken
1
;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
3
;;; Copyright (c) 2006 by the authors.
5
;;; See LICENCE for details.
12
(defparameter *persistent-types* (make-hash-table))
14
(defclass* persistent-type ()
26
(defmacro defptype (name args &body body)
27
(bind ((common-lisp-type-p (eq (symbol-package name) (find-package :common-lisp)))
28
(allow-nil-args-p (or (null args)
29
(eq '&optional (first args))
30
(eq '&rest (first args))))
31
(documentation (when (stringp (first body))
35
`(defclass* ,(type-class-name-for name) (persistent-type)
40
(mapcar #L(list !1 nil) (argument-names-for args)))
41
(:export-class-name-p #t)
42
(:export-accessor-names-p #t)))
43
,(when (or allow-nil-args-p
44
(not common-lisp-type-p))
45
`(eval-when (:load-toplevel :execute)
46
(bind ((substituter (lambda ,args ,@body))
47
(type ,(when allow-nil-args-p
48
`(parse-type (apply substituter nil)))))
50
(setf type (make-instance 'persistent-type)))
51
(setf (name-of type) ',name)
52
(setf (args-of type) ',args)
53
(setf (body-of type) ',body)
54
(setf (documentation-of type) ',documentation)
55
(setf (substituter-of type) substituter)
56
(setf (find-type ',name) type)
58
,(if common-lisp-type-p
60
`(deftype ,name ,args ,@body)))))
62
(defun find-type (type)
63
(gethash (first (ensure-list type)) *persistent-types*))
65
(defun (setf find-type) (new-value type)
66
(setf (gethash (first (ensure-list type)) *persistent-types*) new-value))
68
(defun type-class-name-for (type)
69
(concatenate-symbol (if (eq (symbol-package type)
70
(find-package :common-lisp))
71
(find-package :cl-perec)
72
(symbol-package type))
75
(defun argument-names-for (args)
76
(remove-if #L(or (eq !1 '&optional)
79
(eq !1 '&allow-other-keys))
82
(defun type-specifier-p (type)
85
(defun substitute-type-arguments (type args)
86
(let ((persistent-type (find-type type)))
88
(apply (substituter-of (find-type type)) args)
89
(error "Unknown type specifier: ~A" type))))
94
(defun canonical-type-for (type)
95
(iter (for simplified-type :initially type :then (simplify-boolean-form (canonical-type-for* (->dnf simplified-type))))
96
(for previous-type :previous simplified-type)
97
(until (equal simplified-type previous-type))
98
(finally (return simplified-type))))
100
(defvar *canonical-types* nil
101
"A list of type names to be treated as canonical types when a type is converted into canonical form.")
103
(defun find-class* (class-or-name)
104
(if (typep class-or-name 'standard-class)
106
(find-class class-or-name)))
108
(defun canonical-type-p (type)
109
(member (first (ensure-list type)) *canonical-types*))
111
(defun class-type-p (type)
113
(find-class type nil)))
115
(defun disjunct-type-p (type-1 type-2)
118
(subtypep (canonical-type-for `(and ,type-1 ,type-2)) nil))))
120
(defun canonical-type-for* (type)
126
((?is ?type canonical-type-p)
128
((?is ?type class-type-p)
130
((?or (and (?* ?x) ?a (?* ?y) (not ?a) (?* ?z))
131
(and (?* ?x) (not ?a) (?* ?y) ?a (?* ?z)))
133
((and (?* ?x) ?a (?* ?y) ?a (?* ?z))
134
(canonical-type-for (list* 'and (append ?x (list ?a) ?y ?z))))
135
((?or (or (?* ?x) ?a (?* ?y) (not ?a) (?* ?z))
136
(or (?* ?x) (not ?a) (?* ?y) ?a (?* ?z)))
138
((or (?* ?x) ?a (?* ?y) ?a (?* ?z))
139
(canonical-type-for (list* 'or (append ?x (list ?a) ?y ?z))))
140
((and (?* ?x) ?a (?* ?x) ?b (?* ?z)
141
(?if (and (persistent-class-type-p ?a)
142
(persistent-class-type-p ?b)
143
(not (intersection (list* (find-class* ?a) (persistent-effective-sub-classes-of (find-class* ?a)))
144
(list* (find-class* ?b) (persistent-effective-sub-classes-of (find-class* ?b))))))))
146
((?or (and (?* ?x) ?a (?* ?y) (not ?b) (?* ?z)
147
(?if (disjunct-type-p ?a ?b)))
148
(and (?* ?x) (not ?b) (?* ?y) ?a (?* ?z)
149
(?if (disjunct-type-p ?a ?b))))
150
(canonical-type-for `(and ,@?x ,@?y ,?a ,@?z)))
151
(((?or or and not) . ?args)
152
(list* (first type) (mapcar #'canonical-type-for (cdr type))))
154
(canonical-type-for (substitute-type-arguments type nil)))
155
((?is ?type type-specifier-p)
156
(let ((substituted-type (substitute-type-arguments (first type) (cdr type))))
157
(if (not (equal substituted-type type))
158
(canonical-type-for substituted-type)
163
(defvar *mapped-type-precedence-list*
190
"An ordered list of types which are mapped to RDBMS.")
195
(defmacro defmapping (name sql-type reader writer)
197
(defmethod compute-column-type* ((type (eql ',name)) type-specification)
198
(declare (ignorable type-specification))
201
(defmethod compute-reader* ((type (eql ',name)) type-specification)
202
(declare (ignorable type-specification))
205
(defmethod compute-writer* ((type (eql ',name)) type-specification)
206
(declare (ignorable type-specification))
212
(defgeneric parse-keyword-type-parameters (type type-parameters)
213
(:method (type type-parameters)
216
(defgeneric parse-positional-type-parameters (type type-parameters)
217
(:method (type (type-parameters null))
220
(:method (type type-parameters)
221
(let ((args (argument-names-for (args-of type))))
222
;; TODO: eliminate this eval by storing the lambde in the defptype
223
(eval `(apply (lambda ,(args-of type)
224
(list ,@(mappend #L(list (intern (symbol-name !1) (find-package :keyword)) !1) args)))
225
',type-parameters)))))
227
(defun parse-type (type-specifier)
228
(etypecase type-specifier
229
(symbol (find-type type-specifier))
231
(let ((type (make-instance (type-class-name-for (first type-specifier)))))
232
(apply #'reinitialize-instance type
233
(cond ((= 0 (length type-specifier))
235
((find-if #'keywordp (cdr type-specifier))
236
(parse-keyword-type-parameters type (rest type-specifier)))
237
(t (parse-positional-type-parameters type (rest type-specifier)))))))
238
(persistent-type type-specifier)))
248
(defun destructure-type (type)
249
"Returns (values normalized-type null-subtype-p unbound-subtype-p)."
250
(bind ((normalized-type (normalized-type-for type))
251
(mapped-type (mapped-type-for normalized-type))
252
(unbound-subtype-p (and (not (unbound-subtype-p mapped-type))
253
(unbound-subtype-p type)))
254
(null-subtype-p (and (not (null-subtype-p mapped-type))
255
(null-subtype-p type))))
256
(values normalized-type null-subtype-p unbound-subtype-p)))
261
(defvar *matches-type-cut-function*)
263
(defun default-matches-type-cut (object slot type)
264
(declare (ignore object slot))
265
(or (persistent-object-p type)
268
(defun matches-type (value type &key (cut-function #'default-matches-type-cut) (signal-type-violations #f))
269
(bind ((*matches-type-cut-function* cut-function))
271
(aprog1 (matches-type* value type)
273
(error (make-condition 'value-type-violation :value value :value-type type))))))
274
(if (not signal-type-violations)
276
(type-violation () #f))
279
(defcondition* type-violation ()
282
(defcondition* value-type-violation (type-violation)
288
(defcondition* object-slot-type-violation (type-violation)
290
:type persistent-object)
292
:type persistent-effective-slot-definition)))
294
(defgeneric matches-type* (value type)
295
(:documentation "Checks if the given value matches the type.")
297
(:method (value type)
298
(error "Value ~A could not be matched against type ~A" value type))
300
(:method (value (type list))