(* Type checking for Pnf *)

module Pnfcheck:
sig
  val check : Pnf.exp -> Pnf.typ 
end =
struct
  open Check
  open Pnf

  exception Type_error of string * exp
  exception Row_error of string * row

  let rec type_exp (e : exp) : typ = 
    match e with
      Triv trexp -> type_trexp trexp
    | Let ((v,t),e1,e2) -> 
	if (type_exp e1) = t then
	  type_exp e2
	else raise (Type_error ("Let binding type doesn't match definition",e))
    | App (tre1,tre2) ->
	begin
	  match (type_trexp tre1) with
	    ArrowT(t2,t) ->
	      if subtype (type_trexp tre2) t2 then
		t
	      else raise (Type_error ("actual doesn't match formal",e))
	  | _ -> raise (Type_error ("operator not a function",e))
	end
    | Fix(fs,e2) ->
	let chk ((f,ft),e0) =
	  match e0 with
	    Abs((v,vt),e1) ->
	      if ft <> ArrowT(vt,type_exp e1) then
		raise (Type_error ("Fix function type annotation doesn't match",e))
	      else () 
	  | _ -> raise (Type_error ("recursively-defined identifier must be abstraction",e)) in
	List.iter chk fs;
	type_exp e2
    | Record r -> RecordT (type_row r)
    | Select(l,tre1) -> 
	begin
	  match type_trexp tre1 with
	    RecordT rtyp -> 
		begin
		  try 
		    List.assoc l rtyp
		  with Not_found -> raise (Type_error("bad label",e))
		end
	    | _ -> raise (Type_error ("select from non-record",e))
	  end
    | Variant(l,tre1) -> SumT[(l,type_trexp tre1)]
    | Switch(_,[]) -> raise (Type_error ("switch with no arms",e))
    | Switch(tre1,r) ->
	begin
	  let t1 = type_trexp tre1 in
	  match t1 with
	    SumT rtyp ->
	      let rt = type_row r in
	      let (arg_rt,res_typs) = 
		let f = function
		    (lab,ArrowT(arg,res)) -> ((lab,arg),res)
		  | _ -> raise (Type_error ("switch arm not lambda",e)) in
		List.split (List.map f rt) in
	      if not (subtype t1 (SumT arg_rt)) then
		raise (Type_error ("switch arm label missing",e))
	      else
		begin
		  try 
		    join_type_list res_typs
		  with Incomparable -> raise (Type_error ("switch arm result types inconsistent",e))
		end
	  | _ -> raise (Type_error ("switch on non-sum",e))
	end

  and type_trexp (tre: trexp) : typ = 
    match tre with
      Var (v,t) -> t
    | Abs((v,t),e) -> ArrowT(t,type_exp e)
    | Int _ -> IntT

  and type_row (r: row) : rtyp = (* returned row type is in label-sorted order *)
    let r' = Sort.list (<=) r in
    let rec check_nodups l =
      match l with
	[] -> ()
      | [(h,_)] -> ()
      | ((h1,_)::(((h2,_)::_) as t)) -> 
	  if h1 = h2 then 
	    raise (Row_error("duplicate label in row",r))
	  else 
	    check_nodups t in
    check_nodups r';
    List.map (fun (l,tre) -> (l, type_trexp tre)) r' 

  let check = type_exp 

end