Guile-hoot/test/test-hash-tables.scm

;;; Copyright (C) 2023, 2024 Robin Templeton
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Hash table tests.
;;;
;;; Code:

(use-modules (srfi srfi-64)
             (test utils))

(test-begin "test-hash-tables")

(with-additional-imports
 ((hoot hashtables))
 
 (test-call "#t" (lambda () (hashtable? (make-eq-hashtable))))

 ;; Unimplemented:
 ;; - make-eqv-hashtable
 ;; - make-hashtable

 (test-call "#f" (lambda () (hashtable? 42)))

 (test-call "b" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-ref ht 'a 'b))))

 (test-call ""                           ; zero values
            (lambda ()
              (let ((ht (make-eq-hashtable)))
                (hashtable-set! ht 'a 'b))))

 (test-call "b" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 'b)
                    (hashtable-ref ht 'a #f))))

 (test-call "#f" (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'x 'y)
                     (hashtable-ref ht 'a #f))))

 (test-call "b" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 'b)
                    (hashtable-ref ht 'a 'b))))

 (test-call "0" (lambda ()
                  (hashtable-size (make-eq-hashtable))))

 (test-call "1" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 'b)
                    (hashtable-size ht))))

 (test-call "2" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 'b)
                    (hashtable-set! ht 'c 'd)
                    (hashtable-size ht))))

 (test-call "(#f 0)" (lambda ()
                       (let ((ht (make-eq-hashtable)))
                         (hashtable-set! ht 'a 'b)
                         (hashtable-delete! ht 'a)
                         (list (hashtable-ref ht 'a #f)
                               (hashtable-size ht)))))

 (test-call "(b 1)" (lambda ()
                      (let ((ht (make-eq-hashtable)))
                        (hashtable-set! ht 'a 'b)
                        (hashtable-delete! ht 'c)
                        (list (hashtable-ref ht 'a #f)
                              (hashtable-size ht)))))

 (test-call "#f" (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-contains? ht 'a))))

 (test-call "#t" (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-contains? ht 'a))))

 (test-call "1" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-update! ht 'a 1+ 0)
                    (hashtable-ref ht 'a #f))))

 (test-call "2" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 1)
                    (hashtable-update! ht 'a 1+ 0)
                    (hashtable-ref ht 'a #f))))

 (test-call "(2 b d)"
            (lambda ()
              (let ((ht (make-eq-hashtable)))
                (hashtable-set! ht 'a 'b)
                (hashtable-set! ht 'c 'd)
                (let ((ht* (hashtable-copy ht)))
                  (list (hashtable-size ht*)
                        (hashtable-ref ht* 'a #f)
                        (hashtable-ref ht* 'c #f))))))

 (test-call "0" (lambda ()
                  (let ((ht (make-eq-hashtable)))
                    (hashtable-set! ht 'a 'b)
                    (hashtable-clear! ht)
                    (hashtable-size ht))))

 (test-call "#()" (lambda ()
                    (hashtable-keys (make-eq-hashtable))))

 (test-call "#(a)" (lambda ()
                     (let ((ht (make-eq-hashtable)))
                       (hashtable-set! ht 'a 'b)
                       (hashtable-keys ht))))

 (test-call "#()" (lambda ()
                    (hashtable-entries (make-eq-hashtable))))

 (test-call "#(b)" (lambda ()
                     (let ((ht (make-eq-hashtable)))
                       (hashtable-set! ht 'a 'b)
                       (hashtable-entries ht))))

 ;; Unimplemented:
 ;; - equal-hash
 ;; - string-hash
 ;; - string-ci-hash
 ;; - symbol-hash

 ;; Extensions:

 (test-call "(a b)"
            (lambda ()
              (let ((ht (make-eq-hashtable))
                    (lst '()))
                (hashtable-set! ht 'a 'b)
                (hashtable-for-each
                 (lambda (k v)
                   (set! lst (cons k (cons v lst))))
                 ht)
                lst)))

 ;; Weak key hashtables
 (test-call "42"
            (lambda ()
              (let ((table (make-weak-key-hashtable)))
                (weak-key-hashtable-set! table 'foo 42)
                (weak-key-hashtable-ref table 'foo))))
 (test-call "uh-oh"
            (lambda ()
              (let ((table (make-weak-key-hashtable)))
                (weak-key-hashtable-ref table 'foo 'uh-oh))))
 (test-call "#f"
            (lambda ()
              (let ((table (make-weak-key-hashtable)))
                (weak-key-hashtable-set! table 'foo 42)
                (weak-key-hashtable-delete! table 'foo)
                (weak-key-hashtable-ref table 'foo)))))


(test-end* "test-hash-tables")