(* Revised core-calculus, explicitly typed, with subtyping *)

module Tcore = 
struct
  type id = string

  type label = id

  type var = id 

  and typ = 
      IntT
    | ArrowT of typ * typ
    | RecordT of rtyp 
    | SumT of rtyp    

  and rtyp = (label * typ) list  (* labels are sorted and unique *)

  type exp  =
      Var of var 
    | Abs of var * typ * exp
    | App of exp * exp
    | Int of int
    | Fix of (var * exp * typ) list * exp 
    | Record of row
    | Select of label * exp
    | Variant of label * exp
    | Switch of exp * row 

  and row = (label * exp) list

(* primitive operations *)

  let primops = ["Iadd";"Imul";"Ieql"]

(* Fresh variables or labels *)
  let gensym = 
    let next = ref 0 in
    fun () -> 
      let sym = "x" ^ (string_of_int (!next)) in
      incr next;
      sym


(* Bindings *)
  let eLet(x,t,e1,e2) = App(Abs(x,t,e2),e1)

(* Unit encoded as empty record *)
  let eUnit = Record []
  let tUnitT = RecordT []

(* Booleans encoded as summands *)
  let false_label = gensym() 
  let true_label = gensym()
  let tBoolT = SumT [(true_label,tUnitT);(false_label,tUnitT)]
  let eFalse = Variant(false_label,eUnit)
  let eTrue =  Variant(true_label,eUnit)
  let eIf(e,e1,e2) = 
    let d = gensym() in
    Switch(e,[(true_label,Abs(d,tUnitT,e1));(false_label,Abs(d,tUnitT,e2))])

(* Integer pairs *)
  let fst_label = gensym()
  let snd_label = gensym()
  let tPairT = RecordT [(fst_label,IntT);(snd_label,IntT)]
  let ePair(e1,e2) = Record [(fst_label,e1);(snd_label,e2)]
  let eFst = 
    let p = gensym() in
    Abs(p,tPairT,Select(fst_label,Var p))
  let eSnd = 
    let p = gensym() in
    Abs(p,tPairT,Select(snd_label,Var p))

(* Integer binary operations *)
  let eBinop(f,e1,e2) = App(Var f,ePair(e1,e2))
  let iadd(e1,e2) = eBinop("Iadd",e1,e2)
  let ieql(e1,e2) = eBinop("Ieql",e1,e2)
  let imul(e1,e2) = eBinop("Imul",e1,e2)

end