(* static.rml *)
module Static:
  with "absyn.rml"
  with "scheme.rml"
  type Env		= (string * Scheme.Scheme) list
  val env0		: Env
  relation elaborate	: (Env, Absyn.Dec) => Env
end

with "util.rml"
with "types.rml"
with "unify.rml"

val tyINT = Types.CONS([], "int")
val tyREAL = Types.CONS([], "real")
val tySTRING = Types.CONS([], "string")
val tyBOOL = Types.CONS([], "bool")
val tyUNIT = Types.CONS([], "unit")

val qunit = Scheme.QUOTE tyUNIT
val qbool = Scheme.QUOTE tyBOOL

val bv_free = (false,NONE)

val alpha = Scheme.BOUND 0
val beta = Scheme.BOUND 1
val alphaRef = Scheme.MKCONS([alpha],"ref")
val alphaXbeta = Scheme.MKCONS([alpha,beta],"*")
val alphaList = Scheme.MKCONS([alpha],"list")
val intXint = Types.CONS([tyINT,tyINT],"*")
val intXintTOint = Types.CONS([intXint,tyINT],"->")
val scheme_intXintTOint = Scheme.SCHEME([],Scheme.QUOTE intXintTOint)
val scheme_numXnumTOnum = Scheme.SCHEME([(false,SOME["int","real"])],Scheme.MKCONS([Scheme.MKCONS([alpha,alpha],"*"),alpha],"->"))
val scheme_numXnumTObool = Scheme.SCHEME([(false,SOME["int","real"])],Scheme.MKCONS([Scheme.MKCONS([alpha,alpha],"*"),qbool],"->"))
val scheme_realXrealTOreal = Scheme.SCHEME([],Scheme.QUOTE(Types.CONS([Types.CONS([tyREAL,tyREAL],"*"),tyREAL],"->")))
val scheme_eqalphaXeqalphaTObool = Scheme.SCHEME([(true,NONE)],Scheme.MKCONS([Scheme.MKCONS([alpha,alpha],"*"),qbool],"->"))

val env0 =
[("=", scheme_eqalphaXeqalphaTObool)
,("ref",Scheme.SCHEME([bv_free],Scheme.MKCONS([alpha,alphaRef],"->")))
,("!",Scheme.SCHEME([bv_free],Scheme.MKCONS([alphaRef,alpha],"->")))
,(":=",Scheme.SCHEME([bv_free],Scheme.MKCONS([Scheme.MKCONS([alphaRef,alpha],"*"),qunit],"->")))
,("fst",Scheme.SCHEME([bv_free,bv_free],Scheme.MKCONS([alphaXbeta,alpha],"->")))
,("snd",Scheme.SCHEME([bv_free,bv_free],Scheme.MKCONS([alphaXbeta,beta],"->")))
,("true",Scheme.SCHEME([],qbool))
,("false",Scheme.SCHEME([],qbool))
,("null",Scheme.SCHEME([bv_free],Scheme.MKCONS([alphaList,qbool],"->")))
,("hd",Scheme.SCHEME([bv_free],Scheme.MKCONS([alphaList,alpha],"->")))
,("tl",Scheme.SCHEME([bv_free],Scheme.MKCONS([alphaList,alphaList],"->")))
,("nil",Scheme.SCHEME([bv_free],alphaList))
,("::",Scheme.SCHEME([bv_free],Scheme.MKCONS([Scheme.MKCONS([alpha,alphaList],"*"),alphaList],"->")))
,("+",scheme_numXnumTOnum)
,("-",scheme_numXnumTOnum)
,("*",scheme_numXnumTOnum)
,("idiv",scheme_intXintTOint)
,("imod",scheme_intXintTOint)
,("/",scheme_realXrealTOreal)
,("<", scheme_numXnumTObool)
,("<=", scheme_numXnumTObool)
,("print",Scheme.SCHEME([(false,SOME["int","real","bool","string"])],Scheme.MKCONS([alpha,qunit],"->")))
]

relation pure =
  axiom pure(Absyn.INT _)
  axiom pure(Absyn.REAL _)
  axiom pure(Absyn.STRING _)
  axiom pure(Absyn.UNIT)
  axiom pure(Absyn.VAR _)
  axiom pure(Absyn.LAM _)

  rule	pure e1 & pure e2
	----------------
	pure(Absyn.PAIR(e1,e2))

  rule	pure e1 & pure e2 & pure e3
	----------------
	pure(Absyn.IF(e1,e2,e3))
end

relation gen =
  rule	pure rhs & Scheme.gen_limit(rhs_ty, lev) => rhs_sigma
	----------------
	gen(rhs, rhs_ty, lev) => rhs_sigma

  rule	not pure rhs & Scheme.gen_none rhs_ty => rhs_sigma
	----------------
	gen(rhs, rhs_ty, lev) => rhs_sigma
end

datatype Constraint	= OVLD of Types.Type * Types.TyName list

relation check_c =
  rule	Types.deref ty => Types.CONS([],tyname) &
	list_member(tyname, tynames) => true
	----------------
	check_c(OVLD(ty, tynames))
end

relation check_constraints =
  axiom check_constraints([])

  rule	check_c c & check_constraints cs
	----------------
	check_constraints(c::cs)
end

relation add_constraints =
  axiom	add_constraints([], cs) => cs

  rule	Types.alpha_ovld alfa => SOME tynames &
	add_constraints(alphas, OVLD(Types.VAR alfa,tynames)::cs) => cs'
	----------------
	add_constraints(alfa::alphas, cs) => cs'

  rule	Types.alpha_ovld alfa => NONE &
	add_constraints(alphas, cs) => cs'
	----------------
	add_constraints(alfa::alphas, cs) => cs'
end

relation lookup_and_inst =
  rule	Util.lookup(env, var) => var_sigma &
	Scheme.inst(var_sigma, lev) => (bvars,var_ty) &
	add_constraints(bvars, cs) => cs'
	----------------
	lookup_and_inst(env, lev, cs, var) => (var_ty, cs')
end

relation elab_exp =	(* env,lev,cs |- exp => ty,cs' *)
  axiom elab_exp(_, _, cs, Absyn.INT _) => (tyINT, cs)
  axiom elab_exp(_, _, cs, Absyn.REAL _) => (tyREAL, cs)
  axiom elab_exp(_, _, cs, Absyn.STRING _) => (tySTRING, cs)
  axiom	elab_exp(_, _, cs, Absyn.UNIT) => (tyUNIT, cs)

  rule	lookup_and_inst(env, lev, cs, var) => (var_ty, cs')
	----------------
	elab_exp(env, lev, cs, Absyn.VAR var) => (var_ty, cs')

  rule	elab_lam(env, lev, cs, lam) => (lam_ty, cs')
	----------------
	elab_exp(env, lev, cs, Absyn.LAM lam) => (lam_ty, cs')

  rule	elab_exp(env, lev, cs, func) => (func_ty, cs1) &
	elab_exp(env, lev, cs1, arg) => (arg_ty, cs2) &
	Types.mkFreeAlpha lev => alfa &
	let res_ty = Types.VAR alfa &
	Unify.unify(func_ty, Types.CONS([arg_ty,res_ty], "->"))
	----------------
	elab_exp(env, lev, cs, Absyn.APP(func,arg)) => (res_ty, cs2)

  rule	elab_exp(env, lev, cs, e1) => (e1_ty, cs1) &
	elab_exp(env, lev, cs1, e2) => (e2_ty, cs2)
	----------------
	elab_exp(env, lev, cs, Absyn.PAIR(e1,e2)) => (Types.CONS([e1_ty,e2_ty],"*"), cs2)

  rule	elab_exp(env, lev, cs, e1) => (e1_ty, cs1) &
	Unify.unify(e1_ty, tyBOOL) &
	elab_exp(env, lev, cs1, e2) => (e2_ty, cs2) &
	elab_exp(env, lev, cs2, e3) => (e3_ty, cs3) &
	Unify.unify(e2_ty, e3_ty)
	----------------
	elab_exp(env, lev, cs, Absyn.IF(e1,e2,e3)) => (e2_ty, cs3)

  rule	int_add(lev, 1) => lev1 &
	elab_exp(env, lev1, cs, rhs) => (rhs_ty, cs1) &
	gen(rhs, rhs_ty, lev) => lhs_sigma &
	elab_exp((lhs,lhs_sigma)::env, lev, cs1, body) => (body_ty, cs2)
	----------------
	elab_exp(env, lev, cs, Absyn.LET(lhs,rhs,body)) => (body_ty, cs2)

  rule	int_add(lev, 1) => lev1 &
	Types.mkFreeAlpha lev1 => alfa &
	let lhs_ty = Types.VAR alfa &
	Scheme.gen_none lhs_ty => lhs_sigma1 &
	elab_lam((lhs,lhs_sigma1)::env, lev1, cs, lam) => (lam_ty, cs1) &
	Unify.unify(lhs_ty, lam_ty) &
	Scheme.gen_limit(lhs_ty, lev) => lhs_sigma0 &
	elab_exp((lhs,lhs_sigma0)::env, lev, cs1, body) => (body_ty, cs2)
	----------------
	elab_exp(env, lev, cs, Absyn.LETREC(lhs,lam,body)) => (body_ty, cs2)
end

and elab_lam =
  rule	Types.mkFreeAlpha lev => alfa &
	let var_ty = Types.VAR alfa &
	Scheme.gen_none var_ty => var_sigma &
	elab_exp((var,var_sigma)::env, lev, cs, body) => (body_ty,cs')
	----------------
	elab_lam(env,lev,cs,Absyn.LAMBDA(var,body)) => (Types.CONS([var_ty,body_ty],"->"),cs')
end

relation elaborate =
  rule	elab_exp(env, 0, [], exp) => (ty,cs) &
	check_constraints cs &
	Scheme.gen_limit(ty, -1) => sigma
	----------------
	elaborate(env, Absyn.VAL(id,exp)) => ((id,sigma)::env)
end
