;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

;;; Test code for the Goo language.
;;;
;;; See the bug list at the top of tests/driver; some things there might
;;; apply to this file instead.
;;;
;;; Also, note that the protocol-based testing code all lives here.
;;; You may want to refactor it into tests/driver if it seems general
;;; enough.

(use goo)
(use tests/driver)

(test-group slf
  (test== 1    1)
  (test== #t   #t)
  (test== #f   #f)
  (test== 'a   'a)
  (test=  '(a) '(a)))

(dv $no-value #f)

(test-group var
  (test= (dv x 1)  1)
  (test= x         1)
  (test= (set x 2) 2)
  (test= x         2))

(test-group ifc
  (test= (if #t 1 2) 1)
  (test= (if #f 1 2) 2)
  (test= (if #t 3)   3)
  (test= (if #f 4)   #f))

(test-group fun
  (test  (fun (x) x))
  (test= ((fun (x) x) 2)             2)
  (test  (fun ((x ...)) x))
  (test= ((fun ((x ...)) x) 1 2 3)   '(1 2 3))
  (test  (fun (x (y ...)) y))
  ;; (test= ((fun (x (y ...)) y) 1 2 3) '(2 3))
  )

(test-group beg
  (test= (seq)     #f)
  (test= (seq 2)   2)
  (test= (seq 2 3) 3))

(test-group lut
  (test= (let ((a 1)) a)       1)
  (test= (let ((a 2) (b a)) a) 2))

(test-group app
  (test= (+ 1 2)         3)
  (test= ((fun (x) x) 2) 2))

(test-group iterate
  (test= (rep sum ((s 0) (i 5)) (if (< i 0) s (sum (+ s 1) (- i 1)))) 6))

(test-group locals
  (test= (loc ((f (x) (g x)) (g (y) y)) (f 1)) 1))

(test-group bind-exit
  (test= (esc ret (ret 1))                   1)
  (test= (esc ret 2)                         2)
  (test= (esc ret ((fun (x r) (r x)) 3 ret)) 3))


(test-group protect
  (test= (fin 1 2)                                         1)
  (test= (let ((x 1)) (esc ret (fin (ret 1) (set x 2))) x) 2)
  (test= (let ((x 1)) (esc ret (fin      1  (set x 2))) x) 2))

;; (test-group isa 
;;   (test (isa <Any>))
;;   (test (isa (<Any>)))
;;   (test (dv Pti (isa <Any>)))
;;   (test (dv Pti2 (isa Pti)))
;;   (test (dv A (isa <Any>)))
;;   (test (dv B (isa <Any>)))
;;   (test (dv C (isa A)))
;;   (test (dv D (isa C)))
;;   (test (dv E (isa C)))
;;   (test (dv I (isa B)))
;;   (test (dv J (isa (A B))))
;;   (test= (isa? C A) #t)
;;   (test= (isa? C B) #f)
;;   (test= (isa? D C) #t)
;;   (test= (isa? E C) #t)
;;   (test= (isa? I B) #t)
;;   (test= (isa? J A) #t)
;;   (test= (isa? J B) #t)
;;   (test= (isa? J C) #f))
;; 
;; (test-group dis
;;   ;; (unset f)
;;   (test (dm (f (x A)) 'a))
;;   (test (dm (f (x B)) 'b))
;;   (test (dm (f (x C)) 'c))
;;   ;; (test (dv (f (x D)) 'd))
;;   ;; (test (dv (f (x E)) 'e))
;;   ;; (test (dv (f (x F)) 'f))
;;   (test= (f A)               a)
;;   (test= (f B)               b)
;;   (test= (f C)               c)
;;   (test= (f D)               c)
;;   (test= (f E)               c)
;;   (test= (f I)               b)
;;   ;; (test= (f J)               ambiguous)
;;   )
;; 
;; (test-group slt
;;   ;; (unset x) (unset x-setter)
;;   ;; (unset y) (unset y-setter)
;;   ;; (unset Pt) (unset p)
;;   (test   (dv Pt (isa <Any>)))
;;   (test   (dp x (Pt => <any>)))
;;   (test== (x Pt)             Nul)
;;   (test== (set (x Pt) Pt)    Pt)
;;   (test== (x Pt)             Pt)
;;   (test   (dp y (Pt => <any>)))
;;   (test   (y Pt)             Pt)
;;   (test   (dv p (isa Pt)))
;;   (test== (x p)              Pt)
;;   (test== (y p)              Pt))

;; (test-group cnd ...)

;;; DISPATCH
;;; FUNCTION REDEF

(ds def-protocol-tests (((,var ,name)) ,@tests)
  `(dm test-object (,var|(t< ,name)) (let ((group-name ',name)) ,@tests)))

(ds def-concrete-protocol-tests ((,var|,name) ,@tests)
  `(seq (def-protocol-tests (,var|,name) ,@tests)
        (test-group ,name (test-object ,name)))))

(def-protocol-tests (x|<any>)
  ;; (to-str <any> => <str>)
  )

(def-concrete-protocol-tests (x|<chr>)
  (sup x)
  ;; lower? (x|<chr> => <log>)
  ;; upper? (x|<chr> => <log>)
  ;; to-lower (x|<chr> => <chr>)
  ;; to-upper (x|<chr> => <chr>)
  ;; alpha? (x|<chr> => <log>)
  ;; digit? (x|<chr> => <log>)
  ;; to-digit (digit|<chr> => <int>)
  ;; ascii->char (n|<int> => <chr>)
  ;; char->integer (char|<chr> => <int>)
  ;; integer->char (n|<int> => <chr>)
  ;; char->ascii (char|<chr> => <int>)
  )

(def-protocol-tests (x|<num>)
  (sup x)
  (def ex (op as x _))
  (test== (pos?  (ex 1))  #t)
  (test== (pos?  (ex 0))  #f)
  (test== (pos?  (ex -1)) #f)
  (test== (neg?  (ex 1))  #f)
  (test== (neg?  (ex 0))  #f)
  (test== (neg?  (ex -1)) #t)
  (test== (zero? (ex 1))  #f)
  (test== (zero? (ex 0))  #t)
  (test== (zero? (ex -1)) #f)
  (test== (< (ex 1) (ex 2))  #t)
  (test== (< (ex -1) (ex 0)) #t)
  (test== (< (ex 2) (ex 1))  #f)
  (test== (+ (ex 1) (ex 2))  (ex 3))
  (test== (+ (ex -1) (ex 2)) (ex 1))
  (test== (- (ex 1) (ex 2))  (ex -1))
  (test== (- (ex 2) (ex 1))  (ex 1))
  (test== (* (ex 4) (ex 8))  (ex 32))
  (test== (* (ex -3) (ex 7)) (ex -21))
  ;; floor (x|<num> => <int>)
  ;; ceil (x|<num> => <int>)
  ;; round (x|<num> => <int>)
  ;; trunc (x|<num> => <int>)
  ;; floor/ (real|<num> divisor|<num> => (tup <int> rem|<num>))
  ;; ceil/ (real|<num> divisor|<num> => (tup <int> rem|<num>))
  ;; round/ (real|<num> divisor|<num> => (tup <int> rem|<num>))
  ;; trunc/ (real|<num> divisor|<num> => (tup <int> rem|<num>))
  ;; modulo (real|<num> divisor|<num> => <num>)
  ;; remainder (real|<num> divisor|<num> => <num>)
  ;; neg (x|<num> => <num>)
  ;; abs (x|<num> => <num>)
  ;; to-str (x|<num> => <str>)
  )

(def-concrete-protocol-tests (x|<int>)
  (sup x)
  (test= (| 1 2)  3)
  (test= (| 1 1)  1)
  (test= (| 1 0)  1)
  (test= (^ 1 2)  3)
  (test= (^ 1 1)  0)
  (test= (^ 1 0)  1)
  (test= (& 1 2)  0)
  (test= (& 1 1)  1)
  (test= (& 1 0)  0)
  (test= (~ 1)    -2)
  (test= (~ 0)    -1)
  (test= (~ 2)    -3)
  (test= (bit? 5 0) #t)
  (test= (bit? 5 1) #f)
  (test= (bit? 5 2) #t)
  (test= (even? 0)     #t)
  (test= (even? 1)     #f)
  (test= (even? -1)    #f)
  (test= (even? -2)    #t)
  (test= (odd? 0)      #f)
  (test= (odd? 1)      #t)
  (test= (odd? -1)     #t)
  (test= (odd? -2)     #f)
  (test= (<< 1 2)      4)
  (test= (<< 2 2)      8)
  (test= (<< -1 2)     -4)
  (test= (>> 1 2)      0)
  )

(def-concrete-protocol-tests (x|<flo>)
  (sup x)
  )

(dm col-elt-type (x|(t< <col>) => <any>) <any>)
(dm col-elt-type (x|(t< <str>) => <any>) <chr>)
(dm as-elt (c|(t< <col>) x) (as (col-elt-type c) x))
(dm fabsex (type|(t< <col>) ints|...)
  (def et (col-elt-type type))
  (app fabs type (map (fun (x) (as et x)) ints)))
(dm int-plus (x y) (+ (as <int> x) (as <int> y)))

(def-protocol-tests (x|<col>)
  (sup x)
  (def ex (op as (col-elt-type x) _))
  ;; (col (t< <col>) x|... => <any>)
  ;; (default <col> => <any>)
  (test   (fab x 0))
  ;; (col-res x y)
  (test== (isa? (key-type (nul x)) <type>) #t)
  (test== (isa? (elt-type (nul x)) <type>) #t)
  (test== (isa? (key-test (nul x)) <fun>) #t)
  (test== (nul? (fab x 0))  #t)
  (test   (nul x))
  (test=  (len (nul x)) 0)
  (test=  (nul x) (fab x 0))
  (test=  (len (fab x 0)) 0)
  (test=  (fabsex x 1 2) (fabsex x 1 2))
  (test   (fab x 5))
  (test== (elt (fabsex x 1 2) 0) (ex 1))
  (test== (elt-or (fabsex x 1 2) 2 0) 0)
  (test   (let ((res (elts (fabsex x 1 2 3) '(0 2)))) 
            (and (= (len res) 2) 
                 (== (elt-or res 0 #f) 1)
                 (== (elt-or res 2 #f) 3))))
  (test=  (dup (fabsex x 1 2)) (fabsex x 1 2))
  (test=  (sort (as <lst> (keys (fabsex x 1 2 3)))) '(0 1 2))
  (test=  (sort-by (items (fabsex x 1 2 3)) (op < (1st _) (1st _))) 
          (lst (tup 0 (ex 1)) (tup 1 (ex 2)) (tup 2 (ex 3))))
  (test=  (del (fabsex x 1 2 3) (ex 2)) (fabsex x 1 2))
  (test=  (zap (fabsex x 1 2 3)) '())
  (test=  (fill (fabsex x 1 2 3) (ex 0)) (fabsex x 0 0 0))
  (test== (mem? (fabsex x 1 2) (ex 1)) #t)
  (test== (mem? (fabsex x 1 2) (ex 0)) #f)
  (test== (any? (fun (e) (= e (ex 1))) (nul x))  #f)
  (test== (any? (fun (e) (= e (ex 1))) (fabsex x 1)) #t)
  (test== (any? (fun (e) (= e (ex 1))) (fabsex x 2)) #f)
  (test== (any? (fun (e) (= e (ex 1))) (fabsex x 1 1 1)) #t)
  (test== (any? (fun (e) (= e (ex 1))) (fabsex x 1 2 3)) #t)
  (test== (any? (fun (e) (= e (ex 1))) (fabsex x 3 2 4)) #f)
  (test== (all? (fun (e) (= e (ex 1))) (nul x))  #t)
  (test== (all? (fun (e) (= e (ex 1))) (fabsex x 1)) #t)
  (test== (all? (fun (e) (= e (ex 1))) (fabsex x 2)) #f)
  (test== (all? (fun (e) (= e (ex 1))) (fabsex x 1 1 1)) #t)
  (test== (all? (fun (e) (= e (ex 1))) (fabsex x 1 2 3)) #f)
  (test== (all? (fun (e) (= e (ex 1))) (fabsex x 3 2 4)) #f)
  (test   (seq (do (fun (e) e) (fabsex x 1 2)) #t))
  (test=  (map (fun (e) (ex (+ (as <int> e) 1))) (fabsex x 1 2)) 
          (fabsex x 2 3))
  (test=  (find (fun (x) (odd? (as <int> x))) (fabsex x 2 3)) 1)
  (test=  (find-or (fun (x) (odd? (as <int> x))) (fabsex x 2 4) 0) 0)
  (test=  (fold int-plus 0 (nul x))   0)
  (test=  (fold int-plus 0 (fabsex x 1))     1)
  (test=  (fold int-plus 0 (fabsex x 1 2))   3)
  (test=  (fold int-plus 0 (fabsex x 1 2 3)) 6)
  ;; (test=  (fold+ + (nul x))      0) ;TODO: CONDITION
  (test=  (fold+ int-plus (fabsex x 1))      (ex 1))
  (test=  (fold+ int-plus (fabsex x 1 2))    3)
  (test=  (fold+ int-plus (fabsex x 1 2 3))  6)
  ;; fip
  ;; what about len-setter?
  )

;;(def-protocol-tests (x|<bag>)
;;  (sup x)
;;   add followed by mem?
;;  )

(def-protocol-tests (x|<map>)
  (sup x)
  ;; elts of non pos int keys
  ;; col
  ;; zap
  )

(def-concrete-protocol-tests (x|<tab>)
  (sup x)
  ;; perhaps hashing functions
  ;; str hashing
  )

(def-protocol-tests (x|<seq>)
  (sup x)
  (def ex (op as (col-elt-type x) _))
  (test= (fill (fab x 4) (ex 1)) (fabsex x 1 1 1 1))
  (test= (1st (fabsex x 1 2 3 4)) (ex 1))
  (test= (2nd (fabsex x 1 2 3 4)) (ex 2))
  (test= (3rd (fabsex x 1 2 3 4)) (ex 3))
  (test= (last (fabsex x 1 2 3 4)) (ex 4))
  (test= (add (fabsex x 2 3) (ex 1)) (fabsex x 1 2 3))
  (test= (rev (fabsex x 1 2 3)) (fabsex x 3 2 1))
  (test= (cat (fabsex x 1 2) (fabsex x 3 4)) (fabsex x 1 2 3 4))
  (test= (cat (fabsex x 1 2) (fabsex x 3 4) (fabsex x 5)) (fabsex x 1 2 3 4 5))
  (test= (sub (fabsex x 1 2 3 4) 0 2) (fabsex x 1 2))
  (test= (sub (fabsex x 1 2 3 4) 1 3) (fabsex x 2 3))
  (test= (sub* (fabsex x 1 2 3 4) 2) (fabsex x 3 4))
  (test= (del-dups (fabsex x 1 2 3 4)) (fabsex x 1 2 3 4))
  (test= (del-dups (fabsex x 1 2 1 1)) (fabsex x 1 2))
  (test= (del-vals (fabsex x 1 2 3 4) (ex 2)) (fabsex x 1 3 4))
  (test= (del-vals (fabsex x 1 2 2 3) (ex 2)) (fabsex x 1 3))
  (test= (finds (fabsex x 1 2 3 4) (fabsex x 2 3))     1)
  (test= (finds (fabsex x 1 2 3 4) (fabsex x 1 2 3 4)) 0)
  (test= (finds (fabsex x 1 2 3) (fabsex x 1 2 3 4))   #f)
  (test= (finds (fabsex x 1 2 3 4) (fabsex x 2 4))     #f)
  (test= (1st (pop (push (fabsex x 1) (ex 0)))) (fabsex x 1))
  (test= (2nd (pop (push (fabsex x 1) (ex 0)))) (ex 0))
  (test= (1st (pop (push (fabsex x 1 2) (ex 0)))) (fabsex x 1 2))
  (test= (2nd (pop (push (fabsex x 1 2) (ex 0)))) (ex 0))
  (test= (ins (fabsex x 1 2) (ex 0) 0) (fabsex x 0 1 2))
  (test= (ins (fabsex x 1 2) (ex 3) 2) (fabsex x 1 2 3))
  (test= (ins (fabsex x 1 2) (ex 3) 3) (fabsex x 1 2)) ;; TODO: ERROR
  (test= (pick   odd? (fabsex x 1 2 3 4)) (fabsex x 1 3))
  (test= (reject odd? (fabsex x 1 2 3 4)) (fabsex x 2 4))
  (test= (sort (fabsex x 1 4 3 2)) (fabsex x 1 2 3 4))
  (test= (sort-by (fabsex x 1 4 3 2) >) (fabsex x 4 3 2 1))
  (test= (suffix? (fabsex x 1 2 3 4) (fabsex x 3 4)) #t)
  (test= (suffix? (fabsex x 1 2 3 4) (fabsex x 3 4 5)) #f)
  (test= (suffix? (fabsex x 1 2 3 4) (fabsex x 1 2 3 4 5)) #f)
  (test= (prefix? (fabsex x 1 2 3 4) (fabsex x 1 2)) #t)
  (test= (prefix? (fabsex x 1 2 3 4) (fabsex x 0 1 2)) #f)
  (test= (prefix? (fabsex x 1 2 3 4) (fabsex x 1 2 3 4 5)) #f)
  (test= (repeat (fabsex x 1 2) 0) (fabsex x))
  (test= (repeat (fabsex x 1 2) 1) (fabsex x 1 2))
  (test= (repeat (fabsex x 1 2) 2) (fabsex x 1 2 1 2))
  (test= (len (split (fabsex x 1 0 2 0 3) (ex 0))) 3)
  (test= (join (lst (fabsex x 1 2) (fabsex x 3 4) (fabsex x 5)) (fabsex x 0))
         (fabsex x 1 2 0 3 4 0 5))
  (test= (join (split (fabsex x 1 2 0 3 4 0 5) (ex 0)) (fabsex x 0))
         (fabsex x 1 2 0 3 4 0 5))
  ;; (vals-to-str <seq>)
  )

;;; TODO: CHECK FOR MUT PROP -- TOUGH FOR LST'S

(def-protocol-tests (x|<col!>)
  (sup x)
  (def ex (op as (col-elt-type x) _))
  (test= (into (fabsex x 1 2) (fabsex x 2 3)) (fabsex x 2 3))
  ;; (elt-setter <any> <col> <any>)
  ;; (elt! <col!> <any> <fun>)
  (test= (fill! (fabsex x 1 2 3) (ex 0)) (fabsex x 0 0 0))
  (test= (del! (fabsex x 1 2 3) (ex 2)) (fabsex x 1 2))
  (test= (zap! (fabsex x 1 2)) (fabsex x))
  (test= (zap! (fabsex x 1 2)) (fabsex x))
  )

(def-protocol-tests (x|<seq!>)
  (sup x)
  (def ex (op as (col-elt-type x) _))
  (test= (add (fabsex x 2 3) (ex 1)) (fabsex x 1 2 3))
  (test= (let ((x (fabsex x 1))) (set (len x) 0) x)
         (fabsex x))
  (test= (let ((x (fabsex x 1 2))) (set (len x) 1) x)
         (fabsex x 1))
  (test= (let ((x (fabsex x 1 2))) (set (len/fill x (ex 0)) 3) x)
         (fabsex x 1 2 0))
  (test= (rev! (fabsex x 1 2 3)) (fabsex x 3 2 1))
  (test= (cat! (fabsex x 1 2) (fabsex x 3 4)) (fabsex x 1 2 3 4))
  (test= (cat! (fabsex x 1 2) (fabsex x 3 4) (fabsex x 5)) (fabsex x 1 2 3 4 5))
  (test= (1st (pop! (push! (fabsex x 1) (ex 0)))) (fabsex x 1))
  (test= (2nd (pop! (push! (fabsex x 1) (ex 0)))) (ex 0))
  (test= (1st (pop! (push! (fabsex x 1 2) (ex 0)))) (fabsex x 1 2))
  (test= (2nd (pop! (push! (fabsex x 1 2) (ex 0)))) (ex 0))
  (test= (ins! (fabsex x 1 2) (ex 0) 0) (fabsex x 0 1 2))
  (test= (ins! (fabsex x 1 2) (ex 2) 3) (fabsex x 1 2 3))
  (test= (ins! (fabsex x 1 3) (ex 1) 2) (fabsex x 1 2 3))
  (test= (set (sub (fabsex x 1 2) 0 1) (fabsex x 0)) (fabsex x 0 2))
  (test= (set (sub (fabsex x 1 2) 0 0) (fabsex x 0)) (fabsex x 0 1 2))
  (test= (set (sub (fabsex x 1 2) 0 2) (fabsex x 0)) (fabsex x 0))
  (test= (set (sub* (fabsex x 1 2) 1) (fabsex x 0)) (fabsex x 1 0))
  (test= (del-dups! (fabsex x 1 2 3 4)) (fabsex x 1 2 3 4))
  (test= (del-dups! (fabsex x 1 2 1 1)) (fabsex x 1 2))
  (test= (del-vals! (fabsex x 1 2 3 4) (ex 2)) (fabsex x 1 3 4))
  (test= (del-vals! (fabsex x 1 2 2 3) (ex 2)) (fabsex x 1 3))
  (test= (sort! (as <lst> (keys (fabsex x 1 2 3)))) '(0 1 2))
  (test= (sort-by! (items (fabsex x 1 2 3)) (op < (1st _) (1st _))) 
         (lst (tup 0 (ex 1)) (tup 1 (ex 2)) (tup 2 (ex 3))))
  )

(def-concrete-protocol-tests (x|<lst>)
  (sup x)
  ;; (assq <any> <lst> => <any>) 
  )

(def-concrete-protocol-tests (x|<tup>)
  (sup x)
  ;; (assq <any> <lst> => <any>) 
  )

(def-concrete-protocol-tests (x|<vec>)
  (sup x)
  )

(def-concrete-protocol-tests (x|<str>)
  (sup x)
  ;; <
  )

(def-protocol-tests (x|<range>) ;; TODO: concrete
  (sup x)
  ;;
  )

(def-protocol-tests (x|<step>) ;; TODO: concrete
  (sup x)
  ;;
  )

;; (def-protocol-tests (x|<assoc>)
;;   (sup x)
;;   )

(def-concrete-protocol-tests (x|<sym>)
  (sup x)
  ;; 
  )

(def-protocol-tests (x|<condition>) ;; TODO: concrete
  (sup x)
  ;; 
  )

(def-concrete-protocol-tests (x|<loc>) ;; TODO: concrete
  (sup x)
  ;; 
  )

(def-protocol-tests (x|<port>)
  (sup x)
  ;; eof-object? (x|<chr> => <log>)
  ;; open (t|(t< <port>) dat => <port>)
  ;; close (port|<port>)
  ;; with-port (,name ,port) ,@body)
  ;; 
  )

(def-protocol-tests (x|<out-port>)
  (sup x)
  ;; newline (port|<out-port>) 
  ;; force-out (port|<out-port>)
  ;; put (port|<out-port> c|<chr>)
  ;; puts (port|<out-port> s|<str>)
  )

(def-protocol-tests (x|<in-port>)
  (sup x)
  ;; get (port|<in-port> => <chr>)
  ;; peek (port|<in-port> => <chr>)
  ;; ready? (port|<in-port> => <log>)
  )

(def-protocol-tests (x|<file-in-port>) ;; TODO: concrete
  (sup x)
  ;; file-opening-error (filename|<str>)
  )

(def-protocol-tests (x|<file-out-port>) ;; TODO: concrete
  (sup x)
  )

(def-protocol-tests (x|<str-in-port>) ;; TODO: concrete
  (sup x)
  ;; port-contents (port|<string-port> => <str>)
  )

(def-protocol-tests (x|<str-out-port>) ;; TODO: concrete
  (sup x)
  )

(def-concrete-protocol-tests (x|<fun>)
  (sup x)
  ;; identity (x) x)
  ;; compose (fx|<fun> fy|<fun> => <fun>)
  ;; rcurry (f|<fun> curried|... => <fun>)
  ;; curry (f|<fun> curried|... => <fun>)
  ;; always (x => <fun>)
  ;; 
  )

