implementation module CodeGeneratorJS

import StdEnv, Maybe, Void, StringAppender, FastString
import SaplTokenizer, SaplParser, BuiltInJS

:: CoderState = { cs_inbody 		:: Bool			     // The body of a function is generated (not signature)
				, cs_intrfunc		:: Maybe SaplTerm    // The name of the currently genrenated function if it is tail recursive
				, cs_inletdef		:: Maybe [SaplTerm]  // used for generating cross referencing (e.g. recursive) lets
				, cs_current_vars 	:: [SaplTerm]
				, cs_constructors	:: Map SaplTerm [SaplTerm]
				, cs_functions		:: Map SaplTerm [SaplTerm]
				, cs_CAFs			:: Map SaplTerm Void				
				, cs_builtins		:: Map String (String, Int)
				, cs_inlinefuncs	:: Map String (InlineCoderFunc, Int)
		      	}

newState :: ParserState -> CoderState
newState p = { cs_inbody 		= False
			 , cs_intrfunc 		= Nothing
			 , cs_inletdef 		= Nothing
			 , cs_current_vars 	= []
			 , cs_constructors 	= p.ps_constructors
			 , cs_functions		= p.ps_functions
			 , cs_CAFs			= p.ps_CAFs
			 , cs_builtins		= builtInFunctions
			 , cs_inlinefuncs	= inlineFunctions
			 }

// Returns True if a term can be inlined, i.e. no separate statement is needed
inline :: SaplTerm -> Bool
inline (SLet _ _) = False
inline (SSelect _) = False
inline (SLambda _ _) = False
inline (SCase _ _ _) = False
inline _ = True

pushArgs :: CoderState [SaplTerm] -> CoderState
pushArgs s [t:ts] = pushArgs {s & cs_current_vars = [t:s.cs_current_vars]} ts
pushArgs s [] = s

prefix = "__"

//escapeTable :: Char -> Maybe String
escapeTable '<' = Just "$3C"
escapeTable '>' = Just "$3E"
escapeTable '{' = Just "$7B"
escapeTable '}' = Just "$7D"
escapeTable '(' = Just "$28"
escapeTable ')' = Just "$29"
escapeTable '*' = Just "$2A"
escapeTable '+' = Just "$2B"
escapeTable '-' = Just "$2D"
escapeTable ',' = Just "$2C"
escapeTable '~' = Just "$7E"
escapeTable '`' = Just "$60"
escapeTable ';' = Just "$3B"
escapeTable '!' = Just "$21"
escapeTable '=' = Just "$3D"
escapeTable '#' = Just "$23"
escapeTable ':' = Just "$3A"
escapeTable '/' = Just "$2F"
escapeTable '|' = Just "$2F"
escapeTable '%' = Just "$7C"
escapeTable '@' = Just "$40"
escapeTable '.' = Just "_"	// this is the module name separator
escapeTable _ = Nothing

// Escape identifier, except the "$eval" part if it ends like that		
escapeName :: String StringAppender -> StringAppender
escapeName name a
	| (endsWith "$eval" name)
		= escapeName_ (a <++ prefix) 0 0 ((size name)- 5) (size name)
		= escapeName_ (a <++ prefix) 0 0 (size name) (size name)
where 
	escapeName_ a start offs size realsize
		| offs > (size - 1)
			| start == 0
				= append a name
			| (start < offs) || (not (size == realsize))
				= append a (name % (start, (realsize-1)))
				= a					
		= case escapeTable name.[offs] of
			Just r # a = append a (name % (start, (offs-1)))
				   # a = append a r
				   = escapeName_ a (offs + 1) (offs + 1) size realsize
				   = escapeName_ a start (offs + 1) size realsize

callWrapper :: SaplTerm CoderState StringAppender -> StringAppender
callWrapper t s a
	| not (inline t)
		= termCoder t s a		
	| (isJust s.cs_intrfunc) && (isTailRecursive (fromJust s.cs_intrfunc) t)
		= forceTermCoder t s a
//		= a <++ "return " <++ termCoder t s <++ ";" // Optimize for stack use. BUGGY
		= a <++ "return " <++ forceTermCoder t s <++ ";" // Optimize for speed

unpackName (SStrictName name) = name
unpackName (SName name _) = name

isStrictName (SStrictName _) = True
isStrictName _ = False

isTailRecursive :: SaplTerm SaplTerm -> Bool
isTailRecursive name (SSelect args) = any (isTailRecursive name) args
isTailRecursive name (SCase pred lhs rhs) = isTailRecursive name lhs || isTailRecursive name rhs
isTailRecursive name (SApplication aname _) = (unpackName name) == (unpackName aname)
isTailRecursive name (SLambda body _) = isTailRecursive name body
isTailRecursive _ _ = False

funcCoder :: FuncType CoderState StringAppender -> StringAppender
funcCoder (FTFunc name body args) s a = normalFunc name body args s a
funcCoder (FTMacro name body args) s a = normalFunc name body args s a
funcCoder (FTCAF name body) s a = normalFunc name body [] s a
funcCoder (FTADT name args) s a = foldl (\a t = termCoder t s a) a args
funcCoder (FTRecord name args) s a 
	= a <++ constructorCoder name 0 args s <++ termCoder name s <++ ".fields=[" <++ recordFieldCoder args <++ "];";

normalFunc :: SaplTerm SaplTerm [SaplTerm] CoderState StringAppender -> StringAppender
normalFunc name body args s a
	// Generate $eval function if any of its arguments is annotated as strict	
	# a = if (any isStrictName args) 
				(makeStrictClosure a (unpackName name) args) a
				
	// Generate function signature			
	# a = a <++ "function " <++ termCoder name s
			<++ "(" <++ termArrayCoder args "," s <++ "){"

	// Update coder state with the new local arguments, ...
	# s = {s & cs_inbody = True
			 , cs_current_vars = args
			 , cs_intrfunc = if (isTailRecursive name body) (Just name) Nothing}

	// Generate body (in a while(1) if the function is tail recursive)				
	# a = if (isJust s.cs_intrfunc) (a <++ "while(1){") a
	# a = callWrapper body s a
	# a = if (isJust s.cs_intrfunc) (a <++ "}") a
	= a <++ "};"  

where
	// The (i-1) is to be compatible with the original compiler written in JavaScript
	makeStrictClosure a name args
		= a <++ "function " 
			<++ escapeName name <++ "$eval("
			<++ joinList "," ["a"+++toString (i-1) \\ i <- [1..length args]]
			<++ "){return " <++ escapeName name <++ "("
			<++ (\a = fst (foldl strictsep (a,1) args))
			<++ ");};"
	where
		strictsep (a,i) arg
			# a = case isStrictName arg of
					True = a <++ "Sapl.feval(a" <++ (i-1) <++ ")"
						 = a <++ "a" <++ (i-1)
			| i < (length args)
				= (a <++ ",", i+1)
				= (a, i)

make_app_args :: SaplTerm [SaplTerm] CoderState StringAppender -> StringAppender
make_app_args func args s a 
	= case get func s.cs_functions of
		Just func_args = a <++ maa_ func_args args 0 s
					   = a <++ maa_ [] args 0 s // this is the case of built-in functions
where
	// fargs: formal, aargs: actual	
	maa_ [(SStrictName _):fargs] [aa:aargs] i s a 
		# a = if (i>0) (a <++ ",") a
		= a <++ forceTermCoder aa s <++ maa_ fargs aargs (i+1) s 
	maa_ [_:fargs] [aa:aargs] i s a 
		# a = if (i>0) (a <++ ",") a		
		= a <++ termCoder aa s <++ maa_ fargs aargs (i+1) s 
	maa_ [] [aa:aargs] i s a 
		# a = if (i>0) (a <++ ",") a		
		= a <++ termCoder aa s <++ maa_ [] aargs (i+1) s 
	maa_ _ [] _ _ a = a

constructorCoder :: SaplTerm Int [SaplTerm] CoderState StringAppender -> StringAppender
constructorCoder name id args s a
	// Original field names are not necessary, they can be shorten
	# newargs = [SName ("a"+++toString i) 0 \\ i <- [1..length args]]
	
	# a = a <++ "function " <++ termCoder name s <++ "(" <++ termArrayCoder newargs "," s
			<++ "){return [" <++ id <++ ",'" <++ unpackName name <++ "'" 
	# a = case length args of
		0 = a
		  = a <++ "," <++ termArrayCoder newargs "," s 
	= a	<++ "];};"

recordFieldCoder :: [SaplTerm] StringAppender -> StringAppender
recordFieldCoder [t] a = a <++ "\"" <++ unpackName t <++ "\""
recordFieldCoder [t:ts] a
	= a <++ "\"" <++ unpackName t <++ "\"," <++ recordFieldCoder ts
recordFieldCoder [] a = a

termArrayCoder :: [SaplTerm] String CoderState StringAppender -> StringAppender
termArrayCoder [t] sep s a = termCoder t s a
termArrayCoder [t:ts] sep s a
	= a <++ termCoder t s <++ sep <++ termArrayCoder ts sep s
termArrayCoder [] _ s a = a

letDefCoder :: [SaplTerm] CoderState StringAppender -> StringAppender
letDefCoder [t] s a = termCoder t s a
letDefCoder [t:ts] s a
	= a <++ termCoder t s <++ "," <++ letDefCoder ts {s & cs_inletdef = Just (tl (fromJust s.cs_inletdef))}
letDefCoder [] _ a = a

// Generate code that forces the evaluation of the given term
forceTermCoder :: SaplTerm CoderState StringAppender -> StringAppender
forceTermCoder t=:(SApplication name args) s a
	| isdynamic name
		= a <++ "[__dynamic_handler]"
	// local variable
	| isMember name s.cs_current_vars
		= a <++ "Sapl.feval(" <++ termCoder t s <++ ")" 

	// global function or constructor (not curried)
	| (isJust constructor_args && (length (fromJust constructor_args) == length args)) || 
	  (isJust function_args && (length (fromJust function_args) == length args))

		= case (isJust s.cs_intrfunc) && 
			   (isTailRecursive (fromJust s.cs_intrfunc) t) of
			
			// It is posible that a tail recursive call has the same function as its
			// argument. In this case, the deeper call can't be handled as tail recursive!
			True = a <++ make_tr_app args {s & cs_intrfunc = Nothing}
				 = a <++ func_name <++ "(" <++ make_app_args name args s <++ ")"

	// more arguments than needed
	| (isJust function_args && (length (fromJust function_args) < length args))
		= a <++ "Sapl.feval(" <++ termCoder t s <++ ")"  
	
	// TODO: inline (...) doc
	| (isJust inlinefunc && (snd (fromJust inlinefunc)) == length args)
		= a <++ "(" <++ (fst (fromJust inlinefunc)) (\t a = forceTermCoder t s a) args <++ ")"

	| (isJust builtin && (snd (fromJust builtin)) == length args)
		= a <++ func_name <++ "(" <++ make_app_args name args s <++ ")"
	
	| (isNothing function_args) && (isNothing builtin)
		= a <++ "Sapl.feval(" <++ termCoder t s <++ ")"

	// Otherwise
		= a <++ termCoder t s
where
	func_name a = a <++ escapeName (unpackName name) // skip level information

	//is_constructor = isJust (get name s.cs_constructors)
	constructor_args = get name s.cs_constructors
	function_args = get name s.cs_functions
	tr_function_args = fromJust (get (fromJust s.cs_intrfunc) s.cs_functions)
	builtin = get (unpackName name) s.cs_builtins
	inlinefunc = get (unpackName name) s.cs_inlinefuncs	

	make_tr_app args s a 
		= a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";" 
			<++ mta_2 tr_function_args 0 s <++ "continue;"
	where
		mta_1 [(SStrictName _):fargs] [aa:aargs] i s a 
			# a = if (i>0) (a <++ ",") a
			= a <++ "t" <++ i <++ "=" <++ forceTermCoder aa s <++ mta_1 fargs aargs (i+1) s 
		mta_1 [_:fargs] [aa:aargs] i s a 
			# a = if (i>0) (a <++ ",") a		
			= a <++ "t" <++ i <++ "=" <++ termCoder aa s <++ mta_1 fargs aargs (i+1) s 
		mta_1 [] _ i s a = a

		mta_2 [fa:fargs] i s a 
			= a <++ escapeName (unpackName fa) <++ "=t" <++ i <++ ";" <++ mta_2 fargs (i+1) s // skip level information for TR!
		mta_2 [] i s a = a

forceTermCoder t=:(SName name _) s a
	| any isStrictEq s.cs_current_vars
		= termCoder t s a
	| isMember t s.cs_current_vars
		= a <++ "Sapl.feval(" <++ termCoder t s <++ ")" 
	| (isJust constructor_args) && (length (fromJust constructor_args) == 0)
		= a <++ escapeName name <++ "()"	
	| isCAF
		= a <++ escapeName name <++ "()"	
	| (isJust function_args && (length (fromJust function_args) == 0))
		= a <++ escapeName name <++ "()"	
		= a <++ "Sapl.feval(" <++ termCoder t s <++ ")"
where
	isStrictEq (SStrictName aname) = aname == name
	isStrictEq _ = False	
	constructor_args = get t s.cs_constructors
	function_args = get t s.cs_functions	
	isCAF = isJust (get t s.cs_CAFs)

forceTermCoder t s a = termCoder t s a
		
termCoder :: SaplTerm CoderState StringAppender -> StringAppender
termCoder t=:(SName name level) s a
	| (s.cs_inbody) && (not isLocalVar) && (isJust constructor_args) && (length (fromJust constructor_args) == 0)
		= a <++ escapeName name <++ "()"	
	| (s.cs_inbody) && (not isLocalVar) && isCAF
		= a <++ escapeName name <++ "()"	
	| (s.cs_inbody) && (not isLocalVar) && isStrictFunction
		= a <++ escapeName name <++ "$eval"	

		// else
		| (isJust s.cs_inletdef) && (isMember t (fromJust s.cs_inletdef))
			= a <++ "[function(){return Sapl.feval(" <++ var_name <++ ");},[]]"

			// else
			= a <++ var_name
			  
where 
	// TODO: doc
	findLocalVar [(SName cn level):cs] = if (cn == name) level (findLocalVar cs)
	findLocalVar [(SStrictName cn):cs] = if (cn == name) 0 (findLocalVar cs)
	findLocalVar [] = 0
	isLocalVar = isMember t s.cs_current_vars
	
	constructor_args = get t s.cs_constructors
	isBuiltIn = isJust (get name s.cs_builtins)
	isFunction = isJust (get t s.cs_functions)		
	isConstructor = isJust (constructor_args)	
	isCAF = isJust (get t s.cs_CAFs)
	isStrictFunction = case get t s.cs_functions of
							Just args = any isStrictName args
									  = False

	var_name a # decl_level = findLocalVar s.cs_current_vars
			   = case decl_level of
					0 = a <++ escapeName name
			  		  = a <++ escapeName name <++ "_" <++ decl_level

termCoder (SStrictName name) s a = a <++ escapeName name
termCoder (SSelect args) s a 
	# a = a <++ "var ys=" <++ forceTermCoder (hd args) {s & cs_intrfunc = Nothing} <++  ";"
	= case length args > 2 of
		True = a <++ "switch(ys[0]){" <++ selectArgs (tl args) s 0 <++ "}"
			 = callWrapper (hd (tl (args))) s a
where
	selectArgs [] s i a = a
	selectArgs [t:ts] s i a 
		= a <++ "case " <++ toString i <++ ":" <++ callWrapper t s <++ selectArgs ts s (i+1)

termCoder (SLambda body args) s a 
	# s = pushArgs s args
	= a <++ "var " <++ lambdaArgs args 0 s <++ callWrapper body s 
where 
	lambdaArgs [t] i s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "];"
	lambdaArgs [t:ts] i s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "]," <++ lambdaArgs ts (i+1) s
	lambdaArgs [] i s a = a

termCoder (SCase pred lhs rhs) s a 
	// in the predicate of an 'if' there can't be tail recursive call
	= a <++ "if(" <++ forceTermCoder pred {s & cs_intrfunc = Nothing} <++ "){"
		<++ callWrapper lhs s 
		<++ "}else{"
		<++ callWrapper rhs s
		<++ "}"

termCoder (SApplication name args) s a
	| isdynamic name
		= a <++ "[__dynamic_handler]"
	| (isJust constructor_args && (length (fromJust constructor_args) == length args))
		= a <++ func_name name <++ "(" <++ make_app_args name args s <++ ")"
		= a <++ "[" <++ termCoder name s <++ ",[" 
			<++ termArrayCoder args "," s
			<++ "]]"
where
	constructor_args = get name s.cs_constructors
	func_name name a = a <++ escapeName (unpackName name) // skip level information


termCoder (SConst (CString str)) s a = a <++ "\"" <++ str <++ "\""
termCoder (SConst (CChar chr)) s a = a <++ "'" <++ chr <++ "'"
termCoder (SConst (CInt int)) s a = a <++ int
termCoder (SConst (CReal real)) s a = a <++ real
termCoder (SConst (CBool True)) s a = a <++ "true"
termCoder (SConst (CBool False)) s a = a <++ "false"

termCoder (SConstructor name id args) s a
	= constructorCoder name id args s a

/* Let definitions can be cross references to each other.
 * If a let definition has reference to an other which is not yet declared
 * (or recursive) the referenced variable must be wrap into a closure.
 * cs_inletdef contains all the remaining let definitions (letDefCoder 
 * removes the elements step by step)
 */
termCoder (SLet body defs) s a
	# defnames = map (\(SLetDefinition name _) = name) defs
	# s = pushArgs s defnames
	= a <++ "var " <++ letDefCoder defs {s & cs_inletdef = Just defnames} <++ ";\n " 
		<++ callWrapper body s <++ ";"

termCoder (SLetDefinition name body) s a
	= a <++ termCoder name {s & cs_inletdef = Nothing} <++ "=" <++ termCoder body s

termCoder _ s a = abort "???"

isdynamic (SName name _) | startsWith "_SystemDynamic." name
	= True
	= False

isdynamic (SStrictName name) | startsWith "_SystemDynamic." name
	= True
	= False

isdynamic _ = False

generateJS :: String -> (MaybeErrorString (StringAppender, ParserState))
generateJS saplsrc
	# pts = tokensWithPositions saplsrc
	= case parse pts of
		Ok (funcs, s) # state = newState s 
					  # a = foldl (\a curr = funcCoder curr state a) newAppender funcs
					  = Ok (a, s)
		Error msg = Error msg

exprGenerateJS :: String (Maybe ParserState) -> (MaybeErrorString StringAppender)
exprGenerateJS saplsrc mbPst
	# pts = tokensWithPositions saplsrc
	= case parseExpr pts of
		Ok (body, s) # state = newState (mergeParserStates s mbPst)
					 # a = termCoder body {state & cs_inbody=True} newAppender
					 = Ok a
		Error msg = Error msg