1 files changed, 43 insertions, 0 deletions
diff --git a/petty-types.lisp b/petty-types.lisp
new file mode 100644
index 0000000..1d092b9
--- /dev/null
+++ b/petty-types.lisp
@@ -0,0 +1,43 @@
+;;;; 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
+          (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)))))))))
+
+(deftype list-of (type &optional len)
+  "Type specifier for lists all of the same TYPE."
+  `(satisfies ,(sequence-of-predicate-for 'list type len)))
+
+(deftype vector-of (type &optional len)
+  "Type specifier for vectors all of the same TYPE."
+  `(satisfies ,(sequence-of-predicate-for 'vector type len)))
+