open Ast
(*************************************************************************************)
(*****************   Helpers (Auxiliary Function)    *********************************)
(*************************************************************************************)

let rf (*raise failure*) str = raise (Failure(str))
let gs (*get Some*) opt msg = match opt with Some(value) -> value | _ -> (rf(if(String.length msg) = 0 then "BUG" else msg))
let incr_linenum lexbuf = 
		let pos = lexbuf.Lexing.lex_curr_p in 
		lexbuf.Lexing.lex_curr_p <- { pos with
			Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 
			Lexing.pos_bol = pos.Lexing.pos_cnum;
		};
		env.lineNumber <- pos.Lexing.pos_lnum;
		env.charOffset <- pos.Lexing.pos_cnum;
	;;
let addToErrorTable ((_errorMessage: errorMessageType), (_errorPlace: exprCodeType option)) = 
(*	let start_pos = Parsing.rhs_start_pos 3 in  Parsing.
	let end_pos = Parsing.rhs_end_pos 3 in 
	printf "%d.%d-%d.%d: division by zero"
start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)
end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);*)
	env.errorTable <- {errMessage = _errorMessage; errPlace = _errorPlace; lineNum = env.lineNumber; offset = env.charOffset} :: env.errorTable;
	;; 

let addToWorningTable ((_errorMessage: errorMessageType), (_errorPlace: exprCodeType option)) = 
	env.worningTable <- {errMessage = _errorMessage; errPlace = _errorPlace; lineNum = env.lineNumber; offset = env.charOffset} :: env.worningTable
	;; 

let createEmptyLattice _elements = 
		{
				latDataStructType = (UnresolvedType, Seq);
				latNature = Object;
				latEval = None;
				paramNameList = None;
				paramTypeList = None;
				hasChanged = true;
				optimize = true;
				lattice = Seqlat {elements = _elements; symbols = {parent=None; hash=StringMap.empty}};
		}
;;

let createLatticeFieldsFromLatticeType latticeTypeRecord=
		{
				latDataStructType = (UnresolvedType, UndeterminedStruct);
				latNature = Object;
				latEval = None;
				paramNameList = None;
				paramTypeList = None;
				hasChanged = true;
				optimize = true;
				lattice = latticeTypeRecord;
		}
	;;

let createNewLatFromLatEnvTuple(_latticeEnvTuple, (_symbolTable: symbolTableType)) =
	let (latticeElements, latEnv) = _latticeEnvTuple in
		if (List.length latticeElements <= 1) && (StringMap.is_empty _symbolTable.hash) && false then  
			let innerLatFields = List.hd latticeElements in (match innerLatFields.lattice with
				| Seqlat(innerSeqlat) -> innerSeqlat.symbols.parent <- _symbolTable.parent
				| _ -> ());
				innerLatFields
		else
			let innerSeqlat = 
							Seqlat {
								elements = latticeElements; 
								symbols = _symbolTable;
							} in
			 createLatticeFieldsFromLatticeType innerSeqlat

let createExprFieldsFromLatticeFields (_latFields: Ast.latticeFields) =
			{
					exprDataStructType = _latFields.latDataStructType;
					exprCode = LatticeExpr(_latFields); (*ConstExpr | LatticeExpr | OpExpr | NameListExpr *)
					exprEval = NotEvaluated; (*ConstExpr | LatticeExpr *)
					exprChanged = true; (*a constant cannot change*)
					expDependers = [];
					expDependees = [];
			}

let createExprFieldsFromExprCodeType(exprCode: Ast.exprCodeType) =
			{
					exprDataStructType = (UnresolvedType, UndeterminedStruct);
					exprCode = exprCode; (*ConstExpr | LatticeExpr | OpExpr | NameListExpr *)
					exprEval = NotEvaluated; (*ConstExpr | LatticeExpr *)
					exprChanged = true; (*a constant cannot change*)
					expDependers = [];
					expDependees = [];
			}

let convertExprValueTypeToExprCodeType(exprValue: Ast.exprValueType) =
		(match exprValue with 
			| ConstValue(const) -> ConstExpr(const)
			| LatticeValue(lat) -> LatticeExpr(lat)
			| NotEvaluated -> ConstExpr(Nil)
		)
		
(*A shorter name only*)
let newExprFields (exprCode: Ast.exprCodeType) = createExprFieldsFromExprCodeType exprCode

let getDataTypeForPredefinedLabel id = match id with
	  0 -> Int (*LENGTH*)
	| 1 -> Int (*COUNT*)
	| 2 -> UnresolvedType (*CLONE*)
	| 3 -> UnresolvedType (*REVERSE*)
	| 4 -> UnresolvedType (*RETURN*)
	| 5 -> UnresolvedType(*LOOP*)
	| 6 -> General (*GET_LOST*)

	| 10 -> UnresolvedType (*LABELS*) 
	| _ -> raise (Failure ("BUG: getPredefinedLabel(): id our of range: id = "^string_of_int id))
	;;

let getPredefinedLabel id = match id with
	  0 -> LENGTH
	| 1 -> COUNT
	| 2 -> CLONE
	| 3 -> REVERSE
	| 4 -> RETURN
	| 5 -> LOOP
	| 6 -> GET_LOST

	| 10 -> LABELS 
	| _ -> raise (Failure ("BUG: getPredefinedLabel(): id our of range: id = "^string_of_int id))

let rec createNewSymbol (_name, _scope, _paramList, _dependers, _dependees, (_altlatFields: Ast.latticeFields)) =
	let symbolValue = (match _scope with
		| Local -> LocalValueLattice(ref (_altlatFields))
		| Label -> LabelIndex(env.labelIdGenerator)
		| UnresolvedSymbol -> rf("Runtime Exception: createNewSymbol(): UnresolvedSymbol!")
	 ) in
			{
					symName = _name;
					symDataStructType = _altlatFields.latDataStructType;
					symValue = symbolValue;
					symbolScope = _scope;
					parameterNameList = _paramList;
					parameterTypeList = None;
					dependers = _dependers;
					dependees = _dependees;
			}
		

and addParamListToSeqlatSymbols(_paramList, _symbolTable) = 
		let symTable = (match _paramList with
			| [] -> _symbolTable
			| paramName::tl -> ((
				if StringMap.mem paramName _symbolTable.hash then
					addToErrorTable(SemIdentifierMultipleDefinition, None)
				else
					let paramSymbol = createNewSymbol (paramName, Local, None, [], [], (createEmptyLattice [])) in  
					_symbolTable.hash <- StringMap.add paramName paramSymbol _symbolTable.hash); 
				addParamListToSeqlatSymbols(tl, _symbolTable)
				)
			) 
		in symTable 
		

and createNewIntLiteralLattice i = 
			{
					exprDataStructType = (Int, Wrd);
					exprCode = ConstExpr(IntLiteral(i)); (*ConstExpr | LatticeExpr | OpExpr | NameListExpr *)
					exprEval = ConstValue(IntLiteral(i)); (*ConstExpr | LatticeExpr *)
					exprChanged = false; (*a constant cannot change*)
					expDependers = [];
					expDependees = [];
			}

and getSymbolTableFromSeqlat _latticeFieldsSeqlat = match _latticeFieldsSeqlat.lattice with
	| Seqlat(seqlat) -> seqlat.symbols
	| Expr(expr) -> (match expr.exprCode with LatticeExpr(lat) -> getSymbolTableFromSeqlat lat | _ -> rf("BUG: getSymbolTableFromSeqlat()!"))
	| _ -> rf("BUG: getSymbolTableFromSeqlat()!")
	
(*************************************************************************************)
(*For Evaluation*)
and getLatticeFieldsByIndex(_latticeFields, _index) = 
		match _latticeFields.lattice with 
			| Seqlat(seqlat) -> List.nth seqlat.elements _index
			| Expr(expr) -> (match expr.exprCode with LatticeExpr(lat) -> getLatticeFieldsByIndex(lat, _index) | _ -> raise(Not_found))
			| _ -> raise(Not_found)

(*************************************************************************************)
(*Symbol Table*)
and findInCurrentSymbolTable(_symbolTable, _symName) =
			if StringMap.mem _symName _symbolTable.hash then
				Some( StringMap.find _symName _symbolTable.hash ) 
			else
				None

and findInSymbolTable(_symbolTable, _symName) =
			if StringMap.mem _symName _symbolTable.hash then
				Some((StringMap.find _symName _symbolTable.hash)) 
			else
				match _symbolTable.parent with
					| None -> None
					| Some(__symbolTable) -> findInSymbolTable(__symbolTable, _symName)
	
and findRefInSymbolTable(_symbolTable, _symName) =
			if StringMap.mem _symName _symbolTable.hash then
				Some(ref (StringMap.find _symName _symbolTable.hash)) 
			else
				match _symbolTable.parent with
					| None -> None
					| Some(__symbolTable) -> findRefInSymbolTable(__symbolTable, _symName)

(*-------------------------------------------------------------------------------------*)
and findNameTypeSymbolInLatticeFields(_latticeF, _nameType) = 
		let symbolTable = try getSymbolTableFromSeqlat _latticeF with e -> raise Not_found in 
		match _nameType with
			| This -> rf("Not Implemented: 'This'!") 
			| PredefinedLabel(predefinedLabel) -> (None, None)
			| IndexingOp(structureType, latticeT) -> (*uses: Seq (for []), Alt (for {}), and UndeterminedStruct (for @)*) 
						(None, None)
			| HashOp(exprF) -> rf("Not Implemented: 'Hash'!")
			| Id(str) -> 
					let symbolOpt = findInSymbolTable(symbolTable, str) in 
					let latticeOpt = (match symbolOpt with
						| None -> raise (Not_found) 
						| Some(symbol) -> (match (symbol).symValue with 
								| LabelIndex(ind) -> Some(getLatticeFieldsByIndex(_latticeF, ind))
								| LocalValueLattice(latFRef) -> Some(!latFRef)
				)) in
				(symbolOpt, latticeOpt)
			| Each(latticeT) -> (None, None)

and findNameListSymbolInLatticeFields(_latticeF, _nameList) =
		match _nameList with
			| [hd] -> findNameTypeSymbolInLatticeFields(_latticeF, hd)
			| hd::tl -> let (symOpt, latOpt) = findNameTypeSymbolInLatticeFields(_latticeF, hd) in 
				(match latOpt with
					| None -> (symOpt, None)
					| Some(lat) -> findNameListSymbolInLatticeFields(lat, tl)
				)
			| [] -> rf("BUG: getNameListFromSymbolTable!")

(*deprecated*)
and findNameListSymbolInLatticeFieldsOpt(_latticeF, _nameList) =
		try Some(findNameListSymbolInLatticeFields(_latticeF, _nameList)) 
		with _ -> None
(*-------------------------------------------------------------------------------------*)
		 
and addLocalToSymbolTable(_symbolTable, _symName, _paramList, (expr: Ast.exprFields)) = 
		let found = (match findInCurrentSymbolTable(_symbolTable, _symName) with
			| None -> false
			| Some(_) -> true) in
		if found then 
			addToErrorTable(SemIdentifierMultipleDefinition, None)
		else
			let symbol = createNewSymbol(_symName, Local, _paramList, [], [], 
				createLatticeFieldsFromLatticeType (Expr(expr))) in
			_symbolTable.hash <- StringMap.add _symName symbol _symbolTable.hash 

(*************************************************************************************)
(*****************    Lattice Creation Functions     *********************************)
(*************************************************************************************)
let incLabelIdGen lastId = 
		env.labelIdGenerator <- lastId + 1
;;
(* >>>>> lattice: Append lattice list for building a Seqlat <<<<< *)
let appendListForSeqlat(_labAltlat, _lattice) =
		(_labAltlat::_lattice)
	;;

(*************************************************************************************)
(* >>>>> labeled_altlat: Create Labeled Altlat <<<<< *)
let createLabeledAltlat(_label, (_altlat: Ast.latticeType)) =
	let altlatFields = createLatticeFieldsFromLatticeType _altlat in
		ignore (match findInCurrentSymbolTable(env.namesOfCurrLat, _label) with
			| None -> 
					let newLabel = createNewSymbol(_label, Label, None, [], [ref (createExprFieldsFromLatticeFields altlatFields)], altlatFields) in
					env.namesOfCurrLat.hash <- StringMap.add _label newLabel env.namesOfCurrLat.hash;
					newLabel
			| Some(oldLabel) -> 
					addToErrorTable(SemIdentifierMultipleDefinition, Some(LatticeExpr(altlatFields))); 
					oldLabel
		);
		_altlat
		;;

(* >>>>> labeled_altlat: Create Parameterized Labeled Altlat <<<<< *)
let createParamLabeledAltlat(_label, _paramList, (_altlat: Ast.latticeType)) = 
		let altlatFields = createLatticeFieldsFromLatticeType _altlat in
			ignore (match findInCurrentSymbolTable(env.namesOfCurrLat, _label) with
				| None -> 
						let newLabel = createNewSymbol(_label, Label, Some(_paramList), [], [ref (createExprFieldsFromLatticeFields altlatFields)], altlatFields) in
						env.namesOfCurrLat.hash <- StringMap.add _label newLabel env.namesOfCurrLat.hash;
						newLabel
				| Some(oldLabel) -> 
						addToErrorTable(SemIdentifierMultipleDefinition, Some(LatticeExpr(altlatFields))); 
						oldLabel
			);
			let newParamSeqlat = createEmptyLattice [altlatFields] in
			let innerSeqlat = (match newParamSeqlat.lattice with
					| Seqlat(seqlat) -> 
			seqlat.symbols <- (addParamListToSeqlatSymbols(_paramList, seqlat.symbols)); seqlat
					| _ -> rf("BUG: createParamLabeledAltlat()")
			) in
			newParamSeqlat.lattice <- Seqlat(innerSeqlat);
			newParamSeqlat.paramNameList <- Some(_paramList);
			Expr(createExprFieldsFromLatticeFields(newParamSeqlat))
		;;
	 
(*************************************************************************************)
(* >>>>> altlat: Create Parameterized Labeled Altlat <<<<< *)
let createPredicateLattice(_condition, _expr) = Predicate 
			{
				expr = _expr;
				condition = _condition;
			}
	;;
(* >>>>> altlat: Concatenate two list of alternatives to create an Altlat <<<<< *)
let appendListForAltlat((_alt1: latticeType), (_alt2: latticeType)) =
			let list1 = (match _alt1 with 
				| Altlat(alt1) -> alt1.alternatives 
				| _ -> [createLatticeFieldsFromLatticeType(_alt1)]) in
			let list2 = (match _alt2 with 
				| Altlat(alt2) -> alt2.alternatives 
				| _ -> [createLatticeFieldsFromLatticeType(_alt2)]) in
			Altlat {
				alternatives = list1 @ list2;
				each = false;
	}
	;;
(*************************************************************************************)
(*****************    Expression Creation Functions     ******************************)
(*************************************************************************************)
let processSymbolTableKeys _symbolTable = 
		let keyList = StringMap.fold(fun x y z -> x ^", " ^ z) _symbolTable.hash "" in
		keyList

let pushNewSymbolTable _ = 
		let newSymTab = {parent = Some(env.namesOfCurrLat); hash = StringMap.empty} in
		env.namesOfCurrLat <- newSymTab;
		env.parentStackLabelIdGenerator <-  env.labelIdGenerator :: env.parentStackLabelIdGenerator;
		env.labelIdGenerator <- -1

let popOldSymbolTable _ = 
		env.poppedSymbolTable <- env.namesOfCurrLat;
		(match env.namesOfCurrLat.parent with 
			| None -> rf("BUG: createParenthisizedLattice(): No Parent Symbol Table!")
			| Some(parent) -> env.namesOfCurrLat <- parent);
		env.labelIdGenerator <- (List.hd env.parentStackLabelIdGenerator);		
		env.parentStackLabelIdGenerator <- (List.tl env.parentStackLabelIdGenerator)
;;		
		
let createParenthisizedLattice(lattice) = 
		popOldSymbolTable(env);
		let parenthisizedLat = createNewLatFromLatEnvTuple(lattice, env.poppedSymbolTable) in 		
		let latExpr = newExprFields(match parenthisizedLat.lattice with
			| Expr(ex) -> ex.exprCode
			| _ -> LatticeExpr(parenthisizedLat)
			) in
		latExpr

(* >>>>> expr:  <<<<< *)
let createBinOp(op1, op, op2) = 
		OpExpr({operator = op; operand1 = op1; operand2 = Some(op2)}) 

let createUnaryOp(_operator, _operand) = 
		OpExpr({operator = _operator; operand1 = _operand; operand2 = None}) 
	
let createParamLocal (_id, _paramList, (expr: Ast.exprFields)) =
		addLocalToSymbolTable(env.namesOfCurrLat, _id, Some(_paramList), expr);
		let newParamSeqlat = createEmptyLattice [createLatticeFieldsFromLatticeType(Expr(expr))] in
		let innerSeqlat = (match newParamSeqlat.lattice with
				| Seqlat(seqlat) -> 
		seqlat.symbols <- (addParamListToSeqlatSymbols(_paramList, seqlat.symbols)); seqlat
				| _ -> rf("BUG: createParamLabeledAltlat()")
		) in
		newParamSeqlat.lattice <- Seqlat(innerSeqlat);
		newParamSeqlat.paramNameList <- Some(_paramList);
		let newExpr = (createExprFieldsFromLatticeFields(newParamSeqlat)) in
		newExprFields(createBinOp(newExprFields(NameListExpr({nameList = [Id(_id)]})), Define, newExpr))
		

let createLocal ((_id: string), (expr: Ast.exprFields)) = 
		addLocalToSymbolTable(env.namesOfCurrLat, _id, None, expr);
		newExprFields(createBinOp(newExprFields(NameListExpr({nameList = [Id(_id)]})), Define, expr))

let createDirectAccessExprFields(_lattice, _nameList) =
		let latticeExpr = createParenthisizedLattice(_lattice) in
		let seqlatExpr = match latticeExpr.exprCode with
			| LatticeExpr(_) -> latticeExpr
			| _ -> newExprFields(LatticeExpr(createEmptyLattice [createLatticeFieldsFromLatticeType (Expr(latticeExpr))])) 
		in newExprFields(createBinOp(seqlatExpr, DirectAccess, newExprFields(NameListExpr(_nameList))))

(* >>>>> lvalue:  <<<<< *)

(* >>>>> name: AND rest_of_name:  <<<<< *)
let combineTwoNameLists(first, second) = first.nameList <- first.nameList @ second.nameList; first 

(* >>>>> at_operation:  <<<<< *)
let createAtOperation (_offsetExprFields: exprFields)= 
		let (offsetExprFields: exprFields) = _offsetExprFields in
		let currentIndex = newExprFields(NameListExpr({nameList = [PredefinedLabel(INDEX)]})) in
		let calculatedIndex = newExprFields(createBinOp(currentIndex,Plus,offsetExprFields)) in
		{ nameList = [PredefinedLabel(SUBJECT); IndexingOp(UndeterminedStruct, Expr(calculatedIndex))] }

let createAtOperationOfInt (_offset: int) = 
		let (offsetExprFields: exprFields) = newExprFields(ConstExpr(IntLiteral(_offset))) in
		createAtOperation(offsetExprFields)

let createAtOperationOfId (_offset: string) =
		let (offsetExprFields: exprFields) = newExprFields(NameListExpr({nameList = [Id(_offset)]})) in
		createAtOperation(offsetExprFields)

let createAtOperationOfAltlat (_offset: latticeType) =
		let (offsetExprFields: exprFields) = 
			newExprFields(LatticeExpr(createLatticeFieldsFromLatticeType(_offset))) in
		createAtOperation(offsetExprFields)


(**********************************************************************************************************)
let rec getSeqlatFromLatticeFields _latticeFRef = match (!_latticeFRef).lattice with
			| Seqlat(seqlat) -> ref seqlat
			| Expr(expr) -> (match expr.exprCode with LatticeExpr(lat) -> getSeqlatFromLatticeFields (ref lat) | _ -> rf("BUG: getSymbolTableFromSeqlat()!"))
			| _ -> rf("BUG: Expected Seqlat but not found!")

let rec setSeqlatFromLatticeFields(_latticeFRef, _seqlat) = match (!_latticeFRef).lattice with
			| Seqlat(seqlat) -> ((!_latticeFRef).lattice <- Seqlat(!_seqlat); _latticeFRef)
			| Expr(expr) -> (match expr.exprCode with 
					| LatticeExpr(lat) -> (let resLat = setSeqlatFromLatticeFields((ref lat), _seqlat) in 
							expr.exprCode <- LatticeExpr(!resLat); (!_latticeFRef).lattice <- Expr(expr); _latticeFRef)
					| _ -> rf("BUG: getSymbolTableFromSeqlat()!"))
			| _ -> rf("BUG: Expected Seqlat but not found!")

let getSeqlatElementsFromLatticeFields _latticeF = match _latticeF.lattice with
			| Seqlat(seqlat) -> seqlat.elements
			| _ -> [_latticeF]






