Guile-hoot/test/test-hashtables.scm

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;; 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:
;;;
;;; Hashtable tests.
;;;
;;; Code:

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

(test-begin "test-hashtables")

(with-additional-imports ((hoot hashtables))
  ;; Hashing numbers
  (test-call "6" (lambda () (hashq 42 37)))

  ;; Hashing pairs and lists.
  (test-call "228" (lambda () (hash '(a . b) 389)))
  (test-call "94" (lambda () (hash '(a b) 389)))
  ;; Deeply nested list.
  (test-call "69" (lambda ()  (hash '(a (b (c (d (e (f (g (h (i))))))))) 389)))
  ;; Circular list!
  (test-call "65"
             (lambda ()
               (let ((x (list 'a 'b 'c)))
                 (set-cdr! (cdr (cdr x)) x)
                 (hash x 389))))
  ;; Hash composition should not be commutative.
  (test-call "#f" (lambda () (= (hash '(a . b) 389) (hash '(b . a) 389))))

  ;; Hashing vectors of different length.
  (test-call "200" (lambda () (hash #() 389)))
  (test-call "222" (lambda () (hash #(1 2 3) 389)))

  ;; Hashing bytevectors of different length.
  (test-call "51"  (lambda () (hash #vu8() 389)))
  (test-call "155" (lambda () (hash #vu8(1) 389)))
  (test-call "224" (lambda () (hash #vu8(1 2) 389)))
  (test-call "294" (lambda () (hash #vu8(1 2 3) 389)))
  (test-call "206" (lambda () (hash #vu8(1 2 3 4) 389)))

  ;; Hashing bitvectors of different length.
  (test-call "173" (lambda () (hash #* 389)))
  (test-call "195" (lambda () (hash #*1010 389)))
  (test-call "119" (lambda () (hash #*01010 389)))

  ;; Empty bytevector should have different hash than empty bitvector.
  (test-call "#f" (lambda () (= (hash #vu8() 389) (hash #* 389))))

  ;; Hashing records.
  (test-call "222"
             (lambda ()
               (define-record-type q (make-q a) q? (a q-a))
               (hash (make-q 42) 389)))

  (define-syntax-rule (test-hashtable-impl make-hashtable
                                           make-eq-hashtable
                                           make-eqv-hashtable
                                           hashtable?
                                           hashtable-hash
                                           hashtable-equiv
                                           hashtable-size
                                           hashtable-ref
                                           hashtable-set!
                                           hashtable-delete!
                                           hashtable-clear!
                                           hashtable-contains?
                                           hashtable-copy
                                           hashtable-keys
                                           hashtable-values
                                           hashtable-for-each
                                           hashtable-fold)
    (begin
      ;; Ref hit
      (test-call "b"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-ref ht 'a))))
      ;; Ref miss
      (test-call "#f"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'x 'y)
                     (hashtable-ref ht 'a))))
      ;; Ref miss with default
      (test-call "b"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'x 'y)
                     (hashtable-ref ht 'a 'b))))
      ;; Key insertion increases size
      (test-call "1"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-size ht))))
      ;; Key deletion
      (test-call "#f"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-delete! ht 'a)
                     (hashtable-contains? ht 'a))))
      ;; Key deletion decrements size
      (test-call "0"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-delete! ht 'a)
                     (hashtable-size ht))))
      ;; Key deletion miss does not decrement size
      (test-call "1"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-delete! ht 'c)
                     (hashtable-size ht))))
      ;; Check for existing key
      (test-call "#t"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-contains? ht 'a))))
      ;; Overwrite value for key
      (test-call "c"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-set! ht 'a 'c)
                     (hashtable-ref ht 'a))))
      ;; Copy
      (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)
                             (hashtable-ref ht* 'c))))))
      ;; Clear sets size to 0
      (test-call "0"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-clear! ht)
                     (hashtable-size ht))))
      ;; Clear removes all associations
      (test-call "#f"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-clear! ht)
                     (hashtable-contains? ht 'a))))
      ;; Keys of an empty table
      (test-call "()"
                 (lambda ()
                   (hashtable-keys (make-eq-hashtable))))
      ;; Keys of a populated table
      (test-call "(a)"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-keys ht))))
      ;; Values of an empty table
      (test-call "()"
                 (lambda ()
                   (hashtable-values (make-eq-hashtable))))
      ;; Values of a populated table
      (test-call "(b)"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-values ht))))
      ;; For each iteration
      (test-call "(a b)"
                 (lambda ()
                   (let ((ht (make-eq-hashtable))
                         (result #f))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-for-each (lambda (k v)
                                           (set! result (list k v)))
                                         ht)
                     result)))
      ;; Fold (result order is technically unspecified but we know what it
      ;; will be)
      (test-call "((a . b) (c . d))"
                 (lambda ()
                   (let ((ht (make-eq-hashtable))
                         (result #f))
                     (hashtable-set! ht 'a 'b)
                     (hashtable-set! ht 'c 'd)
                     (hashtable-fold (lambda (k v prev)
                                       (cons (cons k v) prev))
                                     '()
                                     ht))))
      ;; Grow/shrink
      (test-call "100"
                 (lambda ()
                   (let ((ht (make-eq-hashtable)))
                     (do ((i 0 (1+ i)))
                         ((= i 100))
                       (hashtable-set! ht i i))
                     (do ((i 0 (1+ i)))
                         ((= i 100))
                       (hashtable-delete! ht i))
                     (do ((i 0 (1+ i)))
                         ((= i 100))
                       (hashtable-set! ht i i))
                     (hashtable-size ht))))))

  (test-hashtable-impl make-hashtable
                       make-eq-hashtable
                       make-eqv-hashtable
                       hashtable?
                       hashtable-hash
                       hashtable-equiv
                       hashtable-size
                       hashtable-ref
                       hashtable-set!
                       hashtable-delete!
                       hashtable-clear!
                       hashtable-contains?
                       hashtable-copy
                       hashtable-keys
                       hashtable-values
                       hashtable-for-each
                       hashtable-fold)

  ;; FIXME: These would need to be run in an async context in order
  ;; for any finalization to happen in the Hoot VM, but at least we
  ;; ensure that the main interface is working.
  (test-hashtable-impl make-weak-key-hashtable
                       make-eq-weak-key-hashtable
                       make-eqv-weak-key-hashtable
                       weak-key-hashtable?
                       weak-key-hashtable-hash
                       weak-key-hashtable-equiv
                       weak-key-hashtable-size
                       weak-key-hashtable-ref
                       weak-key-hashtable-set!
                       weak-key-hashtable-delete!
                       weak-key-hashtable-clear!
                       weak-key-hashtable-contains?
                       weak-key-hashtable-copy
                       weak-key-hashtable-keys
                       weak-key-hashtable-values
                       weak-key-hashtable-for-each
                       weak-key-hashtable-fold)

  (test-hashtable-impl make-weak-value-hashtable
                       make-eq-weak-value-hashtable
                       make-eqv-weak-value-hashtable
                       weak-value-hashtable?
                       weak-value-hashtable-hash
                       weak-value-hashtable-equiv
                       weak-value-hashtable-size
                       weak-value-hashtable-ref
                       weak-value-hashtable-set!
                       weak-value-hashtable-delete!
                       weak-value-hashtable-clear!
                       weak-value-hashtable-contains?
                       weak-value-hashtable-copy
                       weak-value-hashtable-keys
                       weak-value-hashtable-values
                       weak-value-hashtable-for-each
                       weak-value-hashtable-fold)

  (test-hashtable-impl make-doubly-weak-hashtable
                       make-eq-doubly-weak-hashtable
                       make-eqv-doubly-weak-hashtable
                       doubly-weak-hashtable?
                       doubly-weak-hashtable-hash
                       doubly-weak-hashtable-equiv
                       doubly-weak-hashtable-size
                       doubly-weak-hashtable-ref
                       doubly-weak-hashtable-set!
                       doubly-weak-hashtable-delete!
                       doubly-weak-hashtable-clear!
                       doubly-weak-hashtable-contains?
                       doubly-weak-hashtable-copy
                       doubly-weak-hashtable-keys
                       doubly-weak-hashtable-values
                       doubly-weak-hashtable-for-each
                       doubly-weak-hashtable-fold))

;; Guile legacy API
(with-imports ((guile))
  (test-call "42"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hashq-set! table 'foo 42)
                 (hashq-ref table 'foo))))

  (test-call "#f"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hash-set! table "foo" 42)
                 (hash-remove! table "foo")
                 (hash-ref table "foo"))))

  (test-call "42"
             (lambda ()
               (let ((table (make-weak-key-hash-table)))
                 (hashq-set! table 'foo 42)
                 (hashq-ref table 'foo))))

  (test-call "((baz . 3) (bar . 2) (foo . 1))"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hashq-set! table 'foo 1)
                 (hashq-set! table 'bar 2)
                 (hashq-set! table 'baz 3)
                 (hash-map->list cons table))))

  (test-call "3"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hash-set! table "foo" 1)
                 (hash-set! table "bar" 2)
                 (hash-set! table "baz" 3)
                 (hash-count (lambda (key val) #t) table))))

  ;; clear, fold, and for-each on an empty table should no-op because
  ;; we don't yet know the concrete table type.
  (test-call "#t"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hash-clear! table)
                 #t)))
  (test-call "0"
             (lambda ()
               (let ((table (make-hash-table)))
                 (hash-fold (lambda (key val sum)
                              (+ sum val))
                            0 table))))
  (test-call "0"
             (lambda ()
               (let ((count 0)
                     (table (make-hash-table)))
                 (hash-for-each (lambda (key val)
                                  (set! count (1+ count)))
                                table)
                 count))))

(test-end* "test-hashtables")