;;; XXX: These tests depend on the properties of gensym. A proper test
;;; would consider the passed structures up to alpha conversion but
;;; that would be time consuming.

(load "gamma-scheme.cps.sld")
(import (gamma-scheme cps) test)

(define (wnl x)
  (write (cps->sexpr (core->cps x)))
  (newline))

(test-group "atomic object syntax"
  (test "constant"
        '(pass (5) () __toplevel)
        (cps->sexpr (core->cps 5)))
  (test "symbol"
        '(pass (x) () __toplevel)
        (cps->sexpr (core->cps 'x)))
  (test "quote"
        '(pass ((quote x)) () __toplevel)
        (cps->sexpr (core->cps ''x)))
  (test "multiple quotes on a symbol"
        '(pass ((quote (quote (quote x)))) () __toplevel)
        (cps->sexpr (core->cps ''''x)))
  (test "quoted constant"
        '(pass (#f) () __toplevel)
        (cps->sexpr (core->cps ''#f)))
  (test "multiple quotes on a constant"
        '(pass ((quote (quote #f))) () __toplevel)
        (cps->sexpr (core->cps '''#f))))

(test-group "function application syntax"
  (test "thunk"
        '(apply x () () __toplevel)
        (cps->sexpr (core->cps '(x))))
  (test "one symbol arg"
        '(apply x (y) () __toplevel)
        (cps->sexpr (core->cps '(x y))))
  (test "one constant arg"
        '(apply x (5) () __toplevel)
        (cps->sexpr (core->cps '(x 5))))
  (test "one quoted arg"
        '(apply x ((quote y)) () __toplevel)
        (cps->sexpr (core->cps '(x 'y))))
  (test "one quoted constant arg"
        '(apply x (#t) () __toplevel)
        (cps->sexpr (core->cps '(x '#t))))
  (test "one compound arg"
        '(apply f (x) () (kappa (__v2) __γ1 (apply x (__v2) __γ1 __toplevel)))
        (cps->sexpr (core->cps '(x (f x)))))
  (test "one constant one compound arg"
        '(apply g (x) () (kappa (__v2) __γ1 (apply f (__v2 10) __γ1 __toplevel)))
        (cps->sexpr (core->cps '(f (g x) 10))))
  (test "sequencing"
        '(apply t1 () ()
                (kappa (__v2) __γ1
                       (apply t2 () __γ1
                              (kappa (__v4) __γ3
                                     (apply t3 () __γ3
                                            (kappa (__v6) __γ5
                                                   (apply f
                                                          (__v2 __v4 __v6)
                                                          __γ5
                                                          __toplevel)))))))
        (cps->sexpr (core->cps '(f (t1) (t2) (t3))))))

(test-group "lambda syntax"
  (test "identity"
        '(pass ((lambda ((__γ1 __κ2) (x)) (pass (x) __γ1 __κ2))) () __toplevel)
        (cps->sexpr (core->cps '(lambda (x) x))))
  (test "let bind"
        '(pass ((lambda ((__γ3 __κ4) (x))
                  (pass (x) __γ3 __κ4))) ()
               (kappa (__v2) __γ1
                      (apply __v2 (y) __γ1 __toplevel)))
        (cps->sexpr (core->cps '((lambda (x) x) y)))))

(test-group "if syntax"
  (test "if #t"
        '(pass (y) () __toplevel)
        (cps->sexpr (core->cps '(if #t y z))))
  (test "if (quote #t)"
        '(pass (y) () __toplevel)
        (cps->sexpr (core->cps '(if '#t y z))))
  (test "if #f"
        '(pass (z) () __toplevel)
        (cps->sexpr (core->cps '(if #f y z))))
  (test "if (quote #f)"
        '(pass (z) () __toplevel)
        (cps->sexpr (core->cps '(if '#f y z))))
  (test "if ''#f"
        '(pass (y) () __toplevel)
        (cps->sexpr (core->cps '(if ''#f y z))))
  (test "if truthy number"
        '(pass (y) () __toplevel)
        (cps->sexpr (core->cps '(if 5 y z))))
  (test "if symbol"
        '(pass (y) () __toplevel)
        (cps->sexpr (core->cps '(if 'x y z)))))

(test-group "delimited continuation syntax"
  (test "push-prompt"
        '(pass (x) ()
               (kappa (__p1) __γ2
                      (apply cons* (__p1 __toplevel __γ2) __γ2
                             (kappa (__γ3) ignored
                                    (pass (y) __γ3 __unwind)))))
        (cps->sexpr (core->cps '(push-prompt x y))))
  (test "push-sub-continuation"
        '(pass (x) ()
               (kappa __γ1 __γ2
                      (apply in-middle (__γ1 __toplevel __γ2) __γ2
                             (kappa (__γ3) ignored
                                    (pass (y) __γ3 __unwind)))))
        (cps->sexpr (core->cps '(push-sub-continuation x y)))))

(define (e1 expr)
  (let-values (((v . rest) (eval-core expr)))
    v))

(test-group "atom eval"
  (test "constant"
        '(5)
        (e1 5))
  (test "quote"
        '('x)
        (e1 ''x))
  (test "multiple quotes on a symbol"
        '('''x)
        (e1 ''''x))
  (test "quoted constant"
        '(#f)
        (e1 ''#f))
  (test "multiple quotes on a constant"
        '(''#f)
        (e1 '''#f)))

(test-group "procedures"
  (test-assert "closure"
               (cps-closure?
                (car (e1 '(lambda (x) x)))))
  (test "apply closure"
        '(5)
        (e1 '((lambda (x) x) 5))))