(* Unification on Types *)
(* Author: Carsten Schuermann *)

exception Error of string

datatype Tp
  = Prop of int
  | Var of Tp option ref
  | Arrow of Tp * Tp

fun whnf (t as Prop _) = t
  | whnf (t as Arrow _) = t
  | whnf (t as Var (ref NONE)) = t
  | whnf (Var (ref (SOME t))) = t

fun occurs (r, t) = occursW (r, whnf t)
and occursW (r, Prop _) = ()
  | occursW (r, Var r') = 
    if r=r' then raise Error "Occurs Check" else ()
  | occursW (r, Arrow (t1, t2)) = 
    (occursW (r, t1); occursW (r, t2))

fun unify (t1, t2) = unifyW (whnf t1, whnf t2)
and unifyW (Prop i, Prop j) = 
    if (i = j) then () else raise Error "Type Clash"
  | unifyW (Var r, t as Var r') =
    if (r = r') then () else (r := SOME t)
  | unifyW (Var r, t) = 
  (occurs (r, t); r := SOME t)
  | unifyW (t, Var r) = (occurs (r, t); r := SOME t)
  | unifyW (Arrow (t1, t2), Arrow (t1', t2')) = 
      (unify (t1, t1'); unify (t2, t2'))
  | unifyW _ = raise Error "Type Clash"


val alpha : Tp option ref
          = ref NONE
val beta  : Tp option ref
          = ref NONE
val t1    = Arrow (Var alpha, Var beta)
val t2    = Arrow (Var beta, Var alpha)
val r     = unify (t1, t2)

val gamma : Tp option ref
          = ref NONE
val delta  : Tp option ref
          = ref NONE
val t3    = Arrow (Arrow (Var gamma, Var gamma), Var delta)
val t4    = Arrow (Var delta, Var gamma)
(* val r     = unify (t3, t4) *)