structure MinML = struct

    (* variables represented simply as strings: *)
    type var = string

    (* in general, an environment is a mapping from variables to something *)
    type 'a env = var -> 'a

    (* extend e by binding variable x to v *)
    fun bind (a, x: var, e) y = if x = y then a else e y
    (* the empty environment simply complains: *)
    fun empty (x: var) = raise Fail ("unbound variable: " ^ x)

    (* *** The MinML language *** *)

    (* primitive operators: *)
    datatype operator = PLUS | TIMES | MINUS | EQUAL | LESS

    (* simple types *)
    datatype typ =
	     INTt
	   | BOOLt
	   | FUNt of typ * typ
	   | VARt of tyvar

    withtype tyvar = typ option ref

    (* base values (values that are not functions) *)
    datatype basevalue =
	     NUM of int
	   | TRUE
	   | FALSE

    (* primitive operators operate on base values: *)
    fun b'primop (PLUS, NUM i, NUM j) = NUM (i+j)
      | b'primop (TIMES, NUM i, NUM j) = NUM (i*j)
      | b'primop (MINUS, NUM i, NUM j) = NUM (i-j)
      | b'primop (EQUAL, NUM i, NUM j) = if i = j then TRUE else FALSE
      | b'primop (LESS, NUM i, NUM j) = if i < j then TRUE else FALSE
      | b'primop _ = raise Fail "primop: numeric argument expected"


    (* syntactic values: *)
    datatype value =
	     BVAL of basevalue
	   | FUN of function
    (* expressions: *)
	 and exp =
	     VAR of var
	   | VAL of value
	   | PRIM of operator * exp * exp
	   | IF of exp * exp * exp
	   | APPLY of exp * exp

    (* recursive "lambda" terms: "fun f(x:argt):rest is body" *)
    withtype function = { f: var, x: var, body: exp }

    fun typecheck e =
	let fun newtyp () = VARt (ref NONE)
	    fun occurs (r, INTt) = false
	      | occurs (r, BOOLt) = false
	      | occurs (r, FUNt (t1, t2)) = occurs (r, t1) orelse occurs (r, t2)
	      | occurs (r, VARt r') =
		  r = r' orelse
		  (case !r' of
 		       NONE => false
		     | SOME t => occurs (r, t))
	    fun unify (INTt, INTt) = ()
	      | unify (BOOLt, BOOLt) = ()
	      | unify (FUNt (t1, t2), FUNt (t1', t2')) =
		  (unify (t1, t1'); unify (t2, t2'))
	      | unify (VARt (ref (SOME t1)), t2) =
		  unify (t1, t2)
	      | unify (t1, VARt (ref (SOME t2))) =
		  unify (t1, t2)
	      | unify (t1 as VARt (r1 as ref NONE),
		       t2 as VARt (r2 as ref NONE)) =
		  if r1 = r2 then ()
		  else (r1 := SOME t2)
	      | unify (t1 as VARt (r1 as ref NONE), t2) =
		  if occurs (r1, t2) then
		      raise Fail "circular type"
		  else r1 := SOME t2
	      | unify (t1, t2 as VARt (r2 as ref NONE)) =
		  if occurs (r2, t1) then
		      raise Fail "circular type"
		  else r2 := SOME t1
	      | unify _ = raise Fail "type mismatch"
	    fun vtyp (G, BVAL (NUM _), t) =
		  unify (t, INTt)
	      | vtyp (G, BVAL (TRUE | FALSE), t) =
		  unify (t, BOOLt)
	      | vtyp (G, FUN { f, x, body }, t) =
		  let val t1 = newtyp ()
		      val t2 = newtyp ()
		  in etyp (bind (t, f, bind (t1, x, G)), body, t2);
		     unify (t, FUNt (t1, t2))
		  end
	    and etyp (G, VAR x, t) =
		  unify (t, G x)
	      | etyp (G, VAL v, t) =
		  vtyp (G, v, t)
	      | etyp (G, PRIM ((PLUS | TIMES | MINUS), e1, e2), t) =
		  (etyp (G, e1, INTt);
		   etyp (G, e2, INTt);
		   unify (INTt, t))
	      | etyp (G, PRIM ((EQUAL | LESS), e1, e2), t) =
		  (etyp (G, e1, INTt);
		   etyp (G, e2, INTt);
		   unify (BOOLt, t))
	      | etyp (G, IF (e1, e2, e3), t) =
		  (etyp (G, e1, BOOLt);
		   etyp (G, e2, t);
		   etyp (G, e3, t))
	      | etyp (G, APPLY (e1, e2), t) =
		  let val t2 = newtyp ()
		  in etyp (G, e1, FUNt (t2, t));
		     etyp (G, e2, t2)
		  end
	in etyp (empty, e, newtyp ())
	end
end