;; recon-test.scm
;;
;; Test the type reconstructor for Scheme/R
;;
;; You must load Scheme+ and recon.scm before running this code.
;;
;;
;; To run the test suite, execute
;;
;; (run-tests)
;;
;;

;; Modified from FL test suite by BJR

(define test-suite '())
(define test-counter 0)
(define test-recon-failed (list 'recon-failed))
(define halt-on-error #t)

(define-datatype test-case
  (test-case int sexp type-sexp))

(define (atest-case-n atest-case)
  (match atest-case
    ((test-case n _ _) n)))

(define (atest-case-exp atest-case)
  (match atest-case
    ((test-case _ exp _) exp)))

(define (atest-case-type-sexp atest-case)
  (match atest-case
    ((test-case _ _ tsexp) tsexp)))

(define (add-test! sexp result)
  (set! test-counter (1+ test-counter))
  (set! test-suite (cons (test-case test-counter sexp result)
			 test-suite))
  unspecific)

(define (run-tests)
  (let ((passed #t))
    (for-each 
     (lambda (atest-case)
       (newline)
       (for-each display
		 (list "Running test " (atest-case-n atest-case) " ..."))
       (run-test atest-case 
		 (lambda (passed? val)
		   (if passed?
		       (display " OK!")
		       (begin (set! passed #f)
			      (test-failed atest-case val))))))
     (reverse test-suite))
    (newline)
    (if passed
	(for-each display (list "Test Suite passed -- " 
				(length test-suite)
				" test cases.")))
    unspecific))


(define (test-failed atest-case val)
  (match atest-case
    ((test-case n sexp result)
     (let ((msg (apply error-string
		       (string-append 
			"\nTest Case " (number->string n) " Failed:")
		       ""
		       (list sexp result val))))
       (if halt-on-error 
	   (error msg)
	   (display msg))))
    ))

(define (run-test test return)
  ;; Returns two values: 
  ;; * A boolean that indicates whether the actual value matched the expected one.
  ;; * The actual value of the test.
  (if (eq? (atest-case-type-sexp test) test-recon-failed)
      (let ((bool&val
	     (call-with-current-continuation
	      (lambda (k)
		(fluid-let ((standard-error-hook 
			     (lambda (condition) 
			       (k (cons #t test-recon-failed)))))
		  (cons #f (check (atest-case-prog test))))))))
	(return (car bool&val) (cdr bool&val)))
      (let ((bool&val
	     (call-with-current-continuation
	      (lambda (k)
		(fluid-let ((standard-error-hook
			     (lambda (condition) 
			       (k (cons #f (with-output-to-string
					     (lambda ()
					       (write-condition-report
						condition
						(current-output-port)))))))))
		  (let* ((ignore (reset-tvariable-counter!))
			 (recon-type (reconstruct (parse (atest-case-exp test))
						  standard-type-environment)))
		    (cons (compare-types
			   recon-type 
			   (instantiate-schema
			    (parse-schema (atest-case-type-sexp test))))
			  recon-type)))))))
	(return (car bool&val) (cdr bool&val)))))


(define (compare-types t1 t2)
  (call-with-current-continuation
   (lambda (k)
     (fluid-let ((standard-error-hook
		  (lambda (condition) 
		    (k #f))))
       (begin (unify! t1 t2)
	      #t)))))



(add-test! '(let ((g (lambda (x) x)))
	      (if (g #t) (g 1) (g 2)))
	   'int)

(add-test! '(lambda (g)
	      (if (g #t) (g 1) (g 2)))
	   test-recon-failed)

(add-test! '(lambda (f)
	      (let ((g f))
		(if (g #t) (g 1) (g 2))))
	   test-recon-failed)

(add-test! '(lambda (f)
	      (let ((g (lambda (x) (f x))))
		(if (g #t) (g 1) (g 2))))
	   test-recon-failed)


(add-test! '(letrec ((fact (lambda (n)
			     (if (= n 0)
				 1
				 (* n (fact (- n 1)))))))
	      fact)
	   '(-> (int) int))

(add-test! 
 '(letrec ((map (lambda (p l)
		  (if (null? l)
		      (null)
		      (cons (p (car l))
			    (map p (cdr l)))))))
    map)
 '(generic (?t-17 ?result-16)
    (-> ((-> (?t-17) ?result-16) (list-of ?t-17)) (list-of ?result-16))))

(add-test! '(lambda (x y)
	      (letrec ((map (lambda (p l)
			      (if (null? l)
				  (null)
				  (cons (p (car l))
					(map p (cdr l)))))))
		(append x
			(map (lambda (y-elt) 
			       (if y-elt 1 0))
			     y))))
	   '(-> ((list-of int) (list-of bool)) (list-of int)))                

(add-test! '(letrec ((^ (lambda (p n)
			  (if (= n 0)
			      (lambda (x) x)
			      (lambda (x)
				(p ((^ p (- n 1)) x)))))))
	      ^)
	   '(generic (?x-11) (-> ((-> (?x-11) ?x-11) int) (-> (?x-11) ?x-11))))


; Functions defined by letrec can be used polymorphically in the body
; of the letrec.

(add-test! '(letrec ((g (lambda (x) x)))
	      (if (g #t) (g 1) (g 2)))
	   'int)

; ... but letrec definitions aren't polymorphic over themselves.

;Should fail
(add-test! '(letrec ((g (lambda (x) x))
		     (h (lambda () (if (g #t) (g 1) (g 2)))))
	      (if (g #t) (g 1) (g 2)))
	   test-recon-failed)

; Should fail
(add-test! '(letrec ((f (lambda (x) x))
		     (g (lambda () (f 1))))
	      (f #t))
	   test-recon-failed)

; A number of potential LETREC bugs are found by the following simple test,
; which should fail.
(add-test! '(letrec ((a (lambda () 3))
		     (b (lambda () (if (a) 1 2))))
	      (b))
	   test-recon-failed)

; Self-application should fail ...
(add-test! '(lambda (f) (f f))
	   test-recon-failed)

; ... unless we know what we're self-applying
;
(add-test! '(let ((twice (lambda (f) (lambda (x) (f (f x))))))
	      (twice twice))
	   '(generic (?result-6) 
	      (-> ((-> (?result-6) ?result-6)) (-> (?result-6) ?result-6))))

(add-test!
  '(let ((g (lambda (x) x)))
     (if ((g g) #t) ((g g) 1) ((g g) 2)))
  'int)

; Infinite loops match any type
;
(add-test! '(letrec ((loop (lambda () (loop))))
	      (lambda (x) 
		(if x 3 (loop))))
	   '(-> (bool) int))

(add-test! '(letrec ((loop (lambda () (loop))))
	      (lambda (x) 
		(if x "three" (loop))))
	   '(-> (bool) string))

; Type clash: string vs. int
(add-test! '(letrec ((loop (lambda (b) (if b 1 (loop b)))))
	      (lambda (x) 
		(if x "three" (loop x))))
	   test-recon-failed)


;;; Hairy examples with identity

; type clash (-> (bool) bool) (-> (int) bool)
(add-test! '(lambda (x) 
	      (let ((id (lambda (a) a)))
		(let ((id2 (if #t
			       id
			       x)))
		  (if (id2 #f) (id2 3) 4))))
	   test-recon-failed)

(add-test! '((lambda (x) 
	       (let ((id (lambda (a) a)))
		 (if #t
		     id
		     x)))
	     (lambda (z) z))
	   '(generic (?z-2) (-> (?z-2) ?z-2)))


(add-test! '(lambda (x)
	      (begin (set! x 3)
		     x))
	   '(-> (int) int))

(add-test! '((lambda (+ *)
	       (primop + 1 2))
	     (lambda (x) x)
	     (lambda (x) (* x x)))
	   'int)