(**
** Lattakia Compiler
** Columbia University COMS-4115
** Programming Languages and Translators
** Authors:
** Wael Salloum
** Katherine Scott
**)
(* Semantic Analysis *)

open Ast
open LatticeCreation
open PrintLattice
(*
***   Basic concept here:
***   descend down the AST and drag the envType with us
***   - if we can find a check to do, do it, if we hit an error 
***   add it to the environment
*)

(**
   ***   FOR THE REPORT
   ***   Each lattakia type is made up of:
   ***   dataStructTypeType =  dataTypeType * structureTypeType
   ***   We need to have multiple levels of semantic checking
   ***   We have three primitive types (structureTypeType)
   ***   (seqlat, altlat, wrd) These can only do operations 
   ***   between ones of the same type
   ***   i.e. 
   ***   seqlat(op)seqlat ...
   ***  
   ***   Additionally inside each primitive type there is what 
   ***   we call a specific type (dataTypeType) which is int, float, string, boolean. 
   ***   If the primitive type matches then we need to on and check that 
   ***   each specific type also matches. 
   ***
   **)

let dataTypeToString _dataType = 
	match _dataType with Int -> "int" | Float -> "float" | Boolean -> "boolean" | String -> "string" | General -> "general"  
									| UnresolvedType -> "unresolved" | Diverse -> "diverse" | MismatchType -> "mismatch"

let structTypeToString _dataType = 
	match _dataType with Seq -> "seqlat" | Alt -> "altlat" | Wrd -> "predicate" | UndeterminedStruct -> "undetermined"

let dataStructTypeToString _dataStructTuple = "("^(dataTypeToString(fst _dataStructTuple))^", "^(structTypeToString(snd _dataStructTuple)) ^ ")" 

(*------------------------------------------------------------------------------------------------*)	  
(********************************************************************)
(********************************************************************)
(********************************************************************)
type symanticEnv = {
		mutable currentLat: latticeFields; 
		mutable parentStack: latticeFields list;
}
let symEnv = {currentLat = LatticeCreation.createEmptyLattice []; parentStack = []}	
	 
let rec analyzeSemantics _lattice  = (*return an error string -if it is empty we are good*)
 		let latticeType = processLatticeReturnType _lattice in (_lattice, latticeType) 

and processLatticeReturnType (_lattice: latticeFields)  = (*input a latticeFields, which is our AST*) 
    let latticeType = (match _lattice.lattice with 
    | Seqlat(seqlat) -> (
				symEnv.parentStack <- symEnv.currentLat :: symEnv.parentStack (*PUSH*); 
				symEnv.currentLat <- _lattice; 
				let seqlatString = processSeqlatReturnType seqlat in
				symEnv.currentLat <- List.hd symEnv.parentStack (*POP*);
				symEnv.parentStack <- List.tl symEnv.parentStack (*Remove*);
				seqlatString
				) 
    | Altlat(altlat) -> processAltlatReturnType altlat 
    | Predicate(pred) -> processPredicateReturnType pred 
    | Expr(expr) -> processExprReturnType expr 
		) in _lattice.latDataStructType <- latticeType; latticeType

(********************************************************************)	  
and processSeqlatReturnType _seqlat = (*do the seq lat *)
		let hd =  (List.hd _seqlat.elements) in
    getLatticeListType(_seqlat.elements, processLatticeReturnType hd, Diverse)
(********************************************************************)								
and processAltlatReturnType _altlat  = (*do the alt lat *)
		let hd =  (List.hd _altlat.alternatives) in
    let resultType = getLatticeListType(_altlat.alternatives, processLatticeReturnType hd, MismatchType) in
		if (fst resultType) = MismatchType then addToErrorTable(SemTypeMismatch, None) else (); resultType 
(********************************************************************)
(*  go through a lattice list and make sure all of the types are the same *)
and getLatticeListType(_latticeList, (_prevType: dataStructTypeType), (_mismatchType: dataTypeType)) =
    match _latticeList with
    | [] -> _prevType
    | hd::tl -> let (hdType: dataStructTypeType) = processLatticeReturnType hd in
      if ((fst _prevType) = (fst hdType)) && ((snd _prevType) = (snd hdType)) then (getLatticeListType(tl, hdType, _mismatchType)) 
      else (_mismatchType, UndeterminedStruct)   	     
(********************************************************************)
and processPredicateReturnType _pred  =
    (* Use the symbol table to compare predicate types - i.e no int < string *)
    let condReturnType  = (processExprReturnType _pred.condition) in
		let predReturnType = processExprReturnType _pred.expr in
		match condReturnType with
			| (Boolean, Wrd) -> predReturnType
			| (_, _) -> addToErrorTable(SemPredicateTypeNotBoolean, None); (MismatchType, UndeterminedStruct)
(********************************************************************)	 
(* Do a expression return a type*)
and processExprReturnType (_expr: exprFields)  = 
    let exprType = (match _expr.exprCode with
    | ConstExpr(const) -> processConstReturnType const 
    | OpExpr(op) -> processOpReturnType op  (*lookup from symbol table*)
    | NameListExpr(nameList) -> processNameListReturnType(symEnv.currentLat, nameList.nameList)  
    | LatticeExpr(lattice) -> processLatticeReturnType lattice
		) in _expr.exprDataStructType <- exprType; 
		exprType 
(********************************************************************)	  
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 processOpReturnType op = 
    let op1type = if doCheckOperandsBeforeCheckingOperator op.operator then processExprReturnType 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) -> (processExprReturnType 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.processOpReturnType(): DirectAccesss: nameList!")) in
				let lattice = (match op.operand1.exprCode with LatticeExpr(lat) -> lat | _ -> rf("BUG: SemanticAnalysis.processOpReturnType(): DirectAccesss: lattice!")) in
				processNameListReturnType(lattice, nameList)
			| FuncCall ->
				let funcNameList = (match op.operand1.exprCode with NameListExpr(nameListEx) -> nameListEx.nameList | _ -> rf("BUG: SemanticAnalysis.processOpReturnType(): FuncCall: funcLattice!")) in
				let (idSymOpt, idLatOpt) = try LatticeCreation.findNameListSymbolInLatticeFields(symEnv.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
									processLatticeReturnType(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(symEnv.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 symEnv.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 = processExprReturnType (gs op.operand2 "") in
				match idSymbolOpt with
					| None -> rf("BUG: SymanticAnalysis: Define: NameList-3!")
					| Some(idSymbol) -> (idSymbol.symDataStructType <- rvalueType; rvalueType) 
		  )
(********************************************************************)	        
and processConstReturnType  = 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 processNameListReturnType(_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 
					
(********************************************************************)
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

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 
		
		
		
		
		
		
		
		
		
		
			
	
