(* Lecture 22: Type Checking *)
(* Author: Frank Pfenning *)

(*
use "rational.sml";
*)

(* Adding Booleans and run-time type errors *)
(* to code of lecture 21 *)
(* dispense with parsing for simplicity *)

signature EVAL0 =
sig

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp
  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp
  | Equal of exp * exp
  | Less of exp * exp

  datatype value =
    Rational of Rat.rat
  | Boolean of bool

  val toString : value -> string

  exception Error of string
  val eval : exp -> value
end;  (* signature EVAL0 *)

functor Eval0 () :> EVAL0 =
struct

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp
  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp
  | Equal of exp * exp
  | Less of exp * exp

  datatype value =
    Rational of Rat.rat
  | Boolean of bool

  exception Error of string

  fun intToString (p) =
      if p < 0 then "-" ^ Int.toString(~p) else Int.toString(p)
  fun toString' (p,1) = intToString p
    | toString' (p,q) = intToString p ^ "/" ^ intToString q
  fun toString (Rational(r)) = toString' (Rat.toInts r)
    | toString (Boolean(true)) = "true"
    | toString (Boolean(false)) = "false"

  (* val theRat : value -> Rat.rat, raises Error *)
  (* untags a value of universal type into a rational *)
  fun theRat (Rational(r)) = r
    | theRat _ = raise Error ("Runtime Type Error")

  (* val theBool : value -> bool, raises Error *)
  (* untags a value of universal type into a boolean *)
  fun theBool (Boolean(b)) = b
    | theBool _ = raise Error ("Runtime Type Error")

  fun eval' (Integer(n)) = Rational (Rat.//(n,1))
    | eval' (Plus es) = ratOp Rat.+ es
    | eval' (Minus es) = ratOp Rat.- es
    | eval' (Times es) = ratOp Rat.* es
    | eval' (Divide es) = ratOp Rat./ es
    | eval' (Neg e) = ratFun Rat.~ e

    | eval' (True) = Boolean (true)
    | eval' (False) = Boolean (false)
    | eval' (IfThenElse(e1,e2,e3)) =
      if theBool(eval' e1) then eval' e2 else eval' e3
    | eval' (Or(e1,e2)) =
        Boolean (theBool(eval' e1) orelse theBool(eval' e2))
    | eval' (And(e1,e2)) =
        Boolean (theBool(eval' e1) andalso theBool(eval' e2))

    | eval' (Equal(e1,e2)) =
        Boolean (case Rat.compare (theRat (eval' e1), theRat (eval' e2))
		 of EQUAL => true
		  | _ => false)
    | eval' (Less(e1,e2)) =
        Boolean (case Rat.compare (theRat (eval' e1), theRat (eval' e2))
		 of LESS => true
		  | _ => false)

  and ratOp func (e1,e2) =
        Rational (func (theRat (eval' e1), theRat (eval' e2)))

  and ratFun func e = Rational (func (theRat (eval' e)))

  fun eval (e) = (eval' e
                  handle Div => raise Error ("Division by Zero")
		       | Overflow => raise Error ("Arithmetic Overflow"))

end;  (* functor Eval0 *)

structure Eval0 :> EVAL0 = Eval0 ();


(* Adding Declarations and Environments *)

signature EVAL1 =
sig

  type ident = string

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp

  | Equal of exp * exp
  | Less of exp * exp

  | Let of decl list * exp
  | Var of ident

  and decl = Dec of ident * exp

  datatype value =
    Rational of Rat.rat
  | Boolean of bool

  datatype env =
    Empty
  | Bind of env * (ident * value)

  val toString : value -> string

  exception Error of string
  val eval : env * exp -> value
  val eval' : env * decl list -> env
end;  (* signature EVAL1 *)

functor Eval1 () :> EVAL1 =
struct

  type ident = string

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp

  | Equal of exp * exp
  | Less of exp * exp

  | Let of decl list * exp
  | Var of ident

  and decl = Dec of ident * exp

  datatype value =
    Rational of Rat.rat
  | Boolean of bool

  datatype env =
    Empty
  | Bind of env * (ident * value)

  exception Error of string

  fun intToString (p) =
      if p < 0 then "-" ^ Int.toString(~p) else Int.toString(p)
  fun toString' (p,1) = intToString p
    | toString' (p,q) = intToString p ^ "/" ^ intToString q
  fun toString (Rational(r)) = toString' (Rat.toInts r)
    | toString (Boolean(true)) = "true"
    | toString (Boolean(false)) = "false"

  fun lookup (x,env) =
      let fun lk (Empty) = raise Error ("Undeclared Variable")
	    | lk (Bind(env,(y,v))) = if (x = y) then v else lk env
      in lk env end

  fun theRat (Rational(r)) = r
    | theRat _ = raise Error ("Runtime Type Error")

  fun theBool (Boolean(b)) = b
    | theBool _ = raise Error ("Runtime Type Error")

  fun evalExp (env, Integer(n)) = Rational (Rat.//(n,1))
    | evalExp (env, Plus es) = ratOp env Rat.+ es
    | evalExp (env, Minus es) = ratOp env Rat.- es
    | evalExp (env, Times es) = ratOp env Rat.* es
    | evalExp (env, Divide es) = ratOp env Rat./ es
    | evalExp (env, Neg e) = ratFun env Rat.~ e

    | evalExp (env, True) = Boolean (true)
    | evalExp (env, False) = Boolean (false)
    | evalExp (env, IfThenElse(e1,e2,e3)) =
      if theBool(evalExp(env, e1))
	then evalExp (env, e2)
      else evalExp (env, e3)
    | evalExp (env, Or(e1,e2)) =
      Boolean (theBool(evalExp(env,e1)) orelse theBool(evalExp(env,e2)))
    | evalExp (env, And(e1,e2)) =
      Boolean (theBool(evalExp(env,e1)) andalso theBool(evalExp(env,e2)))

    | evalExp (env, Equal(e1,e2)) =
      Boolean (case Rat.compare (theRat (evalExp(env,e1)),
				 theRat (evalExp(env,e2)))
		 of EQUAL => true
		  | _ => false)
    | evalExp (env, Less(e1,e2)) =
      Boolean (case Rat.compare (theRat (evalExp(env,e1)),
				 theRat (evalExp(env,e2)))
		 of LESS => true
		  | _ => false)

    | evalExp (env, Let(decls,e)) =
        evalExp (evalDecls(env,decls), e)
    | evalExp (env, Var(x)) = lookup (x, env)

  and evalDecls (env, nil) = env
    | evalDecls (env, Dec(x,e)::decls) =
        evalDecls (Bind(env, (x, evalExp(env,e))), decls)

  and ratOp env func (e1,e2) =
        Rational (func (theRat (evalExp (env,e1)), theRat (evalExp (env,e2))))

  and ratFun env func e = Rational (func (theRat (evalExp (env, e))))

  fun handleErrors func x = 
      (func x
       handle Div => raise Error ("Division by Zero")
	    | Overflow => raise Error ("Arithmetic Overflow"))

  fun eval (env, e) = handleErrors evalExp (env,e)

  fun eval' (env, decls) = handleErrors evalDecls (env, decls)

end;  (* functor Eval1 *)

structure Eval1 :> EVAL1 = Eval1 ();
(*
eval (Bind (Empty, ("x",Rational(Rat.//(6,4)))), Plus(Var("x"),Integer(1)));
*)


(* Type-Checking as a separate functor *)

signature TYPE_CHECK =
sig

  type ident = string

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp

  | Equal of exp * exp
  | Less of exp * exp

  | Let of decl list * exp
  | Var of ident

  and decl = Dec of ident * exp

  datatype tp =
    Rat
  | Bool

  datatype ctx =
    Nil
  | Spec of ctx * (ident * tp)

  exception Error of string
  val toString : tp -> string

  val typeCheck :  ctx * exp -> tp
  val typeCheck' : ctx * decl list -> ctx
end;  (* signature TYPE_CHECK *)

functor TypeCheck () :> TYPE_CHECK =
struct

  type ident = string

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  | True
  | False
  | IfThenElse of exp * exp * exp
  | Or of exp * exp
  | And of exp * exp

  | Equal of exp * exp
  | Less of exp * exp

  | Let of decl list * exp
  | Var of ident

  and decl = Dec of ident * exp

  datatype tp =
    Rat
  | Bool

  datatype ctx =
    Nil
  | Spec of ctx * (ident * tp)

  exception Error of string

  fun toString (Rat) = "rat"
    | toString (Bool) = "bool"

  fun lookup (x,ctx) =
      let fun lk (Nil) = raise Error ("Undeclared Variable")
	    | lk (Spec(ctx,(y,t))) = if (x = y) then t else lk ctx
      in lk ctx end

  fun typeOf (ctx,Integer _) = Rat
    | typeOf (ctx,Plus(e1,e2)) =
         (typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Rat)
    | typeOf (ctx,Minus(e1,e2)) =
         (typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Rat)
    | typeOf (ctx,Times(e1,e2)) =
	 (typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Rat)
    | typeOf (ctx,Divide(e1,e2)) =
	 (typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Rat)
    | typeOf (ctx,Neg(e)) = (typeIs(ctx,e,Rat) ; Rat)
    | typeOf (ctx,True) = Bool
    | typeOf (ctx,False) = Bool
    | typeOf (ctx,IfThenElse(e1,e2,e3)) =
      let
	 val _ = typeIs (ctx,e1,Bool) (* raises Error *)
	 val t2 = typeOf (ctx, e2)
	 and t3 = typeOf (ctx, e3)
      in
	if t2 = t3 then t2
	else raise Error ("Conditional branches have different types")
      end
    | typeOf (ctx,Or(e1,e2)) =
        (typeIs(ctx,e1,Bool) ; typeIs (ctx,e2,Bool) ; Bool)
    | typeOf (ctx,And(e1,e2)) =
	(typeIs(ctx,e1,Bool) ; typeIs (ctx,e2,Bool) ; Bool)
    | typeOf (ctx,Equal(e1,e2)) =
	(typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Bool)
    | typeOf (ctx,Less(e1,e2)) =
	(typeIs(ctx,e1,Rat) ; typeIs (ctx,e2,Rat) ; Bool)
    | typeOf (ctx,Let(decls,e)) =
	typeOf (typeCtx (ctx,decls), e)
    | typeOf (ctx,Var(x)) = lookup (x,ctx) (* raises Error *)

  and typeCtx (ctx, nil) = ctx
    | typeCtx (ctx, Dec(x,e)::decls) =
        typeCtx (Spec(ctx, (x,typeOf(ctx,e))), decls)

  and typeIs (ctx,e,t) =
      if t = typeOf (ctx,e) then ()
      else raise Error("Type mismatch")

  fun typeCheck (ctx, e) = typeOf (ctx, e)
  fun typeCheck' (ctx, decls) = typeCtx (ctx, decls)

end;  (* functor TypeCheck *)

structure TypeCheck :> TYPE_CHECK = TypeCheck ();

(*
open TypeCheck;
(typeCheck (Spec(Nil,("x",Bool)), IfThenElse(Var("x"),True,Integer(2))) ; ())
handle Error(msg) => print (msg ^ "\n");
*)