Coverage report: /home/ati/workspace/perec/persistence/type.lisp

KindCoveredAll%
expression175425 41.2
branch728 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; -*-
2
 ;;;
3
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;;;;;;;;;;;;;;;;
10
 ;;; Defining types
11
 
12
 (defparameter *persistent-types* (make-hash-table))
13
 
14
 (defclass* persistent-type ()
15
   ((name
16
     :type symbol)
17
    (documentation
18
     :type string)
19
    (args
20
     :type list)
21
    (body
22
     :type list)
23
    (substituter
24
     :type function)))
25
 
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))
32
                           (pop body))))
33
     `(progn
34
       ,(when args
35
              `(defclass* ,(type-class-name-for name) (persistent-type)
36
                ,(append
37
                  `((name ',name)
38
                    (args ',args)
39
                    (body ',body))
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)))))
49
                  (unless type
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)
57
                  type)))
58
       ,(if common-lisp-type-p
59
            `',name
60
            `(deftype ,name ,args ,@body)))))
61
 
62
 (defun find-type (type)
63
   (gethash (first (ensure-list type)) *persistent-types*))
64
 
65
 (defun (setf find-type) (new-value type)
66
   (setf (gethash (first (ensure-list type)) *persistent-types*) new-value))
67
 
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))
73
                       type "-type"))
74
 
75
 (defun argument-names-for (args)
76
   (remove-if #L(or (eq !1 '&optional)
77
                    (eq !1 '&key)
78
                    (eq !1 '&rest)
79
                    (eq !1 '&allow-other-keys))
80
              args))
81
 
82
 (defun type-specifier-p (type)
83
   (find-type type))
84
 
85
 (defun substitute-type-arguments (type args)
86
   (let ((persistent-type (find-type type)))
87
     (if persistent-type
88
         (apply (substituter-of (find-type type)) args)
89
         (error "Unknown type specifier: ~A" type))))
90
 
91
 ;;;;;;;;;;;;;;;;;;
92
 ;;; Canonical type
93
 
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))))
99
 
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.")
102
 
103
 (defun find-class* (class-or-name)
104
   (if (typep class-or-name 'standard-class)
105
       class-or-name
106
       (find-class class-or-name)))
107
 
108
 (defun canonical-type-p (type)
109
   (member (first (ensure-list type)) *canonical-types*))
110
 
111
 (defun class-type-p (type)
112
   (and (symbolp type)
113
        (find-class type nil)))
114
 
115
 (defun disjunct-type-p (type-1 type-2)
116
   (equal '(#t #t)
117
          (multiple-value-list
118
              (subtypep (canonical-type-for `(and ,type-1 ,type-2)) nil))))
119
 
120
 (defun canonical-type-for* (type)
121
   (pattern-case type
122
     (t t)
123
     (nil nil)
124
     (boolean 'boolean)
125
     (double 'double)
126
     ((?is ?type canonical-type-p)
127
      type)
128
     ((?is ?type class-type-p)
129
      type)
130
     ((?or (and (?* ?x) ?a (?* ?y) (not ?a) (?* ?z))
131
           (and (?* ?x) (not ?a) (?* ?y) ?a (?* ?z)))
132
      nil)
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)))
137
      t)
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))))))))
145
      nil)
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))))
153
     ((?is ?type symbolp)
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)
159
            type)))
160
     (?type
161
      type)))
162
 
163
 (defvar *mapped-type-precedence-list*
164
   '(nil
165
     unbound
166
     null
167
     boolean
168
     integer-16
169
     integer-32
170
     integer-64
171
     integer
172
     float-32
173
     float-64
174
     float
175
     double
176
     number
177
     text
178
     duration
179
     string
180
     timestamp
181
     date
182
     time
183
     form
184
     member
185
     symbol*
186
     symbol
187
     serialized
188
     set
189
     t)
190
   "An ordered list of types which are mapped to RDBMS.")
191
 
192
 ;;;;;;;;;;;;;;;;
193
 ;;; Type mapping
194
 
195
 (defmacro defmapping (name sql-type reader writer)
196
   `(progn
197
     (defmethod compute-column-type* ((type (eql ',name)) type-specification)
198
       (declare (ignorable type-specification))
199
       ,sql-type)
200
 
201
     (defmethod compute-reader* ((type (eql ',name)) type-specification)
202
       (declare (ignorable type-specification))
203
       ,reader)
204
 
205
     (defmethod compute-writer* ((type (eql ',name)) type-specification)
206
       (declare (ignorable type-specification))
207
       ,writer)))
208
 
209
 ;;;;;;;;;;;;;;;
210
 ;;; Type parser
211
 
212
 (defgeneric parse-keyword-type-parameters (type type-parameters)
213
   (:method (type type-parameters)
214
            type-parameters))
215
 
216
 (defgeneric parse-positional-type-parameters (type type-parameters)
217
   (:method (type (type-parameters null))
218
            nil)
219
   
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)))))
226
 
227
 (defun parse-type (type-specifier)
228
   (etypecase type-specifier
229
     (symbol (find-type type-specifier))
230
     (list
231
      (let ((type (make-instance (type-class-name-for (first type-specifier)))))
232
        (apply #'reinitialize-instance type
233
               (cond ((= 0 (length type-specifier))
234
                      nil)
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)))
239
 
240
 ;;;;;;;;;;;;;;;;
241
 ;;; Type printer
242
 
243
 ;; TODO:
244
 
245
 ;;;;;;;;;;;;;;;;;;;;
246
 ;;; Destructure type
247
 
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)))
257
 
258
 ;;;;;;;;;;;;;;;;
259
 ;;; Type matcher
260
 
261
 (defvar *matches-type-cut-function*)
262
 
263
 (defun default-matches-type-cut (object slot type)
264
   (declare (ignore object slot))
265
   (or (persistent-object-p type)
266
       (set-type-p type)))
267
 
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))
270
     (flet ((body ()
271
              (aprog1 (matches-type* value type)
272
                (unless it
273
                  (error (make-condition 'value-type-violation :value value :value-type type))))))
274
       (if (not signal-type-violations)
275
           (handler-case (body)
276
             (type-violation () #f))
277
           (body)))))
278
 
279
 (defcondition* type-violation ()
280
   ())
281
 
282
 (defcondition* value-type-violation (type-violation)
283
   ((value
284
     :type t)
285
    (value-type
286
     :type the-type)))
287
 
288
 (defcondition* object-slot-type-violation (type-violation)
289
   ((object
290
     :type persistent-object)
291
    (slot
292
     :type persistent-effective-slot-definition)))
293
 
294
 (defgeneric matches-type* (value type)
295
   (:documentation "Checks if the given value matches the type.")
296
 
297
   (:method (value type)
298
            (error "Value ~A could not be matched against type ~A" value type))
299
 
300
   (:method (value (type list))
301
            (typep value type)))
302