(* This file starts with the content of cae.ml *)

(* Data definitions *)

type cae = 
    Num of int
  | Str of string
  | Add of cae * cae
  | Sub of cae * cae
  | IfZ of cae * cae * cae
  | Arg
  | This
  | New of string * cae list
  | Get of cae * string
  | DSend of cae * string * cae
  | SSend of cae * string * string * cae

and cdecl = Class of string * field list * meth list

and field = Field of string

and meth = Method of string * cae

and caeValue =
    NumV of int
  | StrV of string
  | ObjV of cdecl * caeValue list

exception Failed of string

(* Number operations *)

let mkNumOp = fun op
  -> function
      (NumV(a), NumV(b)) -> NumV(op a b)
    | _ -> raise (Failed "not numbers")
	  
let numPlus = mkNumOp (fun a b -> a + b)
let numMinus = mkNumOp (fun a b -> a - b)

(* Lookup *)

exception NoSuch of string * string

let rec find = fun what nameOf name vals ->
  match vals with
    [] -> raise (NoSuch (what, name))
  | a::rest -> 
      if (name = nameOf(a))
      then a
      else find what nameOf name rest
	  
let findClass = (find "class"
		   (fun (Class(name, _, _)) -> name))

let findMethod = (find "method"
		    (fun (Method(name, _)) -> name))

let getField = fun name fields vals ->
  snd (find "field" (fun (Field(name), _) -> name)
	 name (List.map2 (fun x y -> (x,y)) fields vals))

(* Interpreter *)

let rec interp : (cae * cdecl list * caeValue * caeValue 
		  -> caeValue ) 
    = function (expr, cdecls, this, arg) -> 
      let recur = fun e -> interp(e, cdecls, this, arg)
      in match expr with
      Num(n) -> NumV(n)
    | Str(n) -> StrV(n)
    | Add(l, r) -> numPlus(recur l, recur r)
    | Sub(l, r) -> numMinus(recur l, recur r)
    | IfZ(tst, thn, els) ->
	if (recur tst = NumV(0))
	then recur thn
	else recur els
    | This -> this
    | Arg -> arg
    | New(name, exprs) -> 
	let decl = findClass name cdecls
	in let vals = (List.map recur exprs)
	in ObjV(decl, vals)
    | Get(expr, fname) ->
	(match recur expr with
	  ObjV(Class(_, fields, _), vals) -> 
	    getField fname fields vals
	| _ -> raise (Failed "not an object for get"))
    | DSend(expr, mname, argExpr) ->
	(match recur expr with
	  (ObjV(Class(_, _, methods), _) as this) -> 
	    let Method(name, body) = findMethod mname methods
	    in interp(body, cdecls, this, recur argExpr)
	| _ -> raise (Failed "not an object for send"))
    | SSend(expr, cname, mname, argExpr) ->
	let this = recur expr
	in let Class(_, _, methods) = findClass cname cdecls
	in let Method(name, body) = findMethod mname methods
	in interp(body, cdecls, this, recur argExpr)

(* Examples *)

let posnClass = Class("posn",
		      [Field("x"); Field("y")],
		      [Method("mdist", Add(Get(This, "x"), Get(This, "y")));
		       Method("addDist", Add(DSend(This, "mdist", Num(0)),
					     DSend(Arg, "mdist", Num(0))));
		       Method("addX", Add(Get(This, "x"), Arg));
		       Method("subY", Sub(Arg, Get(This, "y")));
		       Method("factory01", New("posn", [Num(0); Num(1)]))])
    
let posn3DClass = Class("posn3D",
			[Field("x"); Field("y"); Field("z")],
			[Method("mdist", Add(Get(This, "z"), 
					     SSend(This, "posn", "mdist", Arg)));
			 Method("addDist", SSend(This, "posn", "addDist", Arg))])
    
let mkPosn27 = New("posn", [Num(2); Num(7)])
let mkPosn531 = New("posn3D", [Num(5); Num(3); Num(1)])

let mdist = fun o -> DSend(o, "mdist", Num(0))
let addDist = fun o p -> DSend(o, "addDist", p)
let addX = fun o y -> DSend(o, "addX", y)
let subY = fun o y -> DSend(o, "subY", y)

let interpPosn = fun x -> interp(x, [posnClass;posn3DClass], NumV(0), NumV(0))

;;

(* Testing *)

exception TestFailed of caeValue * caeValue

let test = function 
    (a, b) ->
      if (a = b)
      then true
      else raise (TestFailed (a, b))
	
;;
  
(* Test cases *)

test(interpPosn(mdist mkPosn27),
     NumV(9));;
test(interpPosn(addX mkPosn27 (Num 10)),
     NumV(12));;
test(interpPosn(subY (SSend(mkPosn27, "posn", "factory01", Num(0))) (Num 15)),
     NumV(14));;
test(interpPosn(addDist mkPosn531  mkPosn27),
     NumV(18));;

(* ********************************************* *)

(* Source Language with Inheritance *)

type icae = 
    INum of int
  | IStr of string
  | IAdd of icae * icae
  | ISub of icae * icae
  | IIfZ of icae * icae * icae
  | IArg
  | IThis
  | INew of string * icae list
  | IGet of icae * string
  | ISend of icae * string * icae
  | ISuper of string * icae

and idecl = 
    IClass of string * string * ifield list * imeth list
      
and ifield = IField of string

and imeth = IMethod of string * icae


let findIClass = (find "class"
		    (fun (IClass(name, _, _, _)) -> name))


let rec compileExpr = function
    (expr, thisClass) -> 
      let recur = fun expr -> compileExpr(expr, thisClass)
      in match expr with
	INum(n) -> Num(n)
      | IStr(n) -> Str(n)
      | IAdd(l, r) -> Add(recur l, recur r)
      | ISub(l, r) -> Sub(recur l, recur r)
      | IIfZ(tst, thn, els) -> IfZ(recur tst, 
				   recur thn,
				   recur els)
      | IArg -> Arg
      | IThis -> This
      | INew(s, exprs) -> New(s, List.map recur exprs)
      | IGet(expr, fname) -> Get(recur expr, fname)
      | ISend(expr, mname, argExpr) -> 
	  DSend(recur expr, mname, recur argExpr)
      | ISuper(mname, expr) ->
	  let IClass(_, sname, _, _) = thisClass
	  in SSend(This, sname, mname, recur expr)

let rec compileMethods = function
    sdecl -> 
      let IClass(name, superName, fields, methods) = sdecl 
      in Class(name,
	       List.map 
		 (fun (IField(fname)) -> Field(fname)) 
		 fields,
	       List.map 
		 (fun (IMethod(name, expr)) -> 
		   Method(name, 
			  compileExpr(expr,
				      sdecl)))
		 methods)

let addFields = function
    (superFields, fields) -> List.append superFields fields
	
let rec addReplaceMethods = function
    (methods, []) -> methods
  | (methods, meth::mrest) ->
      addReplaceMethods(addReplaceMethod(methods, meth),
			mrest)
      
and addReplaceMethod = function
    ([], bmeth) -> [bmeth]
  | ((Method(aname, aexpr) as ameth)::arest, 
     (Method(bname, bexpr) as bmeth))
    -> if (aname = bname)
    then bmeth::arest
    else ameth::(addReplaceMethod (arest, bmeth))

let rec flattenClass = function
    (Class(name, fields, methods), idecls, cdecls) -> 
      let IClass(_, superName, _, _) = findIClass name idecls
      in let Class(_, superFields, superMethods) 
	  = if (superName = "object") 
	  then Class("object", [], [])
	  else flattenClass(findClass superName cdecls,
			    idecls, cdecls)
      in Class(name, 
	       addFields(superFields, fields),
	       addReplaceMethods(superMethods, methods))

let iinterp = function
    (idecls, expr)  -> 
      let expr 
	  = compileExpr(expr, IClass("bad", "bad", [], []))
      in let cdeclsNotFlat
	  = (List.map (fun sdecl -> compileMethods(sdecl))
	       idecls)
      in let cdecls 
	  = (List.map (fun cdecl -> flattenClass(cdecl, 
						 idecls,
						 cdeclsNotFlat))
	       cdeclsNotFlat)
      in interp(expr, cdecls, NumV(0), NumV(0))
	
(* Examples *)

let sposnClass = IClass("posn", "object",
			[IField("x"); IField("y")],
			[IMethod("mdist", IAdd(IGet(IThis, "x"), IGet(IThis, "y")));
			 IMethod("addDist", IAdd(ISend(IThis, "mdist", INum(0)),
						 ISend(IArg, "mdist", INum(0))))])
    
let sposn3DClass = IClass("posn3D", "posn",
			  [IField("z")],
			  [IMethod("mdist", IAdd(IGet(IThis, "z"), 
						 ISuper("mdist", IArg)))])
    
let smkPosn27 = INew("posn", [INum(2); INum(7)])
let smkPosn531 = INew("posn3D", [INum(5); INum(3); INum(1)])

let smdist = fun o -> ISend(o, "mdist", INum(0))
let saddDist = fun o p -> ISend(o, "addDist", p)

let sinterpPosn = fun x -> iinterp([sposnClass;sposn3DClass], x)

;;

(* Test cases *)

test(sinterpPosn(smdist smkPosn27),
     NumV(9));;
test(sinterpPosn(smdist smkPosn531),
     NumV(9));;
test(sinterpPosn(saddDist smkPosn531 smkPosn27),
     NumV(18));;
test(sinterpPosn(saddDist smkPosn27 smkPosn531),
     NumV(18));;

(* ********************************************* *)

(* Source language with types --- only the declarations have to change *)

type tcdecl = TClass of string * string * tfield list * tmeth list
      
and tfield = TField of string * te
    
and tmeth = TMethod of string * te * te * icae
    
and te = 
    NumTE
  | StrTE
  | ObjTE of string

and ty = 
    NumT
  | StrT
  | ObjT of string

(* Type checking *)

let findTClass = (find "class"
		    (fun (TClass(name, _, _, _)) -> name))
let findTField = (find "field"
		    (fun (TField(name, _)) -> name))
let findTMethod = (find "method"
		     (fun (TMethod(name, _, _, _)) -> name))

let parseType = function
    NumTE -> NumT
  | StrTE -> StrT
  | ObjTE(s) -> ObjT(s)

let rec getAllFieldTypes = function
    (cname, tdecls) -> 
      if (cname = "object")
      then []
      else let TClass(_, sname, fields, _) = findTClass cname tdecls
      in (List.append 
	    (getAllFieldTypes (sname, tdecls))
	    (List.map (fun (TField(_, te)) -> parseType te)
	       fields))

let rec findInTree = fun
  findInList extract (name, tdecl, tdecls) -> 
    let items = extract tdecl
    and TClass(_, sname, _, _) = tdecl
    in try (findInList name items)
    with exn -> if (sname == "object")
    then raise exn
    else (findInTree findInList extract
	    (name, findTClass sname tdecls, tdecls))
	  
let findFieldInTree = (findInTree findTField
			 (fun (TClass(_, _, fields, _)) -> fields))
	
let findMethodInTree = (findInTree findTMethod
			  (fun (TClass(_, _, _, methods)) -> methods))

let rec andmap2 = fun f l1 l2 
    -> match (l1, l2) with
      (a::arest, b::brest) ->
	(f a b) & (andmap2 f arest brest)
    | ([], []) -> true
    | _ -> false

let rec isSubClass = function
    (aname, bname, tdecls) -> 
      if (aname = bname)
      then true
      else if (aname = "object")
      then false
      else let TClass(_, sname, _, _) = findTClass aname tdecls
      in isSubClass(sname, bname, tdecls)

let isSubType = function
    (ObjT(aname), ObjT(bname), tdecls) ->
      isSubClass(aname, bname, tdecls)
  | (NumT, NumT, _) -> true
  | (StrT, StrT, _) -> true
  | _ -> false

exception NoType of icae * string

let rec typecheckExpr = function
    (expr, tdecls, argTy, thisClass) -> 
      let recur = fun expr -> typecheckExpr(expr, tdecls, argTy, thisClass)
      in match expr with
	INum(n) -> NumT
      | IStr(n) -> StrT
      | IAdd(l, r) -> 
	  (match (recur l, recur r) with
	    (NumT, NumT) -> NumT
	  | _ -> raise (NoType(expr, "not numbers")))
      | ISub(l, r) -> 
	  (match (recur l, recur r) with
	    (NumT, NumT) -> NumT
	  | _ -> raise (NoType(expr, "not numbers")))
      | IIfZ(tst, thn, els) -> 
	  (match (recur tst) with
	    NumT -> 
	      let thnty = recur thn
	      and elsty = recur els
	      in if (isSubType(thnty, elsty, tdecls))
	      then elsty
	      else if (isSubType(elsty, thnty, tdecls))
	      then thnty
	      else raise (NoType (expr, "branch mismatch"))
	  | _ -> raise (NoType(expr, "test is non-number")))
      | IArg -> argTy
      | IThis -> 
	  let TClass(name, _, _, _) = thisClass
	  in ObjT(name)
      | INew(cname, exprs) -> 
	  let argTys = List.map recur exprs
	  and fieldTys = getAllFieldTypes(cname, tdecls)
	  in if (andmap2 (fun t1 t2 -> isSubType(t1, t2, tdecls)) 
		   argTys fieldTys)
	  then ObjT(cname)
	  else raise (NoType(expr, "field type mismatch"))
      | IGet(expr, fname) -> 
	  (match (recur expr) with 
	    ObjT(cname) ->
	      let TField(_, fieldTE) 
		  = findFieldInTree(fname,
				    findTClass cname tdecls,
				    tdecls)
	      in parseType(fieldTE)
	  | _ -> raise (NoType(expr, "not an object for get")))
      | ISend(expr, mname, argExpr) -> 
	  (match (recur expr) with 
	    ObjT(cname) ->
	      typecheckSend(cname, mname, argExpr, tdecls, recur)
	  | _ -> raise (NoType(expr, "not an object for send")))
      | ISuper(mname, argExpr) ->
	  let TClass(_, sname, _, _) = thisClass
	  in typecheckSend(sname, mname, argExpr, tdecls, recur)

and typecheckSend = function 
    (cname, mname, argExpr, tdecls, recur) -> 
      let TMethod(_, argTE, resultTE, _) 
	  = findMethodInTree(mname,
			     findTClass cname tdecls,
			     tdecls)
      in if (isSubType((recur argExpr), parseType(argTE), tdecls))
      then parseType(resultTE)
      else raise (NoType(argExpr, "arg type mismatch"))

let typecheckMethod = function
    (TMethod(_, argTE, resultTE, body), tdecl, tdecls) ->
      let bodyT = typecheckExpr(body, tdecls, parseType argTE, tdecl)
      in if (isSubType(bodyT, (parseType resultTE), tdecls))
      then ()
      else raise(NoType(body, "result type mismatch"))

exception BadOverride of string

let checkOverride = function
    (TMethod(mname, argTE, resultTE, _), tdecl, tdecls) ->
      let TClass(_, sname, _, _) = tdecl
      in try let TMethod(_, sArgTE, sResultTE, _) 
	  = findMethodInTree(mname,
			     findTClass sname tdecls,
			     tdecls)
      in if ((sArgTE = argTE) & (sResultTE = resultTE))
      then ()
      else raise(BadOverride(mname))
      with (NoSuch _) -> ()

let typecheck = function
    (tdecls, expr)  -> 
      let _ = (List.map 
		 (fun tdecl ->
		   let TClass(_, _, _, methods) = tdecl
		   in (List.map (fun m -> (typecheckMethod(m, tdecl, tdecls);
					   checkOverride(m , tdecl, tdecls)))
			 methods))
		 tdecls)
      in typecheckExpr(expr, tdecls, NumT, TClass("bad", "bad", [], []))

let stripTypes = function
    TClass(name, sname, fields, methods) ->
      IClass(name, sname,
	     (List.map (fun (TField(n,te)) -> IField(n)) 
		fields),
	     (List.map (fun (TMethod(n,ate,rte,body)) -> IMethod(n, body)) 
		methods))

let tinterp = function
    (tdecls, expr) ->
      iinterp(List.map stripTypes tdecls, expr)

(* Examples *)

let tposnClass = TClass("posn", "object",
			[TField("x", NumTE); TField("y", NumTE)],
			[TMethod("mdist", NumTE, NumTE, IAdd(IGet(IThis, "x"), IGet(IThis, "y")));
			 TMethod("addDist", ObjTE("posn"), NumTE,
				 IAdd(ISend(IThis, "mdist", INum(0)),
				      ISend(IArg, "mdist", INum(0))))])
    
let tposn3DClass = TClass("posn3D", "posn",
			  [TField("z", NumTE)],
			  [TMethod("mdist", NumTE, NumTE,
				   IAdd(IGet(IThis, "z"), 
					ISuper("mdist", IArg)))])

let tsquareClass = TClass("square", "object",
			  [TField("topleft", ObjTE("posn"))],
			  [])
    
let tinterpPosn = fun x -> tinterp([tposnClass;tposn3DClass], 
				   x)
let typecheckPosn = fun x -> typecheck([tposnClass;tposn3DClass;tsquareClass], x)

(* More Testing *)

exception TyTestFailed of ty * ty

let tytest = function 
    (a, b) ->
      if (a = b)
      then true
      else raise (TyTestFailed (a, b))

let notytest = function 
    thunk -> try (thunk (); raise (Failed "no exception!?")) with 
      BadOverride _ -> true
    | NoType(_, _) -> true
    | NoSuch(_, _) -> true

;;

(* Test cases *)

test(tinterpPosn(smdist smkPosn27),
     NumV(9));;
test(tinterpPosn(smdist smkPosn531),
     NumV(9));;
test(tinterpPosn(saddDist smkPosn531 smkPosn27),
     NumV(18));;
test(tinterpPosn(saddDist smkPosn27 smkPosn531),
     NumV(18));;

tytest(typecheckPosn(smdist smkPosn27),
       NumT);;
tytest(typecheckPosn(smdist smkPosn531),
       NumT);;
tytest(typecheckPosn(saddDist smkPosn531 smkPosn27),
       NumT);;
tytest(typecheckPosn(saddDist smkPosn27 smkPosn531),
       NumT);;

tytest(typecheckPosn(INew("square", [INew("posn", [INum(0); INum(1)])])),
       ObjT("square"));;
tytest(typecheckPosn(INew("square", [INew("posn3D", [INum(0); INum(1); INum(3)])])),
       ObjT("square"));;

notytest(fun () -> typecheckPosn(smdist (INum(10))));;
notytest(fun () -> typecheck([tposnClass;
			      TClass("other", "posn",
				     [],
				     [TMethod("mdist", ObjTE("object"), NumTE, INum(10))])],
			     INum(10)));;


interp(Num(0),
       [],
       NumV(0),
       NumV(0));; (* should be NumV(0) *)

interp(New("simple", []),
       [Class("simple", [], [])],
       NumV(0),
       NumV(0));; (* should be ObjV(Class("simple", "object", [], []), []) *)

interp(Get(New("simple", [Num(12)]), "z"),
       [Class("simple", [Field("z")], [])],
       NumV(0),
       NumV(0));; (* should be NumV(12) *)

interp(DSend(New("simple", [Num(12)]), "add", Num(17)),
       [Class("simple", [Field("z")],
              [Method("add", Add(Get(This, "z"), Arg))])],
       NumV(0),
       NumV(0));; (* should be NumV(29) *)


(* ... *)

let posn =
  TClass("posn",
	 "object",
	 [TField("x", NumTE);
	  TField("y", NumTE)],
	 [TMethod("mdist",
		  NumTE,
		  NumTE,
		  IAdd(IGet(IThis, "x"),
		       IGet(IThis, "y")))
	 ]);;

let posn3D =
  TClass("posn3D",
	 "posn",
	 [TField("z", NumTE)],
	 [TMethod("mdist",
		  NumTE,
		  NumTE,
		  IAdd(IGet(IThis, "z"),
		      (ISuper("mdist", INum(0))))
		 )]);;

let animal =
  TClass("animal",
	 "object",
	 [TField("name", StrTE);
	  TField("weight", NumTE);
	  TField("BirthYear", NumTE);
	  TField("food", StrTE);
	  TField("location", ObjTE("posn3D"))],
	 [TMethod("GetWeight",
		  NumTE,
		  NumTE,
		  IGet(IThis, "weight"));
	  TMethod("GetAge",
		  NumTE,
		  NumTE,
		  ISub(IArg,
		       IGet(IThis, "BirthYear")))
	 ]);;

let snake =
  TClass("snake",
	 "animal",
	 [TField("scales", StrTE)],
	 [TMethod("GetScales",
		  StrTE,
		  StrTE,
		  IGet(IThis, "scales"))]
	);;

let mkPosn3D_7_8_1 =
  INew("posn3D",
       [INum(7);
	INum(8);
	INum(1)]);;

let mksnake1 =
  INew("snake",
      [IStr("Johnny");
       INum(2);
       INum(2000);
       IStr("rats");
       mkPosn3D_7_8_1;
       IStr("dull");
       ]);;

tytest(typecheck([posn;posn3D;snake;animal],
		 mksnake1),
       ObjT("snake"));;

test(tinterp([posn;posn3D;snake;animal],
             IGet(mksnake1, "scales")),
     StrV("dull"));;
tytest(typecheck([posn;posn3D;snake;animal],
		 IGet(mksnake1, "scales")),
       StrT);;