(module test-table mzscheme

  (require "../private/require.ss")
  (require-contracts)
  (require-schemeunit)
  (require-etc)
  (require-lists)

  (require "../private/datum.ss"
           (prefix table: "../table.ss"))

  (provide/contract
   [test-table test-suite?]
   [test-ordered-table test-suite?]
   [test-hashed-table test-suite?]
   [test-unordered-table test-suite?])

  (define (make-table-test name table)
    (make-test-suite (format "Table: ~a" name)
      (make-test-suite "accessors"
        (make-test-suite "keys"
          (make-test-case "empty"
            (assert equal?
                    (table:keys (table null))
                    (map first (table:to-sexp (table null)))))
          (make-test-case "1,2,3"
            (assert equal?
                    (table:keys (table '([1 A] [2 B] [3 C])))
                    (map first (table:to-sexp (table '([1 A] [2 B] [3 C])))))))
        (make-test-suite "values"
          (make-test-case "empty"
            (assert equal?
                    (table:values (table null))
                    (map second (table:to-sexp (table null)))))
          (make-test-case "1,2,3"
            (assert equal?
                    (table:values (table '([1 A] [2 B] [3 C])))
                    (map second (table:to-sexp (table '([1 A] [2 B] [3 C])))))))
        (make-test-suite "to-sexp"
          (make-test-case "empty"
            (assert datum-bindings=? (table:to-sexp (table null)) null))
          (make-test-case "1,2,3"
            (assert datum-bindings=?
                    (table:to-sexp (table '([1 A] [2 B] [3 C])))
                    '([1 A] [2 B] [3 C]))))
        (make-test-suite "to-alist"
          (make-test-case "empty"
            (assert equal?
                    (table:to-alist (table null))
                    (map (lambda (pair) (cons (first pair) (second pair)))
                         (table:to-sexp (table null)))))
          (make-test-case "1,2,3"
            (assert equal?
                    (table:to-alist (table '([1 A] [2 B] [3 C])))
                    (map (lambda (pair) (cons (first pair) (second pair)))
                         (table:to-sexp (table '([1 A] [2 B] [3 C])))))))
        (make-test-suite "empty?"
          (make-test-case "true"
            (assert-true (table:empty? (table null))))
          (make-test-case "false"
            (assert-false (table:empty? (table '([1 A] [2 B] [3 C]))))))
        (make-test-suite "size"
          (make-test-case "A1-B2-C3"
            (assert = (table:size (table '([A 1] [B 2] [C 3]))) 3)))
        (make-test-suite "contains?"
          (make-test-case "true"
            (assert-true (table:contains? 'A (table '([A 1] [B 2] [C 3])))))
          (make-test-case "false"
            (assert-false (table:contains? 'D (table '([A 1] [B 2] [C 3]))))))
        (make-test-suite "lookup"
          (make-test-case "a in a,b,c"
            (assert = (table:lookup "a" (table '(["a" 1] ["b" 2] ["c" 3]))) 1))
          (make-test-case "a in b,c"
            (assert-false (table:lookup "a" (table '(["b" 2] ["c" 3])))))
          (make-test-case "success override"
            (assert eq?
                    (table:lookup 1 (table '([1 one] [2 two] [3 three]))
                                  (lambda () 'failure)
                                  (lambda (any) 'success))
                    'success))
          (make-test-case "failure override"
            (assert eq?
                    (table:lookup 4 (table '([1 one] [2 two] [3 three]))
                                  (lambda () 'failure)
                                  (lambda (any) 'success))
                    'failure)))
        (make-test-suite "lookup/key"
          (make-test-case "present"
            (assert-equal? (table:lookup/key 1 (table '([1 A] [2 B] [3 C]))) 1))
          (make-test-case "absent"
            (assert-equal? (table:lookup/key 4 (table '([1 A] [2 B] [3 C]))) #f))
          (make-test-case "success override"
            (assert-equal?
             (table:lookup/key 1 (table '([1 A] [2 B] [3 C]))
                               (lambda () 'failure)
                               (lambda (k v) 'success))
             'success))
          (make-test-case "failure override"
            (assert-equal?
             (table:lookup/key 4 (table '([1 A] [2 B] [3 C]))
                               (lambda () 'failure)
                               (lambda (k v) 'success))
             'failure)))
        (make-test-suite "select"
          (make-test-case "singleton"
            (let*-values ([(key value) (table:select (table '([1 A])))])
              (assert datum=? key 1)
              (assert datum=? value 'A))))
        (make-test-suite "select/key"
          (make-test-case "singleton"
            (let* ([key (table:select/key (table '([1 A])))])
              (assert datum=? key 1))))
        (make-test-suite "select/value"
          (make-test-case "singleton"
            (let* ([value (table:select/value (table '([1 A])))])
              (assert datum=? value 'A))))
        )
      (make-test-suite "updaters"
        (make-test-suite "insert"
          (make-test-case "1,3 + 2"
            (assert datum-bindings=?
                    (table:to-sexp (table:insert 2 'B (table '([1 A] [3 C]))))
                    '([1 A] [2 B] [3 C])))
          (make-test-case "1,2,3 + 2"
            (assert datum-bindings=?
                    (table:to-sexp (table:insert 2 'X (table '([1 A] [2 B] [3 C]))))
                    '([1 A] [2 X] [3 C]))))
        (make-test-suite "remove"
          (make-test-case "present"
            (assert datum-bindings=?
                    (table:to-sexp (table:remove 2 (table '([1 A] [2 B] [3 C]))))
                    '([1 A] [3 C])))
          (make-test-case "absent"
            (assert datum-bindings=?
                    (table:to-sexp (table:remove 4 (table '([1 A] [2 B] [3 C]))))
                    '([1 A] [2 B] [3 C]))))
        (make-test-suite "update"
          (make-test-case "present"
            (assert
             datum-bindings=?
             (table:to-sexp (table:update 1 + (table '([1 10] [2 20] [3 30]))))
             '([1 11] [2 20] [3 30])))
          (make-test-case "absent"
            (assert
             datum-bindings=?
             (table:to-sexp (table:update 4 + (table '([1 10] [2 20] [3 30]))))
             '([1 10] [2 20] [3 30]))))
        (make-test-suite "update/value"
          (make-test-case "present"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/value 1 symbol->string (table '([1 A] [2 B] [3 C]))))
             '([1 "A"] [2 B] [3 C])))
          (make-test-case "absent"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/value 4 symbol->string (table '([1 A] [2 B] [3 C]))))
             '([1 A] [2 B] [3 C]))))
        (make-test-suite "update/insert"
          (make-test-case "present"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/insert 1 + 10 (table '([1 10] [2 20] [3 30]))))
             '([1 11] [2 20] [3 30])))
          (make-test-case "absent"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/insert 4 + 40 (table '([1 10] [2 20] [3 30]))))
             '([1 10] [2 20] [3 30] [4 40]))))
        (make-test-suite "update/insert/value"
          (make-test-case "present"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/insert/value 1 symbol->string 'A
                                         (table '([1 A] [2 B] [3 C]))))
             '([1 "A"] [2 B] [3 C])))
          (make-test-case "absent"
            (assert
             datum-bindings=?
             (table:to-sexp
              (table:update/insert/value 4 symbol->string 'D
                                         (table '([1 A] [2 B] [3 C]))))
             '([1 A] [2 B] [3 C] [4 D]))))
        (make-test-suite "clear"
          (make-test-case "1,2,3"
            (assert-true
             (table:empty? (table:clear (table '([1 A] [2 B] [3 C])))))))
        )
      (make-test-suite "traversals"
        (make-test-suite "fold"
          (make-test-case "1,2,3"
            (assert-equal?
             (table:fold (lambda (key value sexp)
                           (append sexp (list (list key value))))
                         null
                         (table '([1 A] [2 B] [3 C])))
             (table:to-sexp (table '([1 A] [2 B] [3 C]))))))
        (make-test-suite "fold/key"
          (make-test-case "1,2,3"
            (assert-equal?
             (table:fold/key (lambda (key keys)
                               (append keys (list key)))
                             null
                             (table '([1 A] [2 B] [3 C])))
             (table:keys (table '([1 A] [2 B] [3 C]))))))
        (make-test-suite "fold/value"
          (make-test-case "1,2,3"
            (assert-equal?
             (table:fold/value (lambda (value values)
                                 (append values (list value)))
                               null
                               (table '([1 A] [2 B] [3 C])))
             (table:values (table '([1 A] [2 B] [3 C]))))))
        (make-test-suite "for-each"
          (make-test-case "1,2,3"
            (let* ([vec (vector #f #f #f)])
              (table:for-each (lambda (key value)
                                (vector-set! vec (- key 1) value))
                              (table '([1 A] [2 B] [3 C])))
              (assert-equal? vec (vector 'A 'B 'C))))
          (make-test-case "non-void"
            (table:for-each (constant #f) (table '([1 A])))))
        (make-test-suite "for-each/key"
          (make-test-case "1,2,3"
            (let* ([vec (vector #f #f #f)])
              (table:for-each/key (lambda (key)
                                    (vector-set! vec (- key 1) #t))
                                  (table '([1 A] [2 B] [3 C])))
              (assert-equal? vec (vector #t #t #t))))
          (make-test-case "non-void"
            (table:for-each/key (constant #f) (table '([1 A])))))
        (make-test-suite "for-each/value"
          (make-test-case "1,2,3"
            (let* ([vec (vector #f #f #f)])
              (table:for-each/value (lambda (value)
                                      (vector-set! vec (- value 1) #t))
                                    (table '([A 1] [B 2] [C 3])))
              (assert-equal? vec (vector #t #t #t))))
          (make-test-case "non-void"
            (table:for-each/value (constant #f) (table '([1 A])))))
        (make-test-suite "map"
          (make-test-case "1:10,2:20,3:30 => 1:11,2:22,3:33"
            (assert datum-bindings=?
                    (table:to-sexp (table:map +
                                              (table '([1 10] [2 20] [3 30]))))
                    '([1 11] [2 22] [3 33]))))
        (make-test-suite "map/key"
          (make-test-case "1:1,2:4,3:9"
            (assert datum-bindings=?
                    (table:to-sexp (table:map/key (lambda (n) (* n n))
                                                  (table '([1 #f] [2 #f] [3 #f]))))
                    '([1 1] [2 4] [3 9]))))
        (make-test-suite "map/value"
          (make-test-case "1A2B3C => 1'A'2'B'3'C'"
            (assert datum-bindings=?
                    (table:to-sexp (table:map/value symbol->string
                                                    (table '([1 A] [2 B] [3 C]))))
                    '([1 "A"] [2 "B"] [3 "C"]))))
        (make-test-suite "filter"
          (make-test-case "1:4,2:3,3:2,4:1 => 1:4,2:3"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:filter < (table '([1 4] [2 3] [3 2] [4 1]))))
                    '([1 4] [2 3]))))
        (make-test-suite "filter/key"
          (make-test-case "1,2,3,4 => 2,4"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:filter/key even? (table '([1 A] [2 B] [3 C] [4 D]))))
                    '([2 B] [4 D]))))
        (make-test-suite "filter/value"
          (make-test-case "1,2,3,4 => 2,4"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:filter/value even?
                                         (table '([A 1] [B 2] [C 3] [D 4]))))
                    '([B 2] [D 4]))))
        (make-test-suite "all?"
          (make-test-case "none"
            (assert-false (table:all? < (table '([1 1] [2 2] [3 3])))))
          (make-test-case "some"
            (assert-false (table:all? < (table '([1 0] [2 2] [3 4])))))
          (make-test-case "all"
            (assert-true (table:all? < (table '([1 2] [2 3] [3 4]))))))
        (make-test-suite "all?/key"
          (make-test-case "none"
            (assert-false (table:all?/key symbol?
                                          (table '([1 A] [2 B] [3 C])))))
          (make-test-case "some"
            (assert-false (table:all?/key symbol?
                                          (table '([1 A] [B 2] [C C])))))
          (make-test-case "all"
            (assert-true (table:all?/key symbol?
                                         (table '([A 1] [B 2] [C 3]))))))
        (make-test-suite "all?/value"
          (make-test-case "none"
            (assert-false (table:all?/value number?
                                            (table '([1 A] [2 B] [3 C])))))
          (make-test-case "some"
            (assert-false (table:all?/value number?
                                            (table '([1 A] [B 2] [C C])))))
          (make-test-case "all"
            (assert-true (table:all?/value number?
                                           (table '([A 1] [B 2] [C 3]))))))
        (make-test-suite "any?"
          (make-test-case "none"
            (assert-false (table:any? < (table '([1 1] [2 2] [3 3])))))
          (make-test-case "some"
            (assert-true (table:any? < (table '([1 0] [2 2] [3 4])))))
          (make-test-case "all"
            (assert-true (table:any? < (table '([1 2] [2 3] [3 4]))))))
        (make-test-suite "any?/key"
          (make-test-case "none"
            (assert-false (table:any?/key symbol?
                                          (table '([1 A] [2 B] [3 C])))))
          (make-test-case "some"
            (assert-true (table:any?/key symbol?
                                         (table '([1 A] [B 2] [C C])))))
          (make-test-case "all"
            (assert-true (table:any?/key symbol?
                                         (table '([A 1] [B 2] [C 3]))))))
        (make-test-suite "any?/value"
          (make-test-case "none"
            (assert-false (table:any?/value number?
                                            (table '([1 A] [2 B] [3 C])))))
          (make-test-case "some"
            (assert-true (table:any?/value number?
                                           (table '([1 A] [B 2] [C C])))))
          (make-test-case "all"
            (assert-true (table:any?/value number?
                                           (table '([A 1] [B 2] [C 3]))))))
        )
      (make-test-suite "combinations"
        (make-test-suite "union"
          (make-test-case "disjoint"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:union (table '([A 1] [B 2]))
                                  (table '([C 3] [D 4]))))
                    '([A 1] [B 2] [C 3] [D 4])))
          (make-test-case "overlap"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:union (table '([A 1] [B 2]))
                                  (table '([B 2] [C 3]))))
                    '([A 1] [B 2] [C 3])))
          (make-test-case "default"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:union (table `([1 ,a1]))
                                        (table `([1 ,a2]))))
                          a1)))
          (make-test-case "override"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:union (table `([1 ,a1]))
                                        (table `([1 ,a2]))
                                        (lambda (k a b) b)))
                          a2)))
          )
        (make-test-suite "union/value"
          (make-test-case "disjoint"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:union/value (table '([A 1] [B 2]))
                                        (table '([C 3] [D 4]))))
                    '([A 1] [B 2] [C 3] [D 4])))
          (make-test-case "overlap"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:union/value (table '([A 1] [B 2]))
                                        (table '([B 2] [C 3]))))
                    '([A 1] [B 2] [C 3])))
          (make-test-case "default"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:union/value (table `([1 ,a1]))
                                              (table `([1 ,a2]))))
                          a1)))
          (make-test-case "override"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:union/value (table `([1 ,a1]))
                                              (table `([1 ,a2]))
                                              (lambda (a b) b)))
                          a2)))
          )
        (make-test-suite "intersection"
          (make-test-case "disjoint"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:intersection (table '([A 1] [B 2]))
                                         (table '([C 3] [D 4]))))
                    '()))
          (make-test-case "overlap"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:intersection (table '([A 1] [B 2]))
                                         (table '([B 2] [C 3]))))
                    '([B 2])))
          (make-test-case "default"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:intersection (table `([1 ,a1]))
                                               (table `([1 ,a2]))))
                          a1)))
          (make-test-case "override"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:intersection (table `([1 ,a1]))
                                               (table `([1 ,a2]))
                                               (lambda (k a b) b)))
                          a2)))
          )
        (make-test-suite "intersection/value"
          (make-test-case "disjoint"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:intersection/value (table '([A 1] [B 2]))
                                               (table '([C 3] [D 4]))))
                    '()))
          (make-test-case "overlap"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:intersection/value (table '([A 1] [B 2]))
                                               (table '([B 2] [C 3]))))
                    '([B 2])))
          (make-test-case "default"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:intersection/value (table `([1 ,a1]))
                                                     (table `([1 ,a2]))))
                          a1)))
          (make-test-case "override"
            (let* ([a1 "a"]
                   [a2 (string-copy a1)])
              (assert-eq? (table:lookup
                           1
                           (table:intersection/value (table `([1 ,a1]))
                                                     (table `([1 ,a2]))
                                                     (lambda (a b) b)))
                          a2)))
          )
        (make-test-suite "difference"
          (make-test-case "disjoint"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:difference (table '([A 1] [B 2]))
                                       (table '([C 3] [D 4]))))
                    '([A 1] [B 2])))
          (make-test-case "overlap"
            (assert datum-bindings=?
                    (table:to-sexp
                     (table:difference (table '([A 1] [B 2]))
                                       (table '([B 2] [C 3]))))
                    '([A 1])))
          )
        )
      (make-test-suite "relations"
        (make-test-suite "subtable?"
          (make-test-case "is subtable"
            (assert-true (table:subtable? datum=?
                                          (table '([A 1] [B 2]))
                                          (table '([A 1] [B 2] [C 3])))))
          (make-test-case "missing key"
            (assert-false (table:subtable? datum=?
                                           (table '([A 1] [B 2]))
                                           (table '([B 2] [C 3])))))
          (make-test-case "bad binding"
            (assert-false (table:subtable? datum=?
                                           (table '([A 1] [B 2] [C 3]))
                                           (table '([A 1] [B 4] [C 3]))))))
        (make-test-suite "equal?"
          (make-test-case "is equal"
            (assert-true (table:equal? datum=?
                                       (table '([A 1] [B 2] [C 3]))
                                       (table '([A 1] [B 2] [C 3])))))
          (make-test-case "missing key"
            (assert-false (table:equal? datum=?
                                        (table '([A 1] [B 2] [C 3]))
                                        (table '([A 1] [B 2])))))
          (make-test-case "extra key"
            (assert-false (table:equal? datum=?
                                        (table '([A 1] [B 2]))
                                        (table '([A 1] [B 2] [C 3])))))
          (make-test-case "bad binding"
            (assert-false (table:equal? datum=?
                                        (table '([A 1] [B 2] [C 3]))
                                        (table '([A 1] [B 4] [C 3]))))))
        )
      ))

  (define test-ordered-table
    (make-table-test "Ordered" (curry table:sexp->ordered datum-compare)))

  (define test-hashed-table
    (make-table-test "Hashed" (curry table:sexp->hashed datum-hash datum=?)))

  (define test-unordered-table
    (make-table-test "Unordered" (curry table:sexp->unordered datum=?)))

  (define test-table
    (make-test-suite "Tables"
      test-ordered-table
      test-hashed-table
      test-unordered-table))

  )