(**
** Lattakia Compiler
** Columbia University COMS-4115
** Programming Languages and Translators
** Authors:
** Wael Salloum
**)
(* Clone Lattice *)

open Ast
open LatticeCreation
open PrintLattice

(*------------------------------------------------------------------------------------------------*)	  
(********************************************************************)
(********************************************************************)
(********************************************************************)
type cloneEnv = {
		mutable currentLat: latticeFields; 
		mutable parentStack: latticeFields list;
}
let clnEnv = {currentLat = LatticeCreation.createEmptyLattice []; parentStack = []}	
	 
let rec cloneLattice _lattice _doCloneCode = (*return an error string -if it is empty we are good*)
 		processLattice _lattice _doCloneCode  

and processLattice (_lattice: latticeFields) _doCloneCode = (*input a latticeFields, which is our AST*) 
		{
				latDataStructType = _lattice.latDataStructType;
				latNature = _lattice.latNature;
				latEval = _lattice.latEval;
				paramNameList = _lattice.paramNameList;
				paramTypeList = _lattice.paramTypeList;
				hasChanged = _lattice.hasChanged;
				optimize = _lattice.optimize;
				lattice = if _doCloneCode = false then _lattice.lattice 
						else  (match _lattice.lattice with 
				    | Seqlat(seqlat) -> (
								clnEnv.parentStack <- clnEnv.currentLat :: clnEnv.parentStack (*PUSH*); 
								clnEnv.currentLat <- _lattice; 
								let seqlatClone = Seqlat(processSeqlat seqlat _doCloneCode) in
								clnEnv.currentLat <- List.hd clnEnv.parentStack (*POP*);
								clnEnv.parentStack <- List.tl clnEnv.parentStack (*Remove*);
								seqlatClone
								) 
				    | Altlat(altlat) -> Altlat(processAltlat altlat _doCloneCode) 
				    | Predicate(pred) -> Predicate(processPredicate pred _doCloneCode) 
				    | Expr(expr) -> Expr(processExpr expr _doCloneCode) 
						)
		}

(********************************************************************)	  
and processSeqlat _seqlat _doCloneCode = (*do the seq lat *)
		(*List.map (processLattice)  _seqlat.elements*)
		rf("Not Implemented.")
(********************************************************************)								
and processAltlat _altlat _doCloneCode = (*do the alt lat *)
		(*List.map (processLattice)  _altlat.alternatives*)
		rf("Not Implemented.")
(********************************************************************)
(*  go through a lattice list and make sure all of the types are the same *)
and getLatticeListType(_latticeList, (_prevType: dataStructTypeType), (_mismatchType: dataTypeType)) _doCloneCode=
    (*match _latticeList with
    | [] -> _prevType
    | hd::tl -> let (hdType: dataStructTypeType) = processLattice hd in
      if ((fst _prevType) = (fst hdType)) && ((snd _prevType) = (snd hdType)) then (getLatticeListType(tl, hdType, _mismatchType)) 
      else (_mismatchType, UndeterminedStruct)*)
					rf("Not Implemented.")   	     
(********************************************************************)
and processPredicate _pred _doCloneCode =
    (* Use the symbol table to compare predicate types - i.e no int < string *)
    (*let cond  = (processExpr _pred.condition) in
		let pred = processExpr _pred.expr in
		match cond with
			| (Boolean, Wrd) -> pred
			| (_, _) -> addToErrorTable(SemPredicateTypeNotBoolean, None); (MismatchType, UndeterminedStruct)*)
		rf("Not Implemented.")
(********************************************************************)	 
(* Do a expression return a type*)
and processExpr (_expr: exprFields) _doCloneCode = 
			{
					exprDataStructType = _expr.exprDataStructType;
					exprCode = if _doCloneCode = false then _expr.exprCode else rf("Not Implemented.")
						(*match _expr.exprCode with
						| ConstExpr(const) -> processConst const 
						| OpExpr(op) -> processOp op  (*lookup from symbol table*)
						| NameListExpr(nameList) -> processNameList(clnEnv.currentLat, nameList.nameList)  
						| LatticeExpr(lattice) -> processLattice lattice _doCloneCode 
						*)
						; (*ConstExpr | LatticeExpr | OpExpr | NameListExpr *)
					exprEval = cloneExprEval _expr.exprEval; (*ConstExpr | LatticeExpr *)
					exprChanged = _expr.exprChanged; (*a constant cannot change*)
					expDependers = _expr.expDependers;
					expDependees = _expr.expDependees;
			}

and cloneExprEval _exprEval = 
	match _exprEval with 
		| ConstValue(x) -> ConstValue(x)
		| LatticeValue(lat) -> LatticeValue(processLattice lat true)
		| NotEvaluated -> NotEvaluated
(********************************************************************)	  
and isWordOperator = function
	| Plus -> true | Minus -> true | Times -> true | Divide -> true | Percent -> true | Or -> true | And -> true | Less -> true  
	| UniMinus -> true | Not -> true | LessOrEqual -> true | Greater -> true | GreaterOrEqual -> true
	| _ -> false 
	(*Tilde | Eval | DontOpt | Let | DirectAccess | Assign | FuncCall | Define | Equal | NotEqual*)
and doCheckOperandsBeforeCheckingOperator = function
	| Plus -> true | Minus -> true | Times -> true | Divide -> true | Percent -> true | Or -> true | And -> true | Less -> true  
	| UniMinus -> true | Not -> true | LessOrEqual -> true | Greater -> true | GreaterOrEqual -> true
	| Tilde -> true | Eval -> true | DontOpt -> true | Let -> true | DirectAccess -> false | Assign -> true 
	| FuncCall -> true | Define -> false | Equal -> true | NotEqual -> true

(* given an operation expression return the type it _should_ return *)
and processOp op = 
		rf("Not Implemented.")
(*		let op1type = if doCheckOperandsBeforeCheckingOperator op.operator then processExpr op.operand1 else (General, Wrd) in 
    let op2type = if doCheckOperandsBeforeCheckingOperator op.operator then 
      (match op.operand2 with
      |	None -> (General, Wrd) (*Apply to all: most general case*) 
      |	Some(opr) -> (processExpr opr)) else (General, Wrd) in
    if (isWordOperator op.operator) 
				&& (match (snd op1type, snd op2type) with
							| (Wrd, Wrd) -> false (*No problem*)
							| (_,_) -> true) 
		then (MismatchType, UndeterminedStruct)
		else
			(match op.operator with
(* Arithmatic Operations *)
	    | Plus -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Int, Wrd)
							| (Float, Float) -> (Float, Wrd)
							| (String, String) -> (String, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
		  | Minus -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Int, Wrd)
							| (Float, Float) -> (Float, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						) 
	    | Times -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Int, Wrd)
							| (Float, Float) -> (Float, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
	    | Divide  -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Int, Wrd)
							| (Float, Float) -> (Float, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
	    | Percent -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Int, Wrd)
							| (Float, Float) -> (Float, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
	    | UniMinus -> ( 
					 match (fst op1type) with
							| (Int) -> (Int, Wrd)
							| (Float) -> (Float, Wrd)
							| (General) -> (General, Wrd)
							| (_) -> (MismatchType, Wrd)
						)
(* Logical Operations *)
	    | Or -> ( 
					 match (fst op1type, fst op2type) with
							| (Boolean, Boolean) -> (Boolean, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						) 
	    | And -> ( 
					 match (fst op1type, fst op2type) with
							| (Boolean, Boolean) -> (Boolean, Wrd)
							| (General, t) -> (t, Wrd)
							| (t, General) -> (t, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
	    | Not -> ( 
					 match (fst op1type) with
							| (Boolean) -> (Boolean, Wrd)
							| (General) -> (General, Wrd)
							| (_) -> (MismatchType, Wrd)
						)
(* Comparison Operations *)
	    | Equal -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						) 	
	    | NotEqual -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)
	    | Less -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)  
	    | LessOrEqual -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						)  
	    | Greater -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						) 
	    | GreaterOrEqual -> ( 
					 match (fst op1type, fst op2type) with
							| (Int, Int) -> (Boolean, Wrd)
							| (Float, Float) -> (Boolean, Wrd)
							| (String, String) -> (Boolean, Wrd)
							| (General, t) -> (Boolean, Wrd)
							| (t, General) -> (Boolean, Wrd)
							| (_,_) -> (MismatchType, Wrd)
						) 
(* Misc Operations: Tilde | Eval | DontOpt | Let | DirectAccess | Assign | FuncCall | Define | Equal | NotEqual*)

	    | Tilde -> 
					let structType = (match (snd op1type, snd op2type) with
								| (Wrd, Wrd) -> Seq
								| (Wrd, x) -> x
								| (Seq, _) -> Seq
								| (Alt, _) -> Alt
								| (UndeterminedStruct, _) -> UndeterminedStruct
							) in
					let dataType = (match (fst op1type, fst op2type) with
								| (Int, Int) -> Int
								| (Float, Float) -> Float
								| (String, String) -> String
								| (Boolean, Boolean) -> Boolean
								| (General, t) -> t
								| (t, General) -> t
								| (UnresolvedType, _) -> UnresolvedType
								| (_, UnresolvedType) -> UnresolvedType
								| (MismatchType, _) -> MismatchType
								| (_, MismatchType) -> MismatchType
								| (_,_) -> Diverse
							) in
					(match (dataType, structType) with
						| (Diverse, Alt) -> (MismatchType, Alt)
						| (_, _) -> (dataType, structType))
	    | Eval -> ( 
					 match (fst op1type, snd op1type) with
							| (x, Wrd) -> (x, Wrd)
							| (x, Seq) -> (x, UndeterminedStruct)
							| (x, Alt) -> (x, UndeterminedStruct)
							| (_,_) -> (MismatchType, Wrd)
						) 
	    | DontOpt -> op1type 
	    | Let -> (General, Wrd) 
			| DirectAccess -> 
				let nameList = (match (gs op.operand2 "").exprCode with NameListExpr(nameListEx) -> nameListEx.nameList | _ -> rf("BUG: SemanticAnalysis.processOp(): DirectAccesss: nameList!")) in
				let lattice = (match op.operand1.exprCode with LatticeExpr(lat) -> lat | _ -> rf("BUG: SemanticAnalysis.processOp(): DirectAccesss: lattice!")) in
				processNameList(lattice, nameList)
			| FuncCall ->
				let funcNameList = (match op.operand1.exprCode with NameListExpr(nameListEx) -> nameListEx.nameList | _ -> rf("BUG: SemanticAnalysis.processOp(): FuncCall: funcLattice!")) in
				let (idSymOpt, idLatOpt) = try LatticeCreation.findNameListSymbolInLatticeFields(clnEnv.currentLat, funcNameList) 
							with Not_found -> addToErrorTable(SemUndefinedIdentifier(PrintLattice.processNameList {parent = None; hash = StringMap.empty} funcNameList), None); (None, None) 
							in
				(match idLatOpt with
					| None -> (UnresolvedType, UndeterminedStruct)
					| Some(funcLattice) -> ( 
							let expr = (gs op.operand2 "") in
							let lattice = (match expr.exprCode with LatticeExpr(lat) -> lat | _ -> createEmptyLattice [createLatticeFieldsFromLatticeType (Expr(expr))]) in
							if funcLattice.paramNameList = None then (MismatchType, UndeterminedStruct) 
							else if funcLattice.paramTypeList = None then (
								if calcParamTypeList(lattice, funcLattice) then
									processLattice(funcLattice)
								else
									(MismatchType, UndeterminedStruct)
								)
							else
								if checkParameterTypes(funcLattice.paramTypeList, lattice) then
									funcLattice.latDataStructType
								else
									(MismatchType, UndeterminedStruct)
							))
			| Assign ->
				let nameList = (match op.operand1.exprCode with NameListExpr(n) -> n.nameList | _ -> rf("BUG: SymanticAnalysis: Assign: NameList-2!")) in 
				let (idSymOpt, idLatOpt) = try LatticeCreation.findNameListSymbolInLatticeFields(clnEnv.currentLat, nameList) 
						with Not_found -> addToErrorTable(SemUndefinedIdentifier(PrintLattice.processNameList {parent = None; hash = StringMap.empty} nameList), None); (None, None)
						in
				let idSymbolType = (match idSymOpt with
					| None -> (UnresolvedType, UndeterminedStruct)
					| Some(idSymbol) -> idSymbol.symDataStructType) in  
				let rvalueType = 
					 (match (fst idSymbolType, fst op2type) with
							| (General, t) -> (t, snd op2type)
							| (t, General) -> (t, snd op2type)
							| (x, y) -> if x = y then (x, snd op2type) else (MismatchType, snd op2type)
						) in rvalueType
			| Define -> 
				let idSymbolOpt = LatticeCreation.findInSymbolTable((LatticeCreation.getSymbolTableFromSeqlat clnEnv.currentLat), 
						(match op.operand1.exprCode with NameListExpr(n) -> 
							(match List.hd n.nameList with Id(x) -> x | _ -> rf("BUG: SymanticAnalysis: Define: NameList-1!")) 
							| _ -> rf("BUG: SymanticAnalysis: Define: NameList-2!"))) in
				let rvalueType = processExpr (gs op.operand2 "") in
				match idSymbolOpt with
					| None -> rf("BUG: SymanticAnalysis: Define: NameList-3!")
					| Some(idSymbol) -> (idSymbol.symDataStructType <- rvalueType; rvalueType) 
		  )*)
(********************************************************************)	        
and processConst  = function (*return the type so we can do type checking*)
    | StringLiteral(_) -> (String, Wrd)
    | IntLiteral(_) -> (Int, Wrd)
    | FloatLiteral(_) -> (Float, Wrd)
    | Epsilon -> (General, Wrd)
    | Nil -> (General, Wrd)
    | True -> (Boolean, Wrd)
    | False -> (Boolean, Wrd)
(********************************************************************)
(* make sure that x.y.z is in the right symbol table scope*)	
and processNameList(_lattice, _nameList)  =
(*				let (idSymOpt, idLatOpt) = try LatticeCreation.findNameListSymbolInLatticeFields(_lattice, _nameList) 
							with Not_found -> addToErrorTable(SemUndefinedIdentifier(PrintLattice.processNameList {parent = None; hash = StringMap.empty} _nameList), None); (None, None) 
							in
				let idSymbolType = (match idSymOpt with
					| None -> (UnresolvedType, UndeterminedStruct)
					| Some(idSymbol) -> idSymbol.symDataStructType
				) in idSymbolType 
*)
		rf("Not Implemented.")				
(********************************************************************)
and checkParameterTypes(_paramTypeList, _paramValueLattice) =
		(*let elements = getSeqlatElementsFromLatticeFields _paramValueLattice in
		List.fold_left2 (fun a b c -> a && (b == c.latDataStructType)) true (gs _paramTypeList "BUG: checkParameterTypes!") elements*)
		rf("Not Implemented.")
		
and calcParamTypeList(_paramLattice, _funcLattice) =
		(*let elements = getSeqlatElementsFromLatticeFields _paramLattice in
		if (List.length elements) <> (List.length (gs _funcLattice.paramNameList "BUG: calcParamTypeList")) then false
		else let paramTypeList = List.map (fun x -> x.latDataStructType) elements in
			_funcLattice.paramTypeList <- Some(paramTypeList); true*) 
		rf("Not Implemented.")
		
		
		
		
		
		
		
		
		
			
	
