(* A little module for type-checking in a simply-typed world *)
module TypeCheck = 
struct
  type tipe = Int_t | Bool_t | Arrow_t of tipe * tipe
  type oper = Plus | Minus | Times | Eq | Less
  type var = string
  type exp = 
      Int_e of int
    | Oper_e of exp * oper * exp
    | Bool_e of bool
    | If_e of exp * exp * exp
    | Var_e of var
    | Lambda_e of var * tipe * exp
    | App_e of exp * exp
    | Let_e of var * exp * exp

  (* 3 + 4*2 *)
  let e1 = Oper_e(Int_e 3, Plus, Oper_e (Int_e 4, Times, Int_e 2))
  (* fun (x:bool) (y:bool) -> if x then y else false *)
  let e2 = Lambda_e("x",Bool_t, 
                    Lambda_e("y",Bool_t,
                             If_e (Var_e "x", Var_e "y", Bool_e false)))
  (* fun (x:bool) (y:bool) -> if x then true else y *)
  let e3 = Lambda_e("x",Bool_t,
                    Lambda_e("y",Bool_t,
                             If_e (Var_e "x", Bool_e true, Var_e "y")))
  (* fun (x:bool) -> x *)
  let e4 = Lambda_e("x",Bool_t,Var_e "x")
  (* let and = fun x y -> if x then y else false
     let or  = fun x y -> if x then true else y
     let id = fun x -> x in 
     and (id true) (or true false)
  *)
  let e5 = Let_e("and",e2, 
                 Let_e ("or",e3,
                        Let_e ("id", e4, 
                               App_e (App_e (Var_e "and", App_e (Var_e "id", Bool_e true)),
                                      App_e (App_e (Var_e "or", Bool_e true), Bool_e false)))))
  (* let id = fun (x:bool) -> x in 
     (id id) (id 3)
  *)
  let e6 = Let_e ("id", e4, 
                  App_e (App_e (Var_e "id", Var_e "id"),
                         App_e (Var_e "id", Int_e 3)))

  (* let id1 = fun (x:int->int) -> x in 
     let id2 = fun (x:int) -> x in
     let id3 = fun (x:int) -> x in
     (id1 id2) (id3 3)
  *)
  let e7 = Let_e ("id1", Lambda_e("x",Arrow_t(Int_t,Int_t),Var_e "x"), 
                  Let_e ("id2",Lambda_e("x",Int_t,Var_e "x"),
                         Let_e ("id3",Lambda_e("x",Int_t,Var_e "x"),
                                App_e (App_e (Var_e "id1", Var_e "id2"),
                                       App_e (Var_e "id3", Int_e 3)))))

  let rec string_of_tipe t = 
    match t with 
      | Int_t -> "int"
      | Bool_t -> "bool"
      | Arrow_t (t1,t2) -> 
          "(" ^ (string_of_tipe t1) ^ "->" ^ (string_of_tipe t2) ^ ")"

  (* A little evaluator for our language *)
  type 'a env = (var * 'a) list

  type value = 
      Int_v of int
    | Bool_v of bool
    | Lambda_v of value env * var * exp

  exception TypeError of string
  let error(s:string) = raise (TypeError s)

  let extend (env:'a env) (x:var) (v:'a) : 'a env = (x,v)::env

  let rec lookup (env:'a env) (x:var) : 'a = 
    match env with 
      | [] -> error ("unbound variable "^x)
      | (y,v)::rest -> if x = y then v else lookup rest x

  let apply_oper (oper:oper) (v1:value) (v2:value) : value = 
    match oper, v1, v2 with 
      | Plus, Int_v i1, Int_v i2 -> Int_v (i1+i2)
      | Minus, Int_v i1, Int_v i2 -> Int_v (i1-i2)
      | Times, Int_v i1, Int_v i2 -> Int_v (i1*i2)
      | Eq, Int_v i1, Int_v i2 -> Bool_v (i1 = i2)
      | Less, Int_v i1, Int_v i2 -> Bool_v (i1 < i2)
      | _, _, _ -> error "expecting integer operands"

  let rec eval (e:exp) (env:value env) : value = 
    match e with 
      | Int_e i -> Int_v i
      | Oper_e (e1,oper,e2) -> apply_oper oper (eval e1 env) (eval e2 env)
      | Bool_e b -> Bool_v b
      | If_e (e1,e2,e3) -> 
          (match eval e1 env with 
             | Bool_v b -> if b then eval e2 env else eval e3 env
             | _ -> error "expecting boolean")
      | Var_e x -> lookup env x
      | Lambda_e (x1,t1,e1) -> Lambda_v (env,x1,e1)
      | App_e (e1,e2) -> 
          (match eval e1 env, eval e2 env with 
             | Lambda_v (env',x',e'), v' -> eval e' (extend env' x' v')
             | _ -> error "expecting function")
      | Let_e (x,e1,e2) -> 
          eval e2 (extend env x (eval e1 env))

  (* A little type-checker for our language *)
  let tapply_oper (oper:oper) (t1:tipe) (t2:tipe) : tipe = 
    match oper, t1, t2 with 
      | Plus, Int_t, Int_t -> Int_t
      | Minus, Int_t, Int_t -> Int_t
      | Times, Int_t, Int_t -> Int_t
      | Eq, Int_t, Int_t -> Bool_t
      | Less, Int_t, Int_t -> Bool_t
      | _, t1, t2 -> 
          error (Printf.sprintf "expecting integer operands but got %s and %s"
                   (string_of_tipe t1) (string_of_tipe t2))

  let rec tcheck (e:exp) (env:tipe env) : tipe = 
    match e with 
      | Int_e _ -> Int_t
      | Oper_e (e1,oper,e2) -> tapply_oper oper (tcheck e1 env) (tcheck e2 env)
      | Bool_e _ -> Bool_t
      | If_e (e1,e2,e3) -> 
          (match tcheck e1 env with 
             | Bool_t -> 
                 let t2 = tcheck e2 env in 
                 let t3 = tcheck e3 env in 
                   if t2 = t3 then t2 else 
                     error (Printf.sprintf "types of conditional don't agree: %s <> %s"
                              (string_of_tipe t2) (string_of_tipe t3))
             | t -> error (Printf.sprintf "expecting boolean test but found %s"
                          (string_of_tipe t)))
      | Var_e x -> lookup env x 
      | Lambda_e (x1,t1,e1) -> Arrow_t (t1, tcheck e1 (extend env x1 t1))
      | App_e (e1,e2) -> 
          (match tcheck e1 env, tcheck e2 env with 
             | Arrow_t (t1,t2), t -> 
                 if t1 = t then t2 else 
                   error (Printf.sprintf "expecting argument type %s but found %s" 
                            (string_of_tipe t1) (string_of_tipe t))
             | t, _ -> error (Printf.sprintf "expecting function type but found %s"
                                (string_of_tipe t)))
      | Let_e (x,e1,e2) -> 
          tcheck e2 (extend env x (tcheck e1 env))
end

(* This module is similar to the above, but does type inference instead of
   type-checking.  However, it does not yet support polymorphism (see below).
*)
module SimpleTypeInfer = 
struct
  (* we add a "guess" type -- this represents some unknown type which may later
     be constrained based on where it appears and how it's used. *)
  type tipe = Int_t | Bool_t | Arrow_t of tipe * tipe 
              | Guess_t of int * (tipe option ref)
  type oper = Plus | Minus | Times | Eq | Less
  type var = string
  type exp = 
      Int_e of int
    | Oper_e of exp * oper * exp
    | Bool_e of bool
    | If_e of exp * exp * exp
    | Var_e of var
      (* we no longer have to decorate lambdas with their domain's type *)
    | Lambda_e of var * exp
    | App_e of exp * exp
    | Let_e of var * exp * exp

  (* 3 + 4*2 *)
  let e1 = Oper_e(Int_e 3, Plus, Oper_e (Int_e 4, Times, Int_e 2))
  (* fun x y -> if x then y else false *)
  let e2 = Lambda_e("x",Lambda_e("y",If_e (Var_e "x", Var_e "y", Bool_e false)))
  (* fun x y -> if x then true else y *)
  let e3 = Lambda_e("x",Lambda_e("y",If_e (Var_e "x", Bool_e true, Var_e "y")))
  (* fun x -> x *)
  let e4 = Lambda_e("x",Var_e "x")
  (* let and = fun x y -> if x then y else false
     let or  = fun x y -> if x then true else y
     let id = fun x -> x in 
     and (id true) (or true false)
  *)
  let e5 = Let_e("and",e2, 
                 Let_e ("or",e3,
                        Let_e ("id", e4, 
                               App_e (App_e (Var_e "and", App_e (Var_e "id", Bool_e true)),
                                      App_e (App_e (Var_e "or", Bool_e true), Bool_e false)))))

  (* let id = fun x -> x in 
     (id id) (id 3)
  *)
  let e6 = Let_e ("id", e4, 
                  App_e (App_e (Var_e "id", Var_e "id"),
                         App_e (Var_e "id", Int_e 3)))

  (* let id1 = fun x -> x in 
     let id2 = fun x -> x in
     let id3 = fun x -> x in
     (id1 id2) (id3 3)
  *)
  let e7 = Let_e ("id1", Lambda_e("x",Var_e "x"), 
                  Let_e ("id2",Lambda_e("x",Var_e "x"),
                         Let_e ("id3",Lambda_e("x",Var_e "x"),
                                App_e (App_e (Var_e "id1", Var_e "id2"),
                                       App_e (Var_e "id3", Int_e 3)))))

  let rec string_of_tipe t = 
    match t with 
      | Int_t -> "int"
      | Bool_t -> "bool"
      | Arrow_t (t1,t2) -> 
          "(" ^ (string_of_tipe t1) ^ "->" ^ (string_of_tipe t2) ^ ")"
      | Guess_t (i,{contents = None}) -> Printf.sprintf "?%d" i
      | Guess_t (_,{contents = Some t}) -> string_of_tipe t

  type 'a env = (var * 'a) list

  type value = 
      Int_v of int
    | Bool_v of bool
    | Lambda_v of value env * var * exp

  exception TypeError of string
  let error(s:string) = raise (TypeError s)

  let extend (env:'a env) (x:var) (v:'a) : 'a env = (x,v)::env

  let rec lookup (env:'a env) (x:var) : 'a = 
    match env with 
      | [] -> error ("unbound variable" ^ x)
      | (y,v)::rest -> if x = y then v else lookup rest x

  let apply_oper (oper:oper) (v1:value) (v2:value) : value = 
    match oper, v1, v2 with 
      | Plus, Int_v i1, Int_v i2 -> Int_v (i1+i2)
      | Minus, Int_v i1, Int_v i2 -> Int_v (i1-i2)
      | Times, Int_v i1, Int_v i2 -> Int_v (i1*i2)
      | Eq, Int_v i1, Int_v i2 -> Bool_v (i1 = i2)
      | Less, Int_v i1, Int_v i2 -> Bool_v (i1 < i2)
      | _, _, _ -> error "expecting integer operands"

  let rec eval (e:exp) (env:value env) : value = 
    match e with 
      | Int_e i -> Int_v i
      | Oper_e (e1,oper,e2) -> apply_oper oper (eval e1 env) (eval e2 env)
      | Bool_e b -> Bool_v b
      | If_e (e1,e2,e3) -> 
          (match eval e1 env with 
             | Bool_v b -> if b then eval e2 env else eval e3 env
             | _ -> error "expecting boolean test")
      | Var_e x -> lookup env x
      | Lambda_e (x1,e1) -> Lambda_v (env,x1,e1)
      | App_e (e1,e2) -> 
          (match eval e1 env, eval e2 env with 
             | Lambda_v (env',x',e'), v' -> eval e' (extend env' x' v')
             | _ -> error "expecting function")
      | Let_e (x,e1,e2) -> 
          eval e2 (extend env x (eval e1 env))

  (* code for generating a fresh guess -- the number is only used for
     printing, so we can see which guesses share and which are distinct. *)
  let guess_counter = ref 0 
  let fresh_guess () : tipe = 
    let c = !guess_counter in 
      guess_counter := c + 1 ; 
      Guess_t (c, ref None)

  (* path compression -- compress a path of constrained guesses, so that 
     the guess refers to the most constrained type. *)
  let rec compress (t:tipe) : tipe = 
    match t with 
      | Guess_t (_, ({contents = Some t'} as r)) -> 
          let t'' = compress t' in 
            r := (Some t'') ; 
            t''
      | Guess_t (_,{contents = None}) | Int_t | Bool_t 
      | Arrow_t (_,_) -> t

  (* occurs check -- determine if a guess is in a type *)
  let rec occurs (r:tipe option ref) (t:tipe) : bool = 
    match t with 
      | Guess_t (_,r') -> r == r'
      | Arrow_t (t1,t2) -> occurs r t1 || occurs r t2
      | Int_t | Bool_t -> false

  (* force two types to be equal by constraining guesses appropriately. *)
  let rec unify (t1:tipe) (t2:tipe) : unit = 
    if t1 == t2 then () else
    match compress t1, compress t2 with 
      | Guess_t (_,({contents = None} as r)), t 
      | t, Guess_t (_,({contents = None} as r)) -> 
          (* if the guess already occurs in t, and if t is not equal to the
             guess, then we have an equation of the form:
               g = g -> t2 or
               g = t2 -> g, 
             which has no finite solution.  So we cannot satisfy the constraints *)
          if occurs r t then 
            error (Printf.sprintf "occurs check failed:  %s <> %s" 
                     (string_of_tipe t1) (string_of_tipe t2))
          else r := (Some t)
      | Arrow_t (t1a,t1b), Arrow_t (t2a,t2b) -> 
          unify t1a t2a ; 
          unify t1b t2b
      | Bool_t, Bool_t -> ()
      | Int_t, Int_t -> ()
      | t1, t2 -> 
          error (Printf.sprintf "unify failure: %s <> %s" (string_of_tipe t1) (string_of_tipe t2))

  let tapply_oper (oper:oper) (t1:tipe) (t2:tipe) : tipe = 
    match oper with 
      | Plus | Minus | Times -> 
          (unify t1 Int_t ; unify t2 Int_t ; Int_t)
      | Eq | Less -> 
          (unify t1 Int_t ; unify t2 Int_t ; Bool_t)

  let rec tinfer (e:exp) (env:tipe env) : tipe = 
    match e with 
      | Int_e _ -> Int_t
      | Oper_e (e1,oper,e2) -> tapply_oper oper (tinfer e1 env) (tinfer e2 env)
      | Bool_e _ -> Bool_t
      | If_e (e1,e2,e3) -> 
          unify (tinfer e1 env) Bool_t ; 
          (* constrain the types of e2 and e3 to be equal *)
          let t2 = tinfer e2 env in 
          let t3 = tinfer e3 env in 
            unify t2 t3 ; 
            t2
      | Var_e x -> lookup env x 
      | Lambda_e (x1,e1) -> 
          let g = fresh_guess() in 
            Arrow_t (g, tinfer e1 (extend env x1 g))
      | App_e (e1,e2) -> 
          let t1 = tinfer e1 env in 
          let t2 = tinfer e2 env in 
          let g = fresh_guess() in 
            unify t1 (Arrow_t (t2, g)) ; 
            g 
      | Let_e (x,e1,e2) -> 
          tinfer e2 (extend env x (tinfer e1 env))

end

module PolyTypeInfer = 
struct
  type tvar = string
  type tipe = Int_t | Bool_t | Arrow_t of tipe * tipe 
              | Guess_t of int * (tipe option ref) | Tvar_t of tvar
  type scheme = Forall of (tvar list) * tipe
  type oper = Plus | Minus | Times | Eq | Less
  type var = string
  type exp = 
      Int_e of int
    | Oper_e of exp * oper * exp
    | Bool_e of bool
    | If_e of exp * exp * exp
    | Var_e of var
    | Lambda_e of var * exp
    | App_e of exp * exp
    | Let_e of var * exp * exp

  (* 3 + 4*2 *)
  let e1 = Oper_e(Int_e 3, Plus, Oper_e (Int_e 4, Times, Int_e 2))
  (* fun x y -> if x then y else false *)
  let e2 = Lambda_e("x",Lambda_e("y",If_e (Var_e "x", Var_e "y", Bool_e false)))
  (* fun x y -> if x then true else y *)
  let e3 = Lambda_e("x",Lambda_e("y",If_e (Var_e "x", Bool_e true, Var_e "y")))
  (* fun x -> x *)
  let e4 = Lambda_e("x",Var_e "x")
  (* let and = fun x y -> if x then y else false
     let or  = fun x y -> if x then true else y
     let id = fun x -> x in 
     and (id true) (or true false)
  *)
  let e5 = Let_e("and",e2, 
                 Let_e ("or",e3,
                        Let_e ("id", e4, 
                               App_e (App_e (Var_e "and", App_e (Var_e "id", Bool_e true)),
                                      App_e (App_e (Var_e "or", Bool_e true), Bool_e false)))))

  (* let id = fun x -> x in 
     (id id) (id 3)
  *)
  let e6 = Let_e ("id", e4, 
                  App_e (App_e (Var_e "id", Var_e "id"),
                         App_e (Var_e "id", Int_e 3)))

  let rec string_of_tipe t = 
    match t with 
      | Int_t -> "int"
      | Bool_t -> "bool"
      | Arrow_t (t1,t2) -> 
          "(" ^ (string_of_tipe t1) ^ "->" ^ (string_of_tipe t2) ^ ")"
      | Guess_t (i,{contents = None}) -> Printf.sprintf "?%d" i
      | Guess_t (_,{contents = Some t}) -> string_of_tipe t
      | Tvar_t x -> Printf.sprintf "'%s" x

  type 'a env = (var * 'a) list

  type value = 
      Int_v of int
    | Bool_v of bool
    | Lambda_v of value env * var * exp

  exception TypeError of string
  let error(s:string) = raise (TypeError s)

  let extend (env:'a env) (x:var) (v:'a) : 'a env = (x,v)::env

  let rec lookup (env:'a env) (x:var) : 'a = 
    match env with 
      | [] -> error ("unbound variable " ^ x)
      | (y,v)::rest -> if x = y then v else lookup rest x

  let apply_oper (oper:oper) (v1:value) (v2:value) : value = 
    match oper, v1, v2 with 
      | Plus, Int_v i1, Int_v i2 -> Int_v (i1+i2)
      | Minus, Int_v i1, Int_v i2 -> Int_v (i1-i2)
      | Times, Int_v i1, Int_v i2 -> Int_v (i1*i2)
      | Eq, Int_v i1, Int_v i2 -> Bool_v (i1 = i2)
      | Less, Int_v i1, Int_v i2 -> Bool_v (i1 < i2)
      | _, _, _ -> error "expecting integer operands"

  let rec eval (e:exp) (env:value env) : value = 
    match e with 
      | Int_e i -> Int_v i
      | Oper_e (e1,oper,e2) -> apply_oper oper (eval e1 env) (eval e2 env)
      | Bool_e b -> Bool_v b
      | If_e (e1,e2,e3) -> 
          (match eval e1 env with 
             | Bool_v b -> if b then eval e2 env else eval e3 env
             | _ -> error "expecting boolean test")
      | Var_e x -> lookup env x
      | Lambda_e (x1,e1) -> Lambda_v (env,x1,e1)
      | App_e (e1,e2) -> 
          (match eval e1 env, eval e2 env with 
             | Lambda_v (env',x',e'), v' -> eval e' (extend env' x' v')
             | _ -> error "expecting function")
      | Let_e (x,e1,e2) -> 
          eval e2 (extend env x (eval e1 env))

  let guess_counter = ref 0 
  let fresh_guess () : tipe = 
    let c = !guess_counter in 
      guess_counter := c + 1 ; 
      Guess_t (c, ref None)

  let rec compress (t:tipe) : tipe = 
    match t with 
      | Guess_t (_, ({contents = Some t'} as r)) -> 
          let t'' = compress t' in 
            r := (Some t'') ; 
            t''
      | Guess_t (_, {contents = None}) | Int_t | Bool_t 
      | Arrow_t (_,_) | Tvar_t _ -> t

  let rec occurs (r:tipe option ref) (t:tipe) : bool = 
    match t with 
      | Guess_t (_,r') -> r == r'
      | Arrow_t (t1,t2) -> occurs r t1 || occurs r t2
      | Int_t | Bool_t | Tvar_t _ -> false

  (* for each (x,t') in s, substitute t' for x in t *)
  let rec subst_tvars (s: (tvar*tipe) list) (t:tipe) : tipe = 
    let t = compress t in 
    match t with 
      | Tvar_t x -> (try List.assoc x s with Not_found -> t)
      | Arrow_t (t1,t2) -> Arrow_t (subst_tvars s t1, subst_tvars s t2)
      | Guess_t _ | Bool_t | Int_t -> t

  (* generate fresh guesses for each of the type variables in a type scheme *)
  let instantiate (s:scheme) : tipe = 
    let Forall (tvs,t) = s in 
    let subst = List.map (fun a -> (a,fresh_guess())) tvs in
      subst_tvars subst t

  let union xs ys = 
    List.fold_right (fun x ys -> if List.mem x ys then ys else x::ys) xs ys

  let difference xs ys = 
    List.fold_right (fun x xs -> if List.mem x ys then xs else x::xs) xs [] 

  let fresh_tvar = 
    let counter = ref 0 in 
      fun () -> 
        let c = !counter in 
        counter := c + 1 ; 
          Printf.sprintf "'a%d" c

  (* collect all of the guesses in a type *)
  let rec tipe_guesses (t:tipe) : (tipe option ref) list = 
    let t = compress t in
    match t with 
      | Guess_t (_,r) -> [r]
      | Tvar_t _ | Int_t | Bool_t -> []
      | Arrow_t (t1,t2) -> union (tipe_guesses t1) (tipe_guesses t2)

  (* collect all of the guesses in a scheme *)
  let scheme_guesses (s:scheme) : (tipe option ref) list = 
    let Forall (_,t) = s in tipe_guesses t

  (* for each (g,'a) in gts, substitute 'a for g in the type t *)
  let rec subst_guesses (gts : (tipe option ref * tvar) list) (t:tipe) : tipe = 
    let t = compress t in 
    match t with 
      | Guess_t (_,r) -> (try Tvar_t (List.assoc r gts) with Not_found -> t)
      | Arrow_t (t1,t2) -> Arrow_t (subst_guesses gts t1, subst_guesses gts t2)
      | Tvar_t _ | Bool_t | Int_t -> t

  (* the heart of polymorphism *)
  let generalize (env:scheme env) (t:tipe) : scheme = 
    (* find the set of all guesses in t -- these are candidates for generalization *)
    let t_gs = tipe_guesses t in 
    (* find the set of all guesses in the type environment -- we must not generalize
       these guesses because they may later become constrained. *)
    let env_gs = List.fold_right (fun (_,t) gs -> union (scheme_guesses t) gs) env [] in 
    (* subtract the environment's guesses from the t's guesses to get the final 
       set of guesses we can generalize. *)
    let gs = difference t_gs env_gs in 
    (* generate a fresh type variable for each of the guesses *)
    let gs_and_tvs = List.map (fun g -> (g,fresh_tvar())) gs in 
    let tvs = List.map snd gs_and_tvs in 
    (* substitute the type variables for the guesses *)
    let t' = subst_guesses gs_and_tvs t in 
      (* return the type scheme that quantifies over the new type variables *)
      Forall (tvs,t')

  let rec unify (t1:tipe) (t2:tipe) : unit = 
    if t1 == t2 then () else
    match compress t1, compress t2 with 
      | Guess_t (_,({contents = None} as r)), t 
      | t, Guess_t (_,({contents = None} as r)) -> 
          if occurs r t then 
            error (Printf.sprintf "occurs check failed:  %s <> %s" 
                     (string_of_tipe t1) (string_of_tipe t2))
          else r := (Some t)
      | Arrow_t (t1a,t1b), Arrow_t (t2a,t2b) -> 
          unify t1a t2a ; unify t1b t2b
      | Bool_t, Bool_t -> ()
      | Int_t, Int_t -> ()
      | t1, t2 -> 
          error (Printf.sprintf "unify failure: %s <> %s" (string_of_tipe t1) (string_of_tipe t2))

  let tapply_oper (oper:oper) (t1:tipe) (t2:tipe) : tipe = 
    match oper with 
      | Plus | Minus | Times -> 
          (unify t1 Int_t ; unify t2 Int_t ; Int_t)
      | Eq | Less -> 
          (unify t1 Int_t ; unify t2 Int_t ; Bool_t)

  (* notice that the type environment maps each variable to a type scheme. *)
  let rec tinfer (e:exp) (env:scheme env) : tipe = 
    match e with 
      | Int_e _ -> Int_t
      | Oper_e (e1,oper,e2) -> tapply_oper oper (tinfer e1 env) (tinfer e2 env)
      | Bool_e _ -> Bool_t
      | If_e (e1,e2,e3) -> 
          unify (tinfer e1 env) Bool_t ; 
          let t2 = tinfer e2 env in 
          let t3 = tinfer e3 env in 
            unify t2 t3 ; 
            t2
      (* we must instantiate the type scheme associated with x *)
      | Var_e x -> instantiate (lookup env x)
      | Lambda_e (x1,e1) -> 
          (* we don't generalize on a lambda -- but we could! *)
          let g = fresh_guess() in 
            Arrow_t (g, tinfer e1 (extend env x1 (Forall ([],g))))
      | App_e (e1,e2) -> 
          let t1 = tinfer e1 env in 
          let t2 = tinfer e2 env in 
          let g = fresh_guess() in 
            unify t1 (Arrow_t (t2, g)) ; 
            g 
      | Let_e (x,e1,e2) -> 
          let t1 = tinfer e1 env in 
          (* here, we generalize the type of e1 to get a polymorphic type
             scheme to be used in e2. *)
          let s = generalize env t1 in 
          tinfer e2 (extend env x s)
end

(* Potential Exercises:

1. Extend the languages with support for pairs.  You should add a pair type,
   a pair expression, and operations fst and snd for getting the first and
   second component of a pair respectively.

2. Extend the languages with support for lists.  You should add a list type,
   an empty list expression, a cons expression, and a match expression of
   the form:

     ListMatch_e of exp * exp * (var * var * exp)

   Here, the first expression is a list, the second expression represents
   what to do in the case the list is empty, and the third case represents
   what to do when the list has a head and tail, which we bind to the two
   variables before running the associated expression.  

3. Find a counterexample which shows why it is not safe to generalize a
   guess which occurs in the environment.  The best way to demonstrate this
   is to create a new module BrokenInfer, which is just like PolyInferType
   but that does not subtract the environment's guesses before generalizing.
   Then give an expression which type-checks, but which when run, produces
   a type-error.

4. [Hard] Add floating point values and operations to the language and 
   modify inference to support overloaded operations.  For instance, 
   "+" and "*" should be usable for both integer and floating point
   operands.  

*)