(**
** Lattakia Compiler
** Columbia University COMS-4115
** Programming Languages and Translators
** Authors:
** Wael Salloum
** Heba ElFardy
** Katherine Scott
**)
open Ast
open LatticeCreation
(********************************************************************)
(********************************************************************)
(********************************************************************)

type printOptionsType = {
	mutable doAnnotateTypes: bool;
	mutable doProcessSymbolTable: bool;
	mutable processCode: bool;
}
type printEnvType = {
	mutable options: printOptionsType;
}
let printEnv = {
 	options = {
		doAnnotateTypes = true;
		doProcessSymbolTable = false;
		processCode = true;
	}
}

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)) ^ ")" 

(*------------------------------------------------------------------------------------------------*)	  
let predefinedLabelType = function LENGTH -> "length" | COUNT -> "count" | LABELS -> "labels" | CLONE -> "clone" | REVERSE -> "reverse" | RETURN -> "return" | LOOP -> "loop" | GET_LOST -> "getlost" | INDEX -> "_index" | SUBJECT -> "_subject"

(*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=*)	  
let rec toString _lattice _options =
	printEnv.options <- _options;  
	processLattice _lattice 
	 
and processLattice lattice = (*input a latticeFields, which is our AST*)
		(if printEnv.options.doAnnotateTypes then ".. lat-type: " ^ (dataStructTypeToString lattice.latDataStructType) ^ "\n" else "") ^
		(if printEnv.options.doAnnotateTypes then (match lattice.paramNameList with None -> ".. No Params, " | Some(pl) -> List.fold_left (^) "" pl) else "") ^
		(processLatticeType lattice.lattice)
	
and processLatticeType latType = 
    match latType with 
    | Seqlat(seqlat) -> (if printEnv.options.doAnnotateTypes then ".. Seqlat:\n" else "") ^ (processSeqlat seqlat)
    | Altlat(altlat) -> (if printEnv.options.doAnnotateTypes then ".. Altlat:\n" else "") ^ (processAltlat altlat)
    | Predicate(pred) -> (if printEnv.options.doAnnotateTypes then ".. Predicate:\n" else "") ^ (processPredicate pred)
    | Expr(expr) -> (if printEnv.options.doAnnotateTypes then ".. Expr:\n" else "") ^ (processExpr expr)
(*------------------------------------------------------------------------------------------------*)	  
and processSeqlat _seqlat = (*do the seq lat *)
		let symbolTableString = if printEnv.options.doProcessSymbolTable then ("  **\n"^ (processSymbolTable _seqlat.symbols) ^ "  **\n") else "" in 
		let listOfElements = List.map (fun x -> processLattice x) _seqlat.elements in
		let rec buildListOfLabels (_listOfLables, _i, _lastI) = 
			if (_i = _lastI) then _listOfLables 
			else (buildListOfLabels (_listOfLables, _i + 1, _lastI) @ [""])
		in 
		let listOfLabels = getListOfLabels _seqlat.symbols.hash in
		let listOfLabels = buildListOfLabels(listOfLabels, List.length listOfLabels, List.length listOfElements) in
		let labElmTupList = (List.combine listOfLabels listOfElements) in
		let tupleList = List.map (fun (x, y) -> x ^ y ^ ";\n") labElmTupList in
		symbolTableString ^ (List.fold_left (^) "" tupleList)
    
(*.................................................................................................*)	  
	and processSymbolTable _symbolTable =
		let hash = _symbolTable.hash in let parent = _symbolTable.parent in
		let processSymbol _symbol = 
			(match _symbol.symbolScope with Label -> "label" | Local -> "local" | UnresolvedSymbol -> "unresolved") ^ ", " ^
			(match _symbol.symValue with LabelIndex(ind) -> "index="^(string_of_int ind)  | LocalValueLattice(latRef) -> "("^(processLattice(!latRef))^")") ^ ", " ^
			(dataStructTypeToString _symbol.symDataStructType)^ ", " ^
			(match _symbol.parameterNameList with None -> "" | Some(nameList) -> "("^(List.fold_left (^) "" nameList)^ ") of ") ^
			(match _symbol.parameterTypeList with None -> "" | Some(typeList) -> "("^(List.fold_left (^) "" (List.map (dataStructTypeToString) typeList))^")") ^ ".\n" 
		in
		let currentSTString = StringMap.fold (fun name symbol rest -> 
				"\t" ^ name ^ " -> " ^ (processSymbol symbol) ^ "\n" ^ rest
			) hash "" in 
		let parentSTString = (match parent with None -> "" | Some(p) -> "\nParent ST has: "^(processSymbolTableKeys p)) in
		currentSTString ^ parentSTString

and processSymbolTableKeys _symbolTable = 
		let keyList = StringMap.fold(fun x y z -> x ^", " ^ z) _symbolTable.hash "" in
		keyList
(*.................................................................................................*)	  
	and getListOfLabels _symoblTableHash = 
			let dirtyTupleList = StringMap.fold (fun name symbol rest -> (match symbol.symValue with
				| LabelIndex(ind) -> (symbol.symName ^ ":", ind) 
				| _ -> ("", -1) ) :: rest
				) _symoblTableHash [] in 
			let rec cleanTupleList = function
				| [] -> []
				| hd::tl -> (let (name, ind) = hd in 
					(if (ind = -1) then [] else [hd]) @ (cleanTupleList tl))
			in 
			let cleanedList = cleanTupleList dirtyTupleList in
			let sortedList = List.sort (fun (_,c1)(_,c2) -> - Pervasives.compare c2 c1) cleanedList in
			let rec fillEmptyPlaces(compactList, prevInd) = match compactList with
				| [] -> []
				| hd::tl -> (let (label, currInd) = hd in 
				if currInd <= prevInd then rf("BUG: fillEmptyPlaces()!") else
				let expectedIndex = prevInd + 1 in
					(if currInd = expectedIndex then 
						hd :: fillEmptyPlaces(tl, currInd)
					else 
						("", expectedIndex) :: (fillEmptyPlaces(compactList, expectedIndex))
					)) in
			fst (List.split (fillEmptyPlaces(sortedList, -1)))
			  
(*------------------------------------------------------------------------------------------------*)	  
and processAltlat _altlat = (*do the alt lat *)
    processListOfLattices _altlat.alternatives "|"
      
and processListOfLattices latticeList separator =
    match latticeList with
    | [hd] -> processLattice hd
    | hd::tl -> (processLattice hd) ^ " " ^ separator ^ " " ^ (processListOfLattices tl separator)
		| [] -> ""
					
(*------------------------------------------------------------------------------------------------*)	  
and processPredicate _pred =
    "[" ^  (processExpr _pred.condition) ^ "] " ^ processExpr _pred.expr
	  
(*------------------------------------------------------------------------------------------------*)	  
and processExpr _expr = 
		(if printEnv.options.doAnnotateTypes then " " ^ (dataStructTypeToString _expr.exprDataStructType) ^ ": " else "") ^ 
		if printEnv.options.processCode then processExprCode _expr.exprCode else 
		let valueStringOpt = processExprValue _expr.exprEval in match valueStringOpt with
			| None -> processExprCode _expr.exprCode
			| Some(valueString) -> valueString
	
	and processExprValue = function
		| ConstValue(const) -> Some(processConst const)
		| LatticeValue(lattice) -> Some("(" ^ processLattice lattice ^ ")")
		| NotEvaluated -> None

	and processExprCode = function
  | ConstExpr(const) -> processConst const
  | OpExpr(op) -> processOperation op
  | NameListExpr(nameList) -> processNameList env.namesOfCurrLat nameList.nameList 
  | LatticeExpr(lattice) -> "**LatticeExpr**(" ^ processLattice lattice ^ ")"
	  
(*.................................................................................................*)	  
and processConst  = function
    | StringLiteral(stringLit) -> "\"" ^ stringLit ^ "\"" 
    | IntLiteral(intLit) -> string_of_int intLit
    | FloatLiteral(floatLit) -> string_of_float floatLit
    | Epsilon -> "epislon"
    | Nil -> "nil"
    | True -> "true"
    | False -> "false"
      
(*.................................................................................................*)	  
and processOperation op =
    let op1Val = processExpr op.operand1 in

    let op2Val = 
      (match op.operand2 with 
      |	None -> ""
      |	Some(opr) -> processExpr opr) in
    (match op.operator with
    | Plus -> op1Val ^ "+" ^ op2Val 
    | Minus -> op1Val ^ "-" ^ op2Val 
    | Times -> op1Val ^ "*" ^ op2Val 
    | Divide  -> op1Val ^ "/" ^ op2Val 
    | Percent  -> op1Val ^ "%" ^ op2Val 
    | Or  -> op1Val ^ "||" ^ op2Val 
    | And  -> op1Val ^ "&&" ^ op2Val 
    | Equal  -> op1Val ^ "==" ^ op2Val 
    | NotEqual  -> op1Val ^ "!=" ^ op2Val 
    | Less  -> op1Val ^ "<" ^ op2Val 
    | LessOrEqual  -> op1Val ^ "<=" ^ op2Val 
    | Greater  -> op1Val ^ ">" ^ op2Val 
    | GreaterOrEqual  -> op1Val ^ ">=" ^ op2Val 
    | Tilde -> op1Val ^ "~" ^ op2Val 
    | UniMinus  -> "-" ^ op1Val
    | Eval  -> "?" ^ op1Val 
    | DontOpt  -> "^" ^ op1Val 
    | Let -> "let " ^ op1Val
		| Not -> "!"  ^ op1Val
		| Assign -> op1Val ^ "=" ^ op2Val
		| DirectAccess -> "("^ op1Val ^ ")." ^ op2Val
		| FuncCall -> op1Val ^ "("^ op2Val ^ ")"
		| Define ->	(*".. " ^ (dataStructTypeToString lattice.latDataStructType) ^*)
			"def " ^ op1Val ^ "=" ^ op2Val   
		)
		
(*.................................................................................................*)	  
and processNameList _symbolTable _nameList =
    match _nameList with 
    | [] -> ""
    | hd::tl -> (match hd with 
        |   Id(id) -> id
        |   IndexingOp(structType, lattice) ->
                            let latString = processLatticeType lattice in 
				(match structType with
					| Seq -> "[" ^ latString ^ "]"
					| Alt -> "{" ^ latString ^ "}"
					| UndeterminedStruct -> "<" ^ latString ^ ">"
					| Wrd -> rf("BUG: PrintLattice.processNameList(): Wrd was found in IndexingOp!")
				)
			| PredefinedLabel(label) -> predefinedLabelType label
			| Each(latticeT) -> "{"^ (processLatticeType latticeT) ^"}"
      |	_ -> "<not handled>"
	    ) ^ (if List.length tl = 0 then "" else
	    "."^ processNameList _symbolTable tl)
		  
(*------------------------------------------------------------------------------------------------*)	  
	    

let stringOfErrorMessage = function 
		  SemParamListTypeSignMismatch -> "Parameter list type signature mismatch"
		| SemUndefinedIdentifier(id) -> "Undefined identifier '"^id^"'"
		| SemIdentifierMultipleDefinition -> "Multiple definition of identifier"
		| SemTypeMismatch -> "Type mismatch"
		| LexUndefinedSymbol(symbol) -> "Undefined symbol '"^symbol^"'"
		| SynParseError -> "Parse Error"
		| SemPredicateTypeNotBoolean -> "Predicate type must be boolean"

let stringOfError _error= 
	(stringOfErrorMessage _error.errMessage) ^ 
	(match _error.errPlace with None -> "" | Some(exprCode) -> " in\n\t"^(processExprCode exprCode)) ^
	"!"

let rec stringOfErrorTable (_errorTable: errorType list) = 
	match _errorTable with
		| [] -> ""
		| hd::tl -> (stringOfError hd) ^ "\n" ^ (stringOfErrorTable tl) 




