From 071625684fda19cbb47dad95638fc8cd708ac29b Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sun, 1 Sep 2024 08:13:21 -0700
Subject: Add: TUPLE deftype

---
 README.org       | 10 ++++++++++
 package.lisp     |  1 +
 petty-types.lisp | 23 +++++++++++++++++++++++
 3 files changed, 34 insertions(+)

diff --git a/README.org b/README.org
index 9f4cb3e..36b4f4a 100644
--- a/README.org
+++ b/README.org
@@ -6,6 +6,7 @@ A tiny library that provides
   valid type specifier
 - ~(list-of type &optional len)~ DEFTYPE for a LIST of elements with TYPE
 - ~(vector-of type &optional len)~ DEFTYPE for a VECTOR of elements with TYPE
+- ~(tuple &rest types)~ DEFTYPE for a list of exactly TYPES
 
   Here are some examples:
 
@@ -44,4 +45,13 @@ NIL
 > (typep "abab" '(vector-of (member #\a #\b) 4))
 T
 
+;; here is an example of TUPLE
+
+> (typep '(1 #\x nil :foo) '(tuple fixnum character null keyword))
+T
+
+> (typep '(1 #\x nil xxx) '(tuple fixnum character null keyword))
+NIL   ; Because XXX is not a KEYWORD
+
+
 #+end_src
diff --git a/package.lisp b/package.lisp
index 6472436..ae36c5c 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,5 +7,6 @@
   (:export
    #:type-specifier-p                   ; function
    #:optional                           ; deftype
+   #:tuple                              ; deftype
    #:vector-of                          ; deftype
    #:list-of))                          ; deftype
diff --git a/petty-types.lisp b/petty-types.lisp
index 060f29d..a45e898 100644
--- a/petty-types.lisp
+++ b/petty-types.lisp
@@ -33,6 +33,25 @@
                        (or (not len) (= len (length xs)))
                        (every is-type xs)))))))))
 
+(defun ordered-sequence-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
+          (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)))))))))))
+
 (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))))
@@ -41,6 +60,10 @@
   "Type specifier for vectors all of the same TYPE."
   `(and vector (satisfies ,(sequence-of-predicate-for 'vector type len))))
 
+(deftype tuple (&rest types)
+  "Type specifier for a list of specific types"
+  `(and list (satisfies ,(ordered-sequence-of types))))
+
 (deftype optional (type)
   "Type specifier for an optional type."
   `(or null ,type))
-- 
cgit v1.2.3