[Header]
open Libm

let (|>) g f = f g

let test str =
    let lexbuf = Lexing.from_string str in
    let pgm = Parser.program Lexer.start lexbuf in
    Simple_checker.check pgm

[Test]
(* 1. binary operators *)
test "((1 = 3) and (true or false))"

[Value]
M.TyBool


[Test]
(* 2. if-then-else *)
test "if false then read else 1"

[Value]
M.TyInt


[Test]
(* 3. if-then-else with non-boolean condition *)
test "if 1 then 1 else 1"

[Exception]
M.TypeError _

[Test]
(* 4. tuple projection *)
test "(1, 2).1"

[Value]
M.TyInt

[Test]
(* 5. assignment to non-loc *)
test "1 := 1"

[Exception]
M.TypeError _

[Test]
(* 6. assignment *)
test "malloc 1 := 2"

[Value]
M.TyInt

[Test]
(* 7. assignment type error *)
test "malloc 1 := true"

[Exception]
M.TypeError _

[Test]
(* 8. complex expression with type error *)
test "if !(malloc false) then 1 else (((write read)=(malloc read));read)"

[Exception]
M.TypeError _

[Test]
(* 9. let val *)
test "let val v = 1 in v end"

[Value]
M.TyInt

[Test]
(* 10. let val with function *)
test "let val f = fn x => (x + 1) in f 3 end"

[Value]
M.TyInt


[Test]
(* 11. let rec *)
test "let rec f = fn x => if (1 = x) then 1 \
   else \
    if (0 = x) then  \
     1 \
    else \
     (f (x - 1) + f (x - 2)) \
in \
 f 15 \
end"

[Value]
M.TyInt

[Test]
(* 12. let val with malloc *)
test "let val l = malloc (fn x => (1 + x)) in \
 (!l) 2 \
end "

[Value]
M.TyInt

[Test]
(* 13. higher-order function *)
test "(fn f => fn y => (fn x => x) (f y)) (fn x => x + 1) 2"

[Value]
M.TyInt


[Test]
(* 14. nested let val with nested malloc *)
test "let val x1 = malloc malloc malloc 1 in \
 let val x2 = !x1 in \
  let val x3 = !x2 in \
   (fn x => x := 3) x3 \
  end \
 end \
end"

[Value]
M.TyInt

[Test]
(* 15. sort *)
test "let
  val data = (1,(400,(29,1)))
  val bg = fn a => fn b =>
    let rec comp = fn a => fn b => fn delta =>
          if (a+delta) = b then false
          else if (a-delta) = b then true
          else comp a b (delta+1)
    in
        if a = b then false
        else comp a b 1
    end
  val sort2 = fn x =>
    let val a = x.1
        val b = x.2
    in
        if (bg a b) then (a,b) else (b,a)
    end
  val sort3 = fn x =>
    let val a = x.1
        val b = sort2 (x.2)
        val c = b.1
        val d = b.2
    in
        if (bg d a) then (c,(d,a))
        else if (bg c a) then (c,(a,d))
        else x
    end
  val sort4 = fn x =>
    let val a = x.1
        val b = sort3 (x.2)
        val c = b.1
    in
        if (bg c a) then (c, sort3 (a,b.2))
        else (a,b)
    end
  val print2 = fn x =>
    let val a = x.1
        val b = x.2
    in
        write a; write b
    end
  val print3 = fn x =>
      let val p = x.1
          val q = x.2
      in
          write (x.1); print2 (x.2)
      end
  val print4 = fn x =>
      let val p = x.1
          val q = x.2
      in write p; print3 (x.2) end
in
  print4 data; write \"sort\";
  print4 (sort4 data)
end"

[Value]
M.TyInt

[Test]
(* 16. complex expression with no type error *)
test "if !(malloc false) then 1 else 1"

[Value]
M.TyInt

[Test]
(* 17. pair type *)
test " \
let val f1 = fn x => x \
    val f2 = fn y => y \
    val p = (f1, f2) \
in \
  (p.1 \"true\", p.2 true) \
end"

[Value]
M.TyPair (M.TyString, M.TyBool)


[Test]
(* 18. complex expression with type error *)
test " \
let val g = fn x => x = true in ( \
let rec f = fn x => ( \
  if (x = 1) then (g x) else (f (x - 1))) in \
  (f 4) end \
) \
end"

[Exception]
M.TypeError _


[Test]
(* 19. location of pair type *)
test " \
let val f1 = fn x => x \
    val f2 = fn y => f1 true \
    val f3 = malloc (f1 false, f2 (malloc 2)) \
in \
  f3 \
end"

[Value]
M.TyLoc (M.TyPair (M.TyBool, M.TyBool))


[Test]
(* 20. complex expression with let val and let rec *)
test "let val g = fn x => (x = true) in \
let rec f = fn x => ( \
  if (x = 1) then (g (x=1)) else (f (x - 1)) \
  ) in \
  f 4 \
end \
end"

[Value]
M.TyBool