blob: c48f37a5f5f2a771ceaf6fb7201ffcb06ad65d27 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
;;;; petty-types.lisp
(in-package #:petty-types)
(defun type-specifier-p (thing)
"Returns T if THING is a valid TYPE-SPECIFIER, otherwise returns NIL."
(ignore-errors
(typep nil thing)
t))
(deftype type-specifier ()
'(satisfies type-specifier-p))
(defun sequence-of-predicate-for (cont type &optional len)
"Returns the name of a predicate that checks whether its argument is a
sequence of type CONT whose values are all of type TYPE."
(check-type type type-specifier "A TYPE-SPECIFIER")
(check-type cont type-specifier "A TYPE-SPECIFIER")
(assert (subtypep cont 'sequence) (cont) "~s is not a subtype of SEQUENCE." cont)
(check-type cont symbol "A SYMBOL")
(assert (or (eq len '*) (typep len 'fixnum)) (len) "LEN must be '* or a fixnum")
(let ((name
(let ((*package* #.(find-package :petty-types)))
(apply #'a:symbolicate cont :-of- (write-to-string len) :- (a:flatten type))))
(len
(when (typep len 'fixnum)
len)))
(prog1 name
(unless (fboundp name)
(setf (symbol-function name)
(let ((is-type (lambda (xs) (typep xs type))))
(lambda (xs)
(and (typep xs cont)
(or (not len) (= len (length xs)))
(every is-type xs)))))))))
(defun tuple-sequence-predicate-of (types)
"Returns the name of a predicate that checks whether its argument is a
list of exactly (LENGTH TYPES) members such that the type of the NTH
member is the NTH member of TYPES."
(assert (every #'type-specifier-p types) (types)
"At least one member of ~s is not a type specifier"
types)
(let ((name
(let ((*package* #.(find-package :petty-types)))
(apply #'a:symbolicate :tuple-
(mapcar #'write-to-string (a:flatten types))))))
(prog1 name
(unless (fboundp name)
(setf (symbol-function name)
(lambda (xs)
(and (listp xs)
(loop :for (x . xs2) :on xs
:for (ty . types2) :on types
:always (typep x ty)
:finally (return (and (endp xs2) (endp types2)))))))))))
(defun hash-table-predicate (from to)
"Returns the name of the predicate that checks whether its argument is
a hasth table with keys of type FROM and values of type TO."
(assert (type-specifier-p from) (from) "~a is not a type specifier" from)
(assert (type-specifier-p to) (to) "~a is not a type specifier" to)
(let ((name
(let ((*package* #.(find-package :petty-types)))
(apply #'a:symbolicate
(nconc
(list :hash-table-from-)
(mapcar #'write-to-string (a:flatten from))
(list :-to-)
(mapcar #'write-to-string (a:flatten to)))))))
(prog1 name
(unless (fboundp name)
(setf (symbol-function name)
(lambda (tb)
(and (hash-table-p tb)
(loop :for key :being :the :hash-keys :of tb
:using (:hash-value val)
:always (typep key from)
:always (typep val to)))))))))
(deftype list-of (type &optional len)
"Type specifier for lists all of the same TYPE."
`(and list (satisfies ,(sequence-of-predicate-for 'list type len))))
(deftype vector-of (type &optional len)
"Type specifier for vectors all of the same TYPE."
`(and vector (satisfies ,(sequence-of-predicate-for 'vector type len))))
(deftype sequence-of (type &optional len)
"Type specifier for vectors all of the same TYPE."
`(and sequence (satisfies ,(sequence-of-predicate-for 'sequence type len))))
(deftype tuple (&rest types)
"Type specifier for a list of specific types"
`(and list (satisfies ,(tuple-sequence-predicate-of types))))
(deftype optional (type)
"Type specifier for an optional type."
`(or null ,type))
(deftype table (from to)
"Type specifier for typed hash table."
`(and hash-table (satisfies ,(hash-table-predicate from to))))
|
