Initial Commit

3 files changed, 64 insertions, 0 deletions

diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..57ed987
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,10 @@
+;;;; package.lisp
+
+(defpackage #:petty-types
+  (:use #:cl)
+  (:local-nicknames
+   (#:a #:alexandria-2))
+  (:export
+   #:type-specifier-p                   ; function
+   #:vector-of                          ; deftype
+   #:list-of))                          ; deftype
diff --git a/petty-types.asd b/petty-types.asd
new file mode 100644
index 0000000..90d3b8e
--- /dev/null
+++ b/petty-types.asd
@@ -0,0 +1,11 @@
+;;;; petty-types.asd
+
+(asdf:defsystem #:petty-types
+  :description "Describe petty-types here"
+  :author "Your Name <your.name@example.com>"
+  :license  "Specify license here"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:alexandria)
+  :components ((:file "package")
+               (:file "petty-types")))
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)))
+