From 3394261352a6103c8969f1cd938135a03754cf0b Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 14 Sep 2024 08:09:26 -0700
Subject: Add table deftype

---
 README.org       |  1 +
 package.lisp     |  4 +++-
 petty-types.lisp | 28 ++++++++++++++++++++++++++++
 3 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/README.org b/README.org
index 49e549a..cb6f2a8 100644
--- a/README.org
+++ b/README.org
@@ -7,6 +7,7 @@ A tiny library that provides
 + ~(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
++ ~(table from to)~ DEFTYPE for a hashtable 
 
   Here are some examples:
 
diff --git a/package.lisp b/package.lisp
index 1bf33cb..0f5cf89 100644
--- a/package.lisp
+++ b/package.lisp
@@ -10,4 +10,6 @@
    #:tuple                              ; deftype
    #:vector-of                          ; deftype
    #:sequence-of                        ; deftype
-   #:list-of))                          ; deftype
+   #:list-of                            ; deftype
+   #:table                              ; deftype
+   ))
diff --git a/petty-types.lisp b/petty-types.lisp
index 9392191..c48f37a 100644
--- a/petty-types.lisp
+++ b/petty-types.lisp
@@ -55,6 +55,30 @@ member is the NTH member of 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))))
@@ -74,3 +98,7 @@ member is the NTH member 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))))
-- 
cgit v1.2.3