;;;; 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))

    ;; Test Sizes

    (define-constant WEAK-DATA-COUNT 25000)
    (define-constant WEAK-DATA-PARTS 4)
    (define-constant WEAK-DATA-SIZE (* WEAK-DATA-COUNT WEAK-DATA-PARTS))

    ;; Support

    (define (list-split ls n)
      (let loop ((n n) (hds '()) (tls ls))
        (if (or (null? tls) (fx<= n 0)) (values (reverse hds) tls)
            (loop (fx- n 1) (cons (car tls) hds) (cdr tls)) ) ) )

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

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

    ;; Test Data

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

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

    (define (str-data tag #!optional (siz WEAK-DATA-SIZE))
      (map symbol->string (sym-data tag siz)) )

    (define (syms->str+sym ls #!optional (n (parts-length ls 2)))
      (receive (hds tls) (list-split ls n)
        (values (map symbol->string hds) tls) ) )

    ;; Tests

    (assert (zero? (modulo WEAK-DATA-SIZE WEAK-DATA-PARTS)))

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak eq? - 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 (sym-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (test-assert-each "table built"
            (k v) (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) (syms->str+sym keys slen)) )
          (test "tails length"
                (length tls)
                (- WEAK-DATA-SIZE (parts-size WEAK-DATA-SIZE WEAK-DATA-PARTS)))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;#; ;unnecessary
            (hash-table-clean! ht)
            ;resurrect for probe
            (test-assert-each "revived probed"
              (x) (not (hash-table-exists? ht (string->symbol x))) bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak eq? - 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 (sym-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals 2)) )
        (test slen (parts-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)
          (test-assert-each "table built"
            (k v) (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!)"
            ;necessary
            (hash-table-clean! ht)
            ;(test "card rem keys = size" (length tls) (hash-table-size ht))
            ;(test "car ht alist = size" (hash-table-size ht) (length (hash-table->alist ht)))
            (test-assert-each "dropped gone"
              (b) (not (hash-table-exists? ht b)) bwps)
            (test-assert-each "remaining found"
              (k) (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))
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys vals)
          (test (length keys) (hash-table-size ht)) ) )
    )

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak eq? - 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 (sym-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (test-assert-each "table built"
            (k v) (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) (syms->str+sym tls slen)) )
          ;(test "card rem keys = 1/2 card" (length tls) (parts-size WEAK-DATA-SIZE 2))
          (set! keys tls)
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged"
            ;#; ;unnecessary
            (hash-table-clean! ht)
            (test-assert-each "dropped gone keys"
              (h) (not (hash-table-exists? ht h)) hds)
            (test-assert-each "dropped gone values"
              (b) (not (hash-table-exists? ht (string->symbol b))) bwps)
          ) )
        (test-group "table remainder"
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys (list-drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak string=? - keys")
      ;string keys w/ string values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #f))
             (keys (str-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals 2)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (test-assert-each "table built"
            (k v) (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) (parts-size WEAK-DATA-SIZE 2))
          (set! bwps (map string->symbol bwps))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;#; ;unnecessary
            (hash-table-clean! ht)
            ;resurrect for probe
            (test-assert-each "revived probed"
              (b) (not (hash-table-exists? ht (symbol->string b))) bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak string=? - values")
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #f #:weak-values #t))
             (keys (str-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals 2)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (test-assert-each "table built"
            (k v) (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 = 1/2" (length tls) (parts-size WEAK-DATA-SIZE 2))
          ;(test "card rem keys = vals" (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            ;necessary
            (hash-table-clean! ht)
            ;(test "card rem keys = size" (length tls) (hash-table-size ht))
            ;(test "car ht alist = size" (hash-table-size ht) (length (hash-table->alist ht)))
            (test-assert-each "dropped gone"
              (b) (not (hash-table-exists? ht b)) bwps)
            (test-assert-each "remaining found"
              (k) (hash-table-exists? ht k) tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys vals)
          (test (length keys) (hash-table-size ht)) ) )
    )

    (test-group (conc "HT (" WEAK-DATA-SIZE ") - weak string=? - key+values")
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #t))
             (keys (str-data 'wky))
             (vals (sym-data 'wvl))
             (slen (parts-length vals WEAK-DATA-PARTS)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (test-assert-each "table built"
            (k v) (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 = 1/2" (length tls) (parts-size WEAK-DATA-SIZE 2))
          ;(test "card dropped vals = keys" (length hds) (- (length vals) (length rst)))
          (set! keys tls)
          (set! vals rst)
          (set! bwps (map string->symbol bwps)) ;kill keys
          (gc #t)
          (test-group "table scavanged"
            ;#; ;unnecessary
            (hash-table-clean! ht)
            (test-assert-each "dropped gone values"
              (h) (not (hash-table-exists? ht h)) hds)
            (test-assert-each "dropped gone keys"
              (b) (not (hash-table-exists? ht (symbol->string b))) bwps)
          ) )
        (test-group "table remainder"
          (test-assert-each "remaining found"
            (k v) (eq? v (hash-table-ref ht k)) keys (list-drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )
  )
  (else) )