open Format
open Syntax
open Support.Error
open Support.Pervasive

(* ------------------------   EVALUATION  ------------------------ *)

let rec isval ctx t = match t with
    TmTrue(_)  -> true
  | TmFalse(_) -> true
  | TmAbs(_,_,_,_) -> true
  | _ -> false

exception NoRuleApplies

let rec eval1 ctx t = match t with
    TmLet(fi,x,v1,t2) when isval ctx v1 ->
      termSubstTop v1 t2
  | TmLet(fi,x,TmRaise(_,v1),_) when isval ctx v1 ->
      TmRaise(fi,v1)
  | TmLet(fi,x,t1,t2) ->
      let t1' = eval1 ctx t1 in
      TmLet(fi, x, t1', t2)
  | TmApp(fi,TmAbs(_,x,tyT11,t12),v2) when isval ctx v2 ->
      termSubstTop v2 t12
  | TmApp(fi,TmRaise(_,v11),t2) when isval ctx v11 ->
      TmRaise(fi,v11)
  | TmApp(fi,v1,TmRaise(_,v21)) when isval ctx v1 && isval ctx v21 ->
      TmRaise(fi,v21)
  | TmApp(fi,v1,t2) when isval ctx v1 ->
      let t2' = eval1 ctx t2 in
      TmApp(fi, v1, t2')
  | TmApp(fi,t1,t2) ->
      let t1' = eval1 ctx t1 in
      TmApp(fi, t1', t2)
  | TmIf(_,TmTrue(_),t2,t3) ->
      t2
  | TmIf(_,TmFalse(_),t2,t3) ->
      t3
  | TmIf(fi,TmRaise(_,v1),_,_) when isval ctx v1 ->
      TmRaise(fi,v1)
  | TmIf(fi,t1,t2,t3) ->
      let t1' = eval1 ctx t1 in
      TmIf(fi, t1', t2, t3)
  | TmTry(fi,v1,t2) when isval ctx v1 ->
      v1
  | TmTry(fi,TmRaise(_,v11),t2) when isval ctx v11 ->
      TmApp(fi,t2,v11)
  | TmTry(fi,t1,t2) ->
      let t1' = eval1 ctx t1 in
      TmTry(fi,t1',t2)
  | TmRaise(fi,TmRaise(_,v11)) when isval ctx v11 -> 
      TmRaise(fi,v11)
  | TmRaise(fi,t1) -> 
      let t1' = eval1 ctx t1 in
      TmRaise(fi,t1')
  | _ -> 
      raise NoRuleApplies

let rec eval ctx t =
  try let t' = eval1 ctx t
      in eval ctx t'
  with NoRuleApplies -> t

(* ------------------------   TYPING  ------------------------ *)

(* Check if two types can be made equivalent, possibly after promoting
any appearances of TyBot. If so, return (Some t), where t is the
common type after any promotions;  otherwise, return None. *)

let rec tyequiv t1 t2 =
  match (t1,t2) with
    (TyBot,_) -> Some t2
  | (_,TyBot) -> Some t1
  | (TyBool,TyBool) -> Some TyBool
  | (TyArr(t11,t12),TyArr(t21,t22)) -> 
      (match (tyequiv t11 t21,tyequiv t12 t22) with
         (Some t1',Some t2') -> Some (TyArr(t1',t2'))
       | _ -> None)
  | (_,_) -> None

let rec typeof ctx t =
  match t with
    TmVar(fi,i,_) -> getTypeFromContext fi ctx i
  | TmLet(fi,x,t1,t2) ->
      let tyT1 = typeof ctx t1 in
      let ctx' = addbinding ctx x (VarBind(tyT1)) in
      typeof ctx' t2
  | TmAbs(fi,x,tyT1,t2) ->
      let ctx' = addbinding ctx x (VarBind(tyT1)) in
      let tyT2 = typeof ctx' t2 in
      TyArr(tyT1, tyT2)
  | TmApp(fi,t1,t2) ->
      let tyT1 = typeof ctx t1 in
      let tyT2 = typeof ctx t2 in
      (match tyequiv tyT1 (TyArr(TyBot,TyBot)) with
         Some (TyArr(tyT11,tyT12)) ->
	   (match tyequiv tyT11 tyT2 with
	      Some _ -> tyT12
            | None -> error fi "parameter type mismatch")
       | _ -> error fi "arrow type expected")
  | TmTrue(fi) -> 
      TyBool
  | TmFalse(fi) -> 
      TyBool
  | TmIf(fi,t1,t2,t3) ->
     (match tyequiv (typeof ctx t1) TyBool with
        Some _ ->  
          (match tyequiv (typeof ctx t2) (typeof ctx t3) with
             Some ty -> ty
	   | None -> error fi "arms of conditional have different types")
      | None -> error fi "guard of conditional not a boolean")
  | TmRaise(fi,t1) ->
     (match tyequiv (typeof ctx t1) tyexn with
        Some _ -> TyBot
      | None -> error fi "argument of raise not of exception type")
  | TmTry(fi,t1,t2) ->
     let tyT1 = typeof ctx t1 in
     let tyT2 = typeof ctx t2 in
     (match tyequiv tyT2 (TyArr(tyexn,tyT1)) with
        Some (TyArr(_,tyT22)) -> tyT22
      | _ -> error fi "type error in try expression")
  | TmError(_) -> assert false