(* To compile this file, run:
 *
 * ocamlbuild -use-ocamlfind -pkg compsci631 -pkg ppx_test typeinf.d.byte
 *)
module Explicit = Tc_util
module Implicit = Xinterp_util

(* This is necessary for let%TEST to work. *)
module PTest = Ppx_test.Test

let rec add_metavars (exp : Implicit.exp) : Explicit.exp = match exp with
  | Implicit.Const c -> Explicit.Const c

(* After this point, we are only working with the explicitly-typed syntax, so
   opening the module is unambiguous. *)

open Explicit

type constr = typ * typ

type env = (id * typ) list (* Other representations are possible too *)

let constraints : (constr list) ref = ref []

let add_constraint (lhs : typ) (rhs : typ) : unit =
  constraints := (lhs, rhs) :: !constraints


let rec cgen (env : env) (exp : exp) : typ = match exp with
  | Const (Int _) -> TInt
  | Const (Bool _) -> TBool
  | Op2 (Add, e1, e2) ->
    add_constraint (cgen env e1) TInt;
    add_constraint (cgen env e2) TInt;
    TInt
  | Fun (x, t1, e) ->
    let t2 = cgen ((x, t1) :: env) e in
    TFun (t1, t2)
  | Id x -> List.assoc x env

module type SUBST = sig
  type t

  val empty : t
  val singleton : metavar -> typ -> t
  val apply : t -> typ -> typ
  val compose : t -> t -> t
  val to_list : t -> (metavar * typ) list (* for debugging *)
end


module Subst : SUBST = struct
  type t = (metavar * typ) list
  let empty = []
  let singleton x typ = failwith "not implemented"
  let apply subst typ = failwith "not implemented"
  let compose subst1 subst2 = failwith "not implemented"
  let to_list subst = failwith "not implemented"
end

(* Some examples of operations on substitutions *)
let x : metavar = "__x"
let y : metavar = "__y"
let z : metavar = "__z"
                    
let%TEST "Subst.apply should replace x with TInt" =
  let s = Subst.singleton x TInt in
  Subst.apply s (TMetavar x) = TInt

let%TEST "Subst.apply should recur into type constructors" =
  let s = Subst.singleton x TInt in
  Subst.apply s (TFun (TMetavar x, TBool)) = (TFun (TInt, TBool))

let%TEST "Subst.compose should distribute over Subst.apply (1)" =
  let s1 = Subst.singleton x TInt in
  let s2 = Subst.singleton y TBool in
  Subst.apply (Subst.compose s1 s2) (TFun (TMetavar x, TMetavar y)) =
  Subst.apply s1 (Subst.apply s2 (TFun (TMetavar x, TMetavar y)))

let%TEST "Subst.compose should distribute over Subst.apply (2)" =
  let s1 = Subst.singleton x TBool in
  let s2 = Subst.singleton y (TMetavar x) in
  Subst.apply (Subst.compose s1 s2) (TFun (TMetavar x, TMetavar y)) =
  Subst.apply s1 (Subst.apply s2 (TFun (TMetavar x, TMetavar y)))

let unify (t1 : typ) (t2 : typ) : Subst.t = failwith "not implemented"

(* An incomplete suite of tests for unification *)
let%TEST "unifying identical base types should return the empty substitution" =
  Subst.to_list (unify TInt TInt) = []

let%TEST "unifying distinct base types should fail" =
  try let _ = unify TInt TBool in false
  with Failure _ -> true

let%TEST "unifying with a variable should produce a singleton substitution" =
  Subst.to_list (unify TInt (TMetavar x)) = [(x, TInt)]

let%TEST "unification should recur into type constructors" =
  Subst.to_list (unify (TFun (TInt, TInt))
                       (TFun (TMetavar x, TInt))) =
  [(x, TInt)]

let%TEST "unification failures may occur across recursive cases" =
  try
    let _ = unify (TFun (TInt, TMetavar x))
                  (TFun (TMetavar x, TBool)) in
    false
  with Failure _ -> true

let%TEST "unification should produce a substitution that is transitively closed" =
  let subst = unify (TFun (TFun (TInt, TMetavar x), TMetavar y))
                    (TFun (TFun (TMetavar x, TMetavar y), TMetavar z)) in
  Subst.to_list subst = [ (z, TInt); (y, TInt); (x, TInt) ]

let%TEST "unification should detect constraint violations that require transitive
      closure" =
  try
    let _ = unify (TFun (TFun (TInt, TMetavar x), TMetavar y))
                      (TFun (TFun (TMetavar x, TMetavar y), TBool)) in
    false
  with Failure _ -> true

let%TEST "unification should implement the occurs check (to avoid infinite loops)" =
  try
    let _ = unify (TFun (TInt, TMetavar x)) (TMetavar x) in
    false (* a bug is likely to cause an infinite loop *)
  with Failure _ -> true

let annotate_exp (subst : Subst.t) (exp : exp) : exp = failwith "not implemented"

let typeinf (exp : Implicit.exp) : Explicit.exp = failwith "not implemented"

                                       
let _ =
  let filename : string = Sys.argv.(1) in
  let program : Implicit.exp = Implicit.from_file filename in
  failwith "not implemented"