(* Copyright 1996 by AT&T Bell Laboratories *)
(* chkplexp.sml *)

signature CHKPLEXP = 
sig 

exception ChkPlexp (* PLambda type check error *)

val checkLtyTop : PLambda.lexp * int -> bool
val checkLty : PLambda.lexp * PLambdaType.ltyEnv * int -> bool
val newlam_ref : PLambda.lexp ref
val fname_ref : string ref

end (* signature CHKPLEXP *)

structure ChkPlexp : CHKPLEXP = 
struct

local structure LT = PLambdaType
      structure LV = LambdaVar
      structure DA = Access 
      structure DI = DebIndex
      open PLambda 
in

exception ChkPlexp (* PLambda type check error *)

val debugging = ref true

(*** a hack of printing diagnostic output into a separate file ***) 
val newlam_ref : PLambda.lexp ref = ref (RECORD[])
val fname_ref : string ref = ref "yyy"

fun bug s = ErrorMsg.impossible ("CheckLty: "^s)
val say = Control.Print.say

structure PP = PrettyPrintNew
structure PU = PPUtilNew
val with_pp = PP.with_default_pp
val pd = ref 20

val anyerror = ref false
val clickerror = fn () => (anyerror := true)

(****************************************************************************
 *                         BASIC UTILITY FUNCTIONS                          *
 ****************************************************************************)
fun debugmsg msg =
    if false (* !debugging *)
    then (say "[ChkPlexp]: "; say msg; say "\n")
    else ()

fun app2(f, [], []) = ()
  | app2(f, a::r, b::z) = (f(a, b); app2(f, r, z))
  | app2(f, _, _) = bug "unexpected list arguments in function app2"

fun simplify(le,0) = STRING "<dummy>"
  | simplify(le,n) = 
      let fun h le = simplify(le, n-1)
       in case le 
           of FN(v, t, e) => FN(v, t, h e)
            | APP(e1, e2) => APP(h e1, h e2)
            | LET(v, e1, e2) => LET(v, h e1, h e2)
            | TFN(ks, e) => TFN(ks, h e)
            | TAPP(e, ts) => TAPP(h e, ts)
            | PACK(lt, ts, nts, e) => PACK(lt, ts, nts, h e)
            | CON(l, x, e) => CON(l, x, h e)
(*          | DECON(l, x, e) => DECON(l, x, h e) *)
            | FIX(lv, lt, le, b) => FIX(lv, lt, map h le, h b)
            | SWITCH(e, l, dc, opp) => 
               (let fun g(c, x) = (c, h x)
                    fun f x = case x of SOME y => SOME(h y) | NONE => NONE
                 in SWITCH(h e, l, map g dc, f opp)
                end)
            | RECORD e => RECORD (map h e)
            | SRECORD e => SRECORD (map h e)
            | VECTOR(e, x) => VECTOR (map h e, x)
            | SELECT(i, e) => SELECT(i, h e)
            | HANDLE(e1, e2) => HANDLE(h e1, h e2)
            | WRAP(t, b, e) => WRAP(t, b, h e)
            | UNWRAP(t, b, e) => UNWRAP(t, b, h e)
            | _ => le
      end (* end of simplify *)

(** utility functions for printing *)
fun tkPrint tk =
    with_pp (fn stm =>
     (PPLty.ppTKind (!pd) stm tk;
      PP.newline stm))

fun tcPrint tc =
    with_pp (fn stm =>
     (PPLty.ppTyc (!pd) stm tc;
      PP.newline stm))

fun ltPrint lt =
    with_pp (fn stm =>
     (PPLty.ppLty (!pd) stm lt;
      PP.newline stm))

fun lePrint le = 
    with_pp(fn ppstrm => PPLexp.ppLexp 20 ppstrm (simplify(le, 3)))

(*** a hack for type checking ***)
fun laterPhase i = (i > 20)

(****************************************************************************
 *           MAIN FUNCTION --- val checkLty : PLambda.lexp -> bool          *
 ****************************************************************************)
fun checkLty (lexp, venv : LT.ltyEnv, phase) = 
let 

val ltEquiv = LT.lt_eqv
val ltString = if laterPhase(phase) then LT.ltc_void else LT.ltc_string
val ltExn = if laterPhase(phase) then LT.ltc_void else LT.ltc_exn
fun ltEtag lt = if laterPhase(phase) then LT.ltc_void 
                else LT.ltc_etag lt
fun ltVector t = if laterPhase(phase) then LT.ltc_void
                 else LT.ltc_tyc(LT.tcc_vector t)

(** lazily selecting a field from a record/structure type *)
exception LtySelect
fun ltSel (lt, i) = 
  (LT.lt_select(lt, i)) handle _ => raise LtySelect

(** build a function or functor type from a pair of arbitrary ltys *)
fun ltFun (x, y) = 
  if (LT.ltp_tyc x) andalso (LT.ltp_tyc y) then LT.ltc_parrow(x, y)
  else LT.ltc_pfct(x, y)

fun ltTup ts = LT.ltc_tyc(LT.tcc_tuple (map LT.ltd_tyc ts)) handle LT.DeconExn => bug "ltTup"

(** lazily finding out the arg and res of an lty *)
exception LtyArrow 
fun ltArrow lt = 
  (if LT.ltp_tyc lt then LT.ltd_parrow lt
   else LT.ltd_pfct lt) handle _ => raise LtyArrow

val lt_inst_chk = LT.lt_inst_chk_gen()
(* kind checker for ltys *)
val ltyChk = fn _ => fn _ => 1 (* LtyKindChk.ltKindCheckGen () *)
(* kind checker for tycs *)
val tycChk = fn _ => fn _ => 1 (* LtyKindChk.tcKindCheckGen () *)

fun ltAppChk (lt, ts, kenv) : LT.lty = 
  (case lt_inst_chk(lt, ts, kenv) 
    of [b] => b 
     | _ => bug "unexpected arg in ltAppChk")

(** utility functions for type checking *)
fun ltTyApp le s (lt, ts, kenv) = 
      ((ltAppChk(lt, ts, kenv))
       handle zz => 
       (clickerror ();
        say (s ^ "  **** Kind conflicting in lexp =====> \n    ");
        case zz of LT.LtyAppChk => say "      exception LtyAppChk raised! \n"
                 | LT.KindChk _ =>  say "      exception KindChk raised! \n"
                 | _ => say "   other weird exception raised! \n";
        say "\n \n"; lePrint le; say "\n For Types: \n";  
        ltPrint lt; say "\n and   \n    "; 
        app (fn x => (tcPrint x; say "\n")) ts;   say "\n \n";  
        say "***************************************************** \n"; 
        bug "fatal typing error in ltTyApp"))

fun ltMatch le msg (t1, t2) = 
  (if ltEquiv(t1,t2) then ()
   else (clickerror();
         with_pp(fn s =>
           (PU.pps s ("ERROR(checkLty): ltEquiv fails in ltMatch: "^msg); PP.newline s;
            PU.pps s "le:"; PP.newline s; PPLexp.ppLexp 6 s le;
            PU.pps s "t1:"; PP.newline s; PPLty.ppLty 20 s t1; PP.newline s;
            PU.pps s "t2:"; PP.newline s; PPLty.ppLty 20 s t2; PP.newline s;
            PU.pps s"***************************************************";
            PP.newline s)); raise Fail "ltMatch"))
  handle LT.TeUnbound => 
  (clickerror();
   with_pp(fn s =>
     (PU.pps s ("ERROR(checkLty): exception teUnbound2 in ltMatch"^msg); PP.newline s;
      PU.pps s "le:"; PP.newline s; PPLexp.ppLexp 6 s le;
      PU.pps s "t1:"; PP.newline s; PPLty.ppLty 10 s t1; PP.newline s;
      PU.pps s "t2:"; PP.newline s; PPLty.ppLty 10 s t2; PP.newline s;
      PU.pps s"***************************************************";
      PP.newline s)))

fun ltFnApp le s (t1, t2) = 
  let val (a1, b1) = 
        ((ltArrow t1) handle zz =>
            (clickerror ();
             say (s ^ "  **** Applying Non-Arrow Type in lexp =====> \n    ");
             case zz of LtyArrow => say "exception LtyArrow raised. \n"
                      | LT.TeUnbound => say "exception TeUnbound raised. \n"
                      | _ => say "other weird exceptions raised\n";
             say "\n \n";  lePrint le; say "\n For Types \n";
             ltPrint t1; say "\n and   \n    "; ltPrint t2; say "\n \n";  
             say "***************************************************** \n"; 
             bug "fatal typing error in ltFnApp"))

   in ltMatch le (s^":ltFnApp") (a1, t2); b1
  end

fun ltFnAppR le s (t1, t2) =  (*** used for DECON lexps ***)
  let val (a1, b1) = 
        ((ltArrow t1) handle zz => 
            (clickerror ();
             say (s ^ "  **** Rev-Apply Non-Arrow Type in lexp =====> \n    ");
             case zz of LtyArrow => say "exception LtyArrow raised. \n"
                      | LT.TeUnbound => say "exception TeUnbound raised. \n"
                      | _ => say "other weird exceptions raised\n";
             say "\n \n";  lePrint le; say "\n For Types \n";
             ltPrint t1; say "\n and   \n    "; ltPrint t2; say "\n \n"; 
             say "***************************************************** \n"; 
             bug "fatal typing error in ltFnApp"))

   in ltMatch le s (b1, t2); a1
  end

fun ltSelect le s (lt, i) = 
  ((ltSel(lt, i))
     handle zz => 
       (clickerror ();
        say (s ^ "  **** Select from a wrong-type lexp  =====> \n    ");
        case zz of LtySelect => say "exception LtyArrow raised. \n"
                 | LT.TeUnbound => say "exception TeUnbound raised. \n"
                 | _ => say "other weird exceptions raised\n";
        say "\n \n";  lePrint le; say "\n \n";
        say "Selecting "; say (Int.toString i); 
        say "-th component from the type: \n     "; ltPrint lt; say "\n \n "; 
        say "***************************************************** \n"; 
        bug "fatal typing error in ltSelect"))

(** ltConChk currently does not check the case for DATAcon *)
(** Of course, we could easily check for monomorphic DATAcons *)
fun ltConChk le s (DATAcon ((_,rep,lt), ts, v), root, kenv, venv, d) = 
      let val t1 = ltTyApp le "DECON" (lt, ts, kenv)
          val t = ltFnAppR le "DECON" (t1, root)
       in LT.ltInsert(venv, v, t, d)
      end
  | ltConChk le s (c, root, kenv, venv, d) = 
      let val nt = (case c of INT32con _ => LT.ltc_int32
                            | WORD32con _ => LT.ltc_int32
                            | REALcon _ => LT.ltc_real
                            | STRINGcon _ => ltString
			    | INTINFcon _ => bug "INTINFcon"
                            |  _ => LT.ltc_int)
       in ((ltMatch le s (nt, root)) handle Fail _ => say "ConChk ltEquiv\n"); venv
      end

(** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
fun check (kenv, venv, d) = 
  let fun ltyChkMsg msg lexp kenv lty = 
		  ltyChk kenv lty 
		  handle LT.KindChk kndchkmsg =>
			 (say ("*** Kind check failure during \
			       \ PLambda type check: ");
			  say (msg);
			  say ("***\n Term: ");
			  with_pp(fn s => PPLexp.ppLexp 20 s lexp);
			  say ("\n Kind check error: ");
			  say kndchkmsg;
			  say ("\n");
			  raise ChkPlexp)
      fun loop le =
	  let fun ltyChkMsgLexp msg kenv lty = 
		    ltyChkMsg msg lexp kenv lty 
	      fun ltyChkenv msg lty = 1 (* ltyChkMsgLexp msg kenv lty *)
	  in
	      (case le
		of VAR v => 
		   (LT.ltLookup(venv, v, d) 
		    handle LT.ltUnbound => 
			   (say ("** Lvar ** " ^ (LV.lvarName(v)) 
				 ^ " is unbound *** \n");
			    bug "unexpected lambda code in checkLty"))
		 | (INT _ | WORD _) => LT.ltc_int
		 | (INT32 _ | WORD32 _) => LT.ltc_int32
		 | REAL _ => LT.ltc_real
		 | STRING _ => ltString
		 | PRIM(p, t, ts) =>
		   (* kind check t and ts *)
		       (ltyChkenv " PRIM " t; 
			map (tycChk kenv) ts;
			debugmsg "PRIM";
			ltTyApp le "PRIM" (t, ts, kenv))
		   
		 | FN(v, t, e1) =>
		   let val _ = ltyChkenv "FN bound var" t 
					 (* kind check bound variable type *)
                       val venv' = LT.ltInsert(venv, v, t, d)
                       val res = check (kenv, venv', d) e1
                       val _ = ltyChkenv "FN rng" res
		       val _ = debugmsg "FN"
		       val fnlty = ltFun(t, res) (* handle both functions and functors *)
		       val  _ = ltyChkenv "FNlty " fnlty
		       val _ = debugmsg "FN 2"
		   in fnlty
		   end
		   
		 | FIX(vs, ts, es, eb) => 
		   let val _ = map (ltyChkenv "FIX bound var") ts  
				   (* kind check bound variable types *)
		       fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
			 | h (env, [], []) = env
			 | h _ = bug "unexpected FIX bindings in checkLty."
                       val venv' = h(venv, vs, ts)
				   
                       val nts = map (check (kenv, venv', d)) es
                       val _ = map (ltyChkenv "FIX body types") nts
                       val _ = app2(ltMatch le "FIX1", ts, nts)
		       val _ = debugmsg "FIX"
		   in check (kenv, venv', d) eb
		   end
		   
		 | APP(e1, e2) => 
		   let val top = loop e1
                       val targ = loop e2
		       val _ = ltyChkenv "APP operator " top
		       val _ = ltyChkenv "APP argument " targ
		       val _ = debugmsg "APP"
		   in 
                       ltFnApp le "APP" (top, targ)
		   end
		   
		 | LET(v, e1, e2) => 
		   let val t1 = loop e1
                       val _ = ltyChkenv "LET definien" t1 
                       val venv' = LT.ltInsert(venv, v, t1, d)
		       val bodyLty = check (kenv, venv', d) e2
		       val _ = ltyChkenv "LET body" bodyLty
		       val _ = debugmsg "LET"
		   in bodyLty
		   end
		   
		 | TFN(ks, e) => 
		   let val kenv' = LT.tkInsert(kenv, ks)
                       val lt = check (kenv', venv, DI.next d) e
                       val _ = ltyChkMsgLexp "TFN body" (ks::kenv) lt
		       val _ = debugmsg "TFN"
		   in LT.ltc_poly(ks, [lt])
		   end
		   
		 | TAPP(e, ts) =>
		   let val lt = loop e
                       val _ = map ((ltyChkenv "TAPP args") o LT.ltc_tyc) ts  
				   (* kind check type args *)
                       val _ = ltyChkenv "TAPP type function " lt
		       val _ = debugmsg "TAPP"
		   in  ltTyApp le "TAPP" (lt, ts, kenv)
		   end
		   
		 | GENOP(dict, p, t, ts) => 
		   ((* should type check dict also *)
			(map ((ltyChkenv "GENOP args ") o LT.ltc_tyc) ts;
			 ltTyApp le "GENOP" (t, ts, kenv)))
		   
		 | PACK(lt, ts, nts, e) => 
		   let val argTy = ltTyApp le "PACK-A" (lt, ts, kenv)
		       val _ = ltyChkenv " PACK-A " argTy
		       val bodyTy = loop e
		       val _ = ltyChkenv " PACK body " bodyTy
		       val _ = debugmsg "PACK"
		   in ((ltMatch le "PACK-M" (argTy, loop e)) handle Fail _ => say "PACK ltEquiv\n") ;
                      ltTyApp le "PACK-R" (lt, nts, kenv)
		   end
		   
		 | CON((_, rep, lt), ts, e) =>   
		   let val t1 = ltTyApp le "CON" (lt, ts, kenv)
                       val _ = ltyChkenv "CON 1 " t1
                       val t2 = loop e
                       val _ = ltyChkenv "CON 2 " t2
		       val _ = debugmsg "CON"
		   in ltFnApp le "CON-A" (t1, t2)
		   end
		       (*
		 | DECON((_, rep, lt), ts, e) =>   
		   let val t1 = ltTyApp le "DECON" (lt, ts, kenv)
                       val t2 = loop e
		   in ltFnAppR le "DECON" (t1, t2)
		   end
			*)
		 | RECORD el => 
		   let val elemsltys = map loop el
		       val _ = map (ltyChkenv "RECORD elem ") elemsltys
		       val _ = debugmsg "RECORD"
		   in ltTup elemsltys
		   end
		 | SRECORD el => 
		   let val elemsltys = map loop el
		       val _ = map (ltyChkenv "SRECORD elem ") elemsltys
		   in LT.ltc_str elemsltys
		   end
		 | VECTOR (el, t)  => 
		   let val ts = map loop el
		   in ltyChkenv "VECTOR index " (LT.ltc_tyc t);
                      map (ltyChkenv "VECTOR vector ") ts;
                      app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts; 
                      debugmsg "VECTOR "; 
		      ltVector t
		   end
		   
		 | SELECT(i,e) => 
		    let val lty = loop e
			val _ = ltyChkenv " SELECT " lty
			val _ = debugmsg "SELECT"
		    in 
			ltSelect le "SEL" (lty, i)
		    end  
		 | SWITCH(e, _, cl, opp) => 
		   let val root = loop e
		       val _ = ltyChkenv " SWITCH root " root 
                       fun h (c, x) = 
			   let val venv' = ltConChk le "SWT1" (c, root, kenv, venv, d)
			   in check (kenv, venv', d) x 
			   end
                       val ts = map h cl
                       val _ = map (ltyChkenv "SWITCH branch ") ts
		       val _ = debugmsg "SWITCH"
		   in (case ts
			of [] => bug "empty switch in checkLty"
			 | a::r => 
                           (app (fn x => ltMatch le "SWT2" (x, a)) r;
                            case opp
                             of NONE => a
                              | SOME be => (ltMatch le "SWT3" (loop be, a); a)))
		   end
		   
		 | ETAG(e, t) => 
		   let val z = loop e   (* what do we check on e ? *)
                       val _ = ltyChkenv "ETAG 1 " z
		       val _ = ltMatch le "ETAG1" (z, LT.ltc_string) 
                       val _ = ltyChkenv "ETAG " t
		       val _ = debugmsg "ETAG"
		   in ltEtag t
		   end
		   
		 | RAISE(e,t) => 
		   let val exlty = loop e
		       val _ = ltyChkenv "RAISE " exlty
		       val _ = debugmsg "RAISE"
		   in
		       (ltMatch le "RAISE" (exlty, ltExn); t)
		   end
		 | HANDLE(e1,e2) => 
		   let val t1 = loop e1
		       val _ = ltyChkenv "HANDLE exception " t1
                       val t2 = loop e2
		       val _  = ltyChkenv "HANDLE handler " t2
		       val arg = ltFnAppR le "HANDLE" (loop e2, t1)
		       val _  = ltyChkenv "HANDLE arg " arg
		       val _ = debugmsg "HANDLE"
		   in t1 (* [GK] Is this right?? *)
		   end
		       
		       (** these two cases should never happen before wrapping *)
		 | WRAP(t, b, e) => 
		   (ltMatch le "WRAP" (loop e, LT.ltc_tyc t); 
		    if laterPhase(phase) then LT.ltc_void
		    else LT.ltc_tyc(if b then LT.tcc_box t else LT.tcc_abs t))
		   
		 | UNWRAP(t, b, e) => 
		   let val ntc = if laterPhase(phase) then LT.tcc_void
				 else (if b then LT.tcc_box t else LT.tcc_abs t)
                       val nt = LT.ltc_tyc ntc
                       val _ = ltyChkenv "UNWRAP " nt
		   in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
		   end)
	  end (* loop *)
  in (* wrap loop with kind check of result *)
     fn x => let val y = loop x in ltyChkMsg "RESULT " x kenv y; y end
 end (* end-of-fn-check *)

in 
  anyerror := false;
  check (LT.initTkEnv, venv, DI.top) lexp;
  !anyerror
end (* end of function checkLty *)

fun checkLtyTop(lexp, phase) = checkLty(lexp, LT.initLtyEnv, phase)

end (* toplevel local *)
end (* structure CheckLty *)
