From 41ed789fc20905ac1d82720c7ec7259fc7dd28a2 Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Fri, 4 Nov 2022 17:23:35 +0100
Subject: re-implement =?, which also implements hash-table equality and is
 variadic

---
 mew.scm        | 45 +++++++++++++++++++++++++++++++++------------
 mew.svnwiki    |  3 ++-
 tests/test.mew | 19 +++++++++++++++++--
 3 files changed, 52 insertions(+), 15 deletions(-)

diff --git a/mew.scm b/mew.scm
index 0383116..63463c5 100644
--- a/mew.scm
+++ b/mew.scm
@@ -23,7 +23,7 @@
      uniq-accumulator unlist until
      vals void?
      -> fun-> fun->> set->
-     <>?
+     =? <>?
      ~?
 
      generic-make-accumulator)
@@ -84,7 +84,6 @@
       (begin seq)
       (lambda fun)
       (apply app)
-      (equal? =?)
       (ceiling ceil)
       ))
 
@@ -97,18 +96,40 @@
   (define (boolean x)
     (not (not x)))
 
+  (define (tbl=? a b)
+    (and (hash-table? a)
+         (hash-table? b)
+         (= (hash-table-size a) (hash-table-size b))
+         (call-with-current-continuation
+          (lambda (ret)
+            (hash-table-for-each
+             a
+             (lambda (k v)
+               ;; n.b. nan is never equal to anything
+               (unless (=? (hash-table-ref/default b k +nan.0) v)
+                 (ret #f))))
+            #t))))
+
+  (define =?
+    (case-lambda
+      (()  #t)
+      ((_) #t)
+      ((x y) (or (equal? x y)
+                 (tbl=? x y)))
+      ((x . rest) (every (lambda (y) (=? x y)) rest))))
+
   (define <>?
     (case-lambda
-      ((a b) (not (equal? a b)))
-      ((a b c) (and (not (equal? a b))
-                    (not (equal? b c))
-                    (not (equal? c a))))
-      ((a b c d) (and (not (equal? a b))
-                      (not (equal? a c))
-                      (not (equal? a d))
-                      (not (equal? b c))
-                      (not (equal? b d))
-                      (not (equal? c d))))
+      ((a b) (not (=? a b)))
+      ((a b c) (and (not (=? a b))
+                    (not (=? b c))
+                    (not (=? c a))))
+      ((a b c d) (and (not (=? a b))
+                      (not (=? a c))
+                      (not (=? a d))
+                      (not (=? b c))
+                      (not (=? b d))
+                      (not (=? c d))))
       ((a b c d . rest)
        (call-with-current-continuation
         (lambda (return)
diff --git a/mew.svnwiki b/mew.svnwiki
index 142fb2a..eab7e64 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -244,7 +244,8 @@ If {{<obj>}} is false, read all data from {{*current-input-port*}}.
 
 <procedure>(=? <val>...)</procedure>
 
-Alias for {{equal?}}.
+Return true if all values are {{equal?}} or hash-tables with same
+set of keys and {{equal?}} values.
 
 <procedure>(<>? <val1> <val2> ...)</procedure>
 
diff --git a/tests/test.mew b/tests/test.mew
index 82a2e71..501a3ae 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -74,6 +74,19 @@
   (test #t (boolean "foo"))
   (test #t (boolean (void))))
 
+(test-group "=?"
+  (test #t (=?))
+  (test #t (=? 1))
+  (test #t (=? "foo" "foo"))
+  (test #t (=? 1 1 1))
+  (test #t (=? #(1 2 3) #(1 2 3)))
+  (test #t (=? (tbl 1 2 3 4) (tbl 3 4 1 2)))
+  (test #f (=? 4 5))
+  (test #f (=? 4 5 6))
+  (test #f (=? "foo" "bar"))
+  (test #f (=? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
+  (test #f (=? 4 5 4)))
+
 (test-group "<>?"
   (test #t (<>? 4 5))
   (test #t (<>? 4 5 6))
@@ -82,6 +95,8 @@
   (test #f (<>? 4 5 4))
   (test #f (<>? "foo" "foo"))
   (test #f (<>? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 7))
+  (test #t (<>? (tbl 1 2 3 4) (tbl 3 4 1 22)))
+  (test #t (<>? (tbl 1 2 3 4) (tbl 3 4)))
   (test-error "error with no arguments" (<>?))
   (test-error "error with one argument" (<>? 42)))
 
@@ -259,12 +274,12 @@
 
 (test-group "set-at"
   (test #(0 42 0) (set-at #(0 0 0) 1 42))
-  (test '(42) (vals (set-at (tbl 1 11) 1 42)))
+  (test #t (=? (tbl 1 42) (set-at (tbl 1 11) 1 42)))
   (test "fox" (set-at "foo" 2 #\x))
   (test-error (set-at '(0 0 0) 1 42)))
 
 (test-group "del-at"
-  (test '(42) (vals (del-at (tbl 0 41 1 42 2 43) 0 2)))
+  (test #t (=? (tbl 1 42) (del-at (tbl 0 41 1 42 2 43) 0 2)))
   (test-error (del-at "foo" 2)))
 
 (test-group "empty?"
-- 
cgit 1.4.1