;;;; hash-table-weak-tests-incl.scm

;; Weak References Tests

#|
- gen unique test data: ht, ls strong keys, ls strong vals
  - test w/
- ctor ht
  - test w/
- break some strong refs
  - test w/ resurrection after earlier conv to diff form - as part of ref
  break
    - note that breaking value ref reqs keeping, strong or not, key ref for
    lookup
- remaining strong refs
  - test w/ unbroken refs
|#

(cond-expand
  (compiling
    (import (chicken gc))

    (define-constant WEAK-DATA-COUNT 30)
    (define-constant WEAK-DATA-PARTS 4)
    (define-constant WEAK-DATA-SIZE (* WEAK-DATA-COUNT WEAK-DATA-PARTS))
    (assert (zero? (modulo WEAK-DATA-SIZE WEAK-DATA-PARTS)))

    (define (list-split ls #!optional (n (floor (/ (length ls) 2))))
      (let loop ((n n) (hds '()) (tls ls))
        (if (or (null? tls) (<= n 0)) (values (reverse hds) tls)
            (loop (sub1 n) (cons (car tls) hds) (cdr tls)) ) ) )

    (define (drop ls n) (receive (_ ns) (list-split ls n) ns))

    #|
    (define gensym!)
    (let ((+counter+ -1))
      (set! gensym!
        (lambda (#!optional (pre "g!"))
          (set! +counter+ (fx+ 1 +counter+))
          (string->symbol (string-append (if (symbol? pre) (symbol->string pre) pre)
                                         (number->string +counter+))) ) ) )
    |#

    (define (gensyms n #!optional (seed 'g))
      (let loop ((n n) (l '()))
        (if (not (positive? n)) (reverse l)
            (loop (sub1 n) (cons (gensym seed) l))) ) )

    (define (gen-symkeys-data tag #!optional (siz WEAK-DATA-SIZE))
      (gensyms siz tag) )

    (define (split-size m n) (round (/ m n)))
    (define (split-length ls n) (split-size (length ls) n))

    (define (symkeys-split ls #!optional (n (split-length ls 2)))
      (receive (hds tls) (list-split ls n)
        (values (map symbol->string hds) tls) ) )

    (test-group "HT - weak eq? hash-table - keys"
      ;make weak key table , gensym keys , set! table keys ,
      ;convert some keys to strings , gc (converted symbols keys -> bwp) ,
      ;verify the bwp keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #f))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                     ;drop some keys, but save for resurrection, as strings,
                     ;not symbols
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (symkeys-split keys slen)) )
          ;
          (test "tails length"
                (length tls)
                (- WEAK-DATA-SIZE (split-size WEAK-DATA-SIZE WEAK-DATA-PARTS)))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;PASS needed?
            ;(hash-table-clean! ht)
            ;resurrect for probe
            (for-each
              (lambda (x) (test-assert (not (hash-table-exists? ht (string->symbol x)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak eq? hash-table - values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #f #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals 2)) )
        (test slen (split-size WEAK-DATA-SIZE 2))
        (test-group "table build"
          (test (length keys) (length vals))
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          (test "card rem keys = vals" (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test "card rem keys = " (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht b))))
              bwps)
            (for-each
              (lambda (k) (test-assert (hash-table-exists? ht k)))
              tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (test "card keys = vals" (length keys) (length vals))
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
          (test (length keys) (hash-table-size ht)) ) )
    )

    (test-group "HT - weak eq? hash-table - key+values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                       ;drop 1st 1/4 values (keep keys) & 2nd 1/4 keys (keep values)
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen))
                      ((bwps tls) (symkeys-split tls slen)) )
          (test "card rem keys = 1/2 card" (length tls) (split-size WEAK-DATA-SIZE 2))
          (set! keys tls)
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged"
            ;FAIL why?
            ;(hash-table-clean! ht)
            (for-each
              (lambda (h) (test-assert (not (hash-table-exists? ht h))))
              hds)
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht (string->symbol b)))))
              bwps)
          ) )
        (test-group "table remainder"
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - keys"
      ;string keys w/ string values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #f))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals 2)) )
        (test-group "table build"
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                       ;drop some keys, but save for resurrection
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          (test "car rem keys = " (length tls) (split-size WEAK-DATA-SIZE 2))
          (set! bwps (map string->symbol bwps))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;FAIL why?
            ;(hash-table-clean! ht)
            ;probe remainder
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #f #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals 2)) )
        (test-group "table build"
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          (test "card rem keys = " (length tls) (split-size WEAK-DATA-SIZE 2))
          (test "card rem keys = vals" (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test "card rem keys = " (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht b))))
              bwps)
            (for-each
              (lambda (k) (test-assert (hash-table-exists? ht k)))
              tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
           (test (length keys) (hash-table-size ht)) ) )
    )

    (test-group "HT - weak string=? hash-table - key+values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data 'wvl))
             (slen (split-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each
            (lambda (k v) (hash-table-set! ht k v))
            keys vals)
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys vals)
        )
                       ;drop 1st 1/3 values & 2nd 1/3 keys
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen)) ;hds killed
                      ((bwps tls) (list-split tls slen)) )
          (test "card rem keys = " (length tls) (split-size WEAK-DATA-SIZE 2))
          (set! keys tls)
          (set! vals rst)
          (set! bwps (map string->symbol bwps)) ;kill keys
          (gc #t)
          (test-group "table scavanged"
            ;PASS why?
            ;(hash-table-clean! ht)
            (for-each
              (lambda (h) (test-assert (not (hash-table-exists? ht h))))
              hds)
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
              bwps)
          ) )
        (test-group "table remainder"
          (for-each
            (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
            keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )
  )
  (else) )