implementation module CodeGeneratorJS

/* TODO:
 *
 * - Cyclical let definitions are not handled correctly:
 *		1. strictness should be removed from the definition which references the later one
 *		2. tail recursion optimization shouldn't be used in the function which has cyclical let definitions (scoping problem)
 *
 */

import StdEnv, Maybe, Void, StringAppender, FastString
import SaplTokenizer, SaplParser, Flavour, JS, StrictnessPropagation
import Let

from List import elem_by, partition
from Map import get

:: CoderState = { cs_inbody 		:: !Maybe SaplVar     // The body of the function which is being generated (not signature)
				, cs_intrfunc		:: !Maybe SaplVar     // The name of the currently generated function if it is tail recursive
				, cs_futuredefs		:: ![SaplVar]     	  // for finding out about let-rec and let bindings defined later 
				, cs_incaseexpr		:: !Bool
				, cs_current_vars 	:: ![SaplVar]		 // Strict, Normal
				, cs_constructors	:: !Map String ConstructorDef
				, cs_functions		:: !Map String [SaplVar]
				, cs_CAFs			:: !Map String Void				
				, cs_builtins		:: !Map String (String, Int)
				, cs_inlinefuncs	:: !Map String InlineFunDef
				, cs_trampoline     :: !Bool
				, cs_prefix         :: !String
		      	}

newState :: !Flavour !Bool !ParserState -> CoderState
newState f tramp p =
			 { cs_inbody 		= Nothing
			 , cs_intrfunc 		= Nothing
			 , cs_futuredefs	= []
			 , cs_incaseexpr 	= False
			 , cs_current_vars 	= []
			 , cs_constructors 	= p.ps_constructors
			 , cs_functions		= p.ps_functions
			 , cs_CAFs			= p.ps_CAFs
			 , cs_builtins		= f.builtInFunctions
			 , cs_inlinefuncs	= f.inlineFunctions
			 , cs_trampoline    = tramp
			 , cs_prefix        = f.fun_prefix
			 }

// 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 (SIf _ _ _) = False
inline _ = True

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

condForce :: !Bool !a !StringAppender -> StringAppender | Appendable a
condForce True e a = a <++ "Sapl.feval(" <++ e <++ ")"
condForce False e a = a <++ e

force e a = condForce True e a
forceApp e a = a <++ "Sapl.fapp(" <++ e <++ ")"

// Escape identifier, except the "$eval" part if it ends like that		
escapeName :: !String !String !StringAppender -> StringAppender
escapeName prefix name a = a <++ prefix <++ toString (urlEncode` (fromString name))
where 
	// A slightly modified URL encoding scheme
	urlEncode` :: ![Char] -> [Char]
	urlEncode` []						= []
	urlEncode` e=:['$eval']				= e		
	urlEncode` [x:xs] 
	| isAlphanum x						= [x  : urlEncode` xs]
	| otherwise							= urlEncodeChar x ++ urlEncode` xs
	where
		urlEncodeChar '_'				= ['_']
		urlEncodeChar '.'				= ['_']		
		urlEncodeChar ' '				= ['+']
		urlEncodeChar '$'				= ['$']		
		urlEncodeChar x					= ['$', c1 ,c2]
		
		(c1,c2)							= charToHex x

		charToHex :: !Char -> (!Char, !Char)
		charToHex c						= (toChar (digitToHex (i >> 4)), toChar (digitToHex (i bitand 15)))
		where
		        i						= toInt c
		        digitToHex :: !Int -> Int
		        digitToHex d
		                | d <= 9		= d + toInt '0'
		                | otherwise		= d + toInt 'A' - 10
				   
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
	| s.cs_trampoline
		= a <++ "return " <++ trampolineCoder t s <++ ";" 	
		= a <++ "return " <++ forceTermCoder t s <++ ";" 

isTailRecursive :: !SaplVar !SaplTerm -> Bool
isTailRecursive var (SSelect _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SIf pred lhs rhs) = isTailRecursive var lhs || isTailRecursive var rhs
isTailRecursive var (SApplication avar _) = unpackVar var == unpackVar avar
isTailRecursive var (SLet body _) = isTailRecursive var 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 = encodeCAF 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 = a <++ constructorCoder name 0 args s
	= a <++ termCoder name s <++ ".$f=[" <++ recordFieldCoder args <++ "];"

// Only real constants can be safely encoded as a simple variable...
encodeCAF :: !SaplVar !SaplTerm !CoderState !StringAppender -> StringAppender
encodeCAF name body=:(SLit _) s a
	# a = a <++ "var " <++ termCoder name s <++ " = "

	# s = {s & cs_inbody = Just name
			 , cs_current_vars = []
			 , cs_intrfunc = Nothing
			 }

	# a = termCoder body s a
	= a <++ ";"  

// ... everything else must be wrapped into an anonymous function to avoid 
// undefined references (because of variables and functions declared later)
encodeCAF name body s a
	# a = a <++ "var " <++ termCoder name s <++ " = [function (){"

	# s = {s & cs_inbody = Just name
			 , cs_current_vars = []
			 , cs_intrfunc = Nothing
			 }

	# a = a <++ callWrapper body s 

	= a <++ "},[]];";

normalFunc :: !SaplVar !SaplTerm ![SaplVar] !CoderState !StringAppender -> StringAppender
normalFunc name body args s a
	// Generate $eval function if any of its arguments is annotated as strict	
	# a = if (any isStrictVar args) 
				(makeStrictClosure (unpackVar name) args s a) 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 = Just name
			 , 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 <++ "};"  

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

make_app_args :: !SaplVar ![SaplTerm] !CoderState !StringAppender -> StringAppender
make_app_args func args s a 
	= case get (unpackVar func) s.cs_functions of
		Just func_args = a <++ maa_ func_args args 0 s
					   = a <++ maa_ [] args 0 s 
where
	// fargs: formal, aargs: actual	
	maa_ [(StrictVar _ _):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

recordFieldCoder :: ![SaplVar] !StringAppender -> StringAppender
recordFieldCoder [t] a = a <++ "\"" <++ unpackVar t <++ "\""
recordFieldCoder [t:ts] a
	= a <++ "\"" <++ unpackVar t <++ "\"," <++ recordFieldCoder ts
recordFieldCoder [] a = a

termArrayCoder :: ![a] !String !CoderState !StringAppender -> StringAppender | TermCoder a
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

//----------------------------------------------------------------------------------------
// Term coder instances

class TermCoder a 
where
	termCoder 		:: !a !CoderState !StringAppender -> StringAppender
	forceTermCoder 	:: !a !CoderState !StringAppender -> StringAppender
	trampolineCoder	:: !a !CoderState !StringAppender -> StringAppender

//----------------------------------------------------------------------------------------
// Data constructor...

constructorCoder :: !SaplVar !Int ![SaplVar] CoderState !StringAppender -> StringAppender

// A zero argument data constructor is a CAF
constructorCoder name id [] s a
	= a <++ "var " <++ escapeName s.cs_prefix (unpackVar name) <++ " = [" <++ id <++ ",\"" <++ unpackVar name <++ "\"];"

constructorCoder name id args s a
	// Generate $eval function if any of its arguments is annotated as strict	
	# a = if (any isStrictVar args) 
				(makeStrictClosure (unpackVar name) args s a) a

	// Original field names are not necessary, they can be shorten
	# newargs = [NormalVar ("_"+++toString i) 0 \\ i <- [1..length args]]
		
	# a = a <++ "function " <++ termCoder name s <++ "(" <++ termArrayCoder newargs "," s
			<++ "){return [" <++ id <++ "," <++ termCoder name s <++ "$n"
	# a = case length args of
		0 = a
		  = a <++ "," <++ termArrayCoder newargs "," s 
	# a = a	<++ "];};"

	= a <++ "var " <++ termCoder name s <++ "$n = \"" <++ unpackVar name <++ "\";" 

constructorInliner :: !SaplVar !ConstructorDef ![SaplTerm] !CoderState !StringAppender -> StringAppender
constructorInliner name def [] s a
	= escapeName s.cs_prefix (unpackVar name) a

constructorInliner name def args s a
	# a = a <++ "[" <++ def.index <++ "," <++ escapeName s.cs_prefix (unpackVar name) <++ "$n"
	# a = case def.nr_args of
		0 = a
		  = a <++ "," <++ argsCoder def.args args ","  {s & cs_intrfunc = Nothing}  
	= a	<++ "]"
where
	// Formal arguments, actual arguments
	argsCoder [NormalVar _ _] [t] sep s a = termCoder t s a
	argsCoder [StrictVar _ _] [t] sep s a = forceTermCoder t s a	
	argsCoder [NormalVar _ _:fs] [t:ts] sep s a 
			= a <++ termCoder t s <++ sep <++ argsCoder fs ts sep s
	argsCoder [StrictVar _ _:fs] [t:ts] sep s a 
			= a <++ forceTermCoder t s <++ sep <++ argsCoder fs ts sep s	
	argsCoder [] [] _ s a = a

instance TermCoder SaplConstructor
where
	termCoder (SaplConstructor name id args) s a = constructorCoder name id args s a
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Literals...

instance TermCoder Literal
where
	termCoder (LString ustr) s a = a <++ "\"" <++ toJSLiteral ustr <++ "\""
	termCoder (LChar uchr) s a = a <++ "'" <++ toJSLiteral uchr <++ "'"
	termCoder (LInt int) s a = a <++ int
	termCoder (LReal real) s a = a <++ real
	termCoder (LBool True) s a = a <++ "true"
	termCoder (LBool False) s a = a <++ "false"
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Select patterns...

get_cons_or_die s cons = maybe (abort ("Data constructor "+++cons+++" cannot be found!")) 
			  		   id
			   	       (get cons s.cs_constructors)

splitDefaultPattern :: ![(SaplPattern, SaplTerm)] -> (![(SaplPattern, SaplTerm)], !Maybe SaplTerm)
splitDefaultPattern patterns 
	= case partition (isDefaultPattern o fst) patterns of
			([],ps) 		= (ps, Nothing)
			([(_,d)],ps) 	= (ps, Just d)
							= abort "Error: more than one default branches in a select expression"

containsUnsafeSelect :: !CoderState !SaplTerm -> Bool
containsUnsafeSelect s (SApplication _ ts) = any (containsUnsafeSelect s) ts
containsUnsafeSelect s (SIf _ tb fb) = containsUnsafeSelect s tb || containsUnsafeSelect s fb
containsUnsafeSelect s (SSelect _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
containsUnsafeSelect s (SLet b _) = containsUnsafeSelect s b
containsUnsafeSelect s _ = False

isUnsafeSelect :: !CoderState ![(SaplPattern, SaplTerm)] -> Bool
isUnsafeSelect s patterns
	= case ps of
		[(PCons name _, _):_] = isNothing d && (get_cons_or_die s name).nr_cons <> length ps
		[(PLit (LBool True), _),(PLit (LBool False), _):_] = False
		[(PLit (LBool False), _),(PLit (LBool True), _):_] = False		
		_ = isNothing d
where
	(ps, d) = splitDefaultPattern patterns

instance TermCoder (SaplPattern, SaplTerm, Bool)
where
	termCoder (PDefault, body, _) s a 
		= callWrapper body s a

	termCoder (PLit lit, body, _) s a 
		= a <++ "case " <++ termCoder lit s <++ ": " <++ callWrapper body s

	termCoder (PCons cons [], body, True) s a 
		= callWrapper body s a

	termCoder (PCons cons [], body, False) s a 
		= a <++ "case " <++ toString cons_idx <++ ": " <++ callWrapper body s
	where
		cons_idx  = (get_cons_or_die s cons).index
		
	termCoder (PCons cons args, body, singleton) s a 
		# s = pushArgs s (map annotate (zip2 get_cons.args args))	

		// In the case of singleton data constructor we omit "switch/case"
		# a = case singleton of
				True = a
				_ 	 = a <++ "case " <++ toString get_cons.index <++ ": "

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

		get_cons   = get_cons_or_die s cons

		annotate (StrictVar _ _, arg) = toStrictVar arg
		annotate (_, arg) = arg

	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Variables...

instance TermCoder SaplVar
where
	forceTermCoder t=:(NormalVar name level) s a
		// Strict let definitions, strict arguments ...
		| any (eqStrictVar name) s.cs_current_vars
			= a <++ termCoder t s
			
		| isJust mbConstructor && constructor.nr_args == 0
			= constructorInliner t constructor [] s a		

		| isCAF 
			= force (escapeName s.cs_prefix name) a

		| isJust function_args && (length (fromJust function_args) == 0)
			= condForce s.cs_trampoline (\a -> a <++ escapeName s.cs_prefix name <++ "()") a
			= force (termCoder t s) a
	where
		mbConstructor = get name s.cs_constructors
		constructor = fromJust mbConstructor
		function_args = get name s.cs_functions	
		isCAF = isJust (get name s.cs_CAFs)

	forceTermCoder (StrictVar name level) s a = forceTermCoder (NormalVar name level) s a

	trampolineCoder t=:(NormalVar name _) s a
		| isJust mbConstructor && constructor.nr_args == 0
			= constructorInliner t constructor [] s a
			= a <++ termCoder t s
	where
		mbConstructor = get name s.cs_constructors
		constructor = fromJust mbConstructor

	trampolineCoder (StrictVar name level) s a = trampolineCoder (NormalVar name level) s a

	termCoder t=:(NormalVar name level) s a
		| isJust s.cs_inbody && not isLocalVar && isJust mbConstructor && constructor.nr_args == 0
			= constructorInliner t constructor [] s a	
				
		// custom data constructors can be inlined even at non-strict position
		| isJust mbInlineFun && inlineFun.data_cons && inlineFun.arity == 0
			= a <++ "(" <++ inlineFun.fun (\t a = termCoder t s a) (\t a = forceTermCoder t s a) [] <++ ")"
				
		| isJust s.cs_inbody && not isLocalVar && isJust mbCAF
			= a <++ escapeName s.cs_prefix name
			
		| isJust s.cs_inbody && not isLocalVar && isStrictFunction
			= a <++ escapeName s.cs_prefix name <++ "$eval"	

			// else (TODO: probably bogus in tail-recursion...)
			| any (eqVarByNameLevel t) s.cs_futuredefs
				= a <++ "[function(){return " <++ force var_name <++ ";},[]]"

			// else: use the defined name if its a built-in function, otherwise its a variable...
			// no prefix for built-in functions
			= a <++ (maybe var_name (escapeName "" o fst) (get name s.cs_builtins))			  
	where
		mbInlineFun = get name s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun
		mbConstructor = get name s.cs_constructors
		constructor = fromJust mbConstructor
		mbCAF = get name s.cs_CAFs

		// TODO: doc
		findLocalVar [(NormalVar cn level):cs] = if (cn == name) level (findLocalVar cs)
		findLocalVar [(StrictVar cn level):cs] = if (cn == name) level (findLocalVar cs)
		findLocalVar [] = 0
		isLocalVar = elem_by eqVarByName t s.cs_current_vars //isMember t s.cs_current_vars
		
		isFunction = isJust (get t s.cs_functions)		
		isStrictFunction = a || b
		where
			a = maybe False (any isStrictVar) (get name s.cs_functions)
			b = maybe False (\{args} -> any isStrictVar args) (get name s.cs_constructors)

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

	termCoder (StrictVar name level) s a = termCoder (NormalVar name level) s a

//----------------------------------------------------------------------------------------
// Let definitions...

/*
 * A let definition is not the spine of the function, avoid tail recursion optimization:
 * {s & cs_intrfunc = Nothing}
 */
letDefCoder :: ![SaplLetDef] !CoderState !StringAppender -> StringAppender
letDefCoder [t] s a = termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} a
letDefCoder all=:[t:ts] s a
	= a <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} <++ "," 
		<++ letDefCoder ts {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
	fvs = map (toNormalVar o unpackBindVar) all

letDefCoder [] _ a = a

isDependent :: ![SaplVar] !SaplTerm -> Bool 
isDependent vs (SApplication f as) = any (isDependent vs) [SVar f:as]
isDependent vs (SVar v) = elem_by eqVarByNameLevel v vs
isDependent _ _ = False

instance TermCoder SaplLetDef
where
	termCoder (SaplLetDef name body) s a
		= a <++ termCoder name {s & cs_futuredefs = []} <++ "=" 
			<++ (if (isStrictVar name) forceTermCoder termCoder) body s
			
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Expressions...

instance TermCoder SaplTerm
where
	// Generate code that forces the evaluation of the given term
	forceTermCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	forceTermCoder t=:(SVar var) s a = forceTermCoder var s a
	
	forceTermCoder t=:(SApplication name args) s a
		| isJust mbConstructor && constructor.nr_args == length args
			= constructorInliner name constructor args s a

		| isJust mbFunction && functionArity == 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 cannot be handled as tail recursive!
				True 	= a <++ make_tr_app args {s & cs_intrfunc = Nothing}	
				_		= condForce s.cs_trampoline 
							(\a -> a <++ func_name <++ "(" <++ make_app_args name args {s & cs_intrfunc = Nothing} <++ ")") a
				
		// more arguments than needed: split it
		| isJust mbFunction && functionArity < length args
			= forceApp (\a -> a <++ forceTermCoder (SApplication name (take functionArity args)) s <++ ",[" 
							 <++ termArrayCoder (drop functionArity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
				
		| isJust mbInlineFun && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"

		// more arguments than needed: split it
		| isJust mbInlineFun && inlineFun.arity < length args
			= forceApp (\a -> a <++ inlineFun.fun 
										(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
										(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) (take inlineFun.arity args) <++ ",[" 
							 <++ termArrayCoder (drop inlineFun.arity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
							 
		// BINs return no thunk, there is no need for feval even in trampolining
		// no prefix for built-in functions
		| isJust builtin && (snd (fromJust builtin)) == length args
			= a <++ escapeName "" (fst (fromJust builtin)) <++ "(" <++ make_app_args name args {s & cs_intrfunc = Nothing} <++ ")"

		// E.g.: in higher order functions application to argument
		| isNothing mbFunction && isNothing builtin
			= forceApp (\a -> a <++ termCoder name s <++ ",[" <++ termArrayCoder args "," s <++ "]") a

		// Otherwise: partial function application 
			= a <++ termCoder t s
			
	where
		func_name a = a <++ escapeName s.cs_prefix (unpackVar name) // skip level information

		mbConstructor = get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		mbInlineFun = get (unpackVar name) s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun
		mbFunction = get (unpackVar name) s.cs_functions
		functionArgs = fromJust mbFunction
		functionArity = length functionArgs

		tr_function_args = fromJust (get (unpackVar (fromJust s.cs_intrfunc)) s.cs_functions)
		builtin = get (unpackVar name) s.cs_builtins

		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 [(StrictVar _ _):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 s.cs_prefix (unpackVar fa) <++ "=t" <++ i <++ ";" <++ mta_2 fargs (i+1) s // skip level information for TR!
			mta_2 [] i s a = a

	forceTermCoder t s a = termCoder t s a

	// During trampolining, in only very special cases the expressions are forced in tail call
	trampolineCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	trampolineCoder t=:(SVar var) s a = trampolineCoder var s a
		
	trampolineCoder t=:(SApplication name args) s a
		| isJust mbConstructor && constructor.nr_args == length args
			= constructorInliner name constructor args s a	

		| isJust mbInlineFun && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"

			= a <++ termCoder t s
	where
		mbConstructor = get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		mbInlineFun = get (unpackVar name) s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun

	trampolineCoder t s a = termCoder t s a

	termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	termCoder t=:(SVar var) s a = termCoder var s a
		
	termCoder t=:(SSelect expr patterns) s a | any (isConsPattern o fst) patterns
		# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++  ";"
		= if (containsUnsafeSelect s t) (unsafe a) (safe a)
	where 
		isSingleton cons = (get_cons_or_die s cons).nr_cons == 1
		addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "};"
		(ps, d) = splitDefaultPattern patterns	

		// Something is very wrong with type inference here
		
		ups :: [(SaplPattern, SaplTerm, Bool)]
		ups = map (\(p,b)=(p,b,False)) ps

		defp :: SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
		defp d b = (PDefault,d,b)

		cp :: SaplPattern SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
		cp p d b = (p,d,b)

		unsafe a
			# a = addSwitch (termArrayCoder ups "" {s & cs_incaseexpr = True}) a
			= case d of
				(Just d) = a <++ termCoder (defp d False) s <++ ";"
						 = a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")
						 
		safe a
			# a = case patterns of
					[(p,body)] = if (isSingleton (fromJust (unpackConsName p))) 
										(termCoder (cp p body True) s a)
										(addSwitch (termCoder (cp p body False) s) a)
							   = addSwitch (termArrayCoder ups "" s) a
			= case d of
				(Just d) = a <++ termCoder (defp d False) s <++ ";"
						 = a
	
	termCoder t=:(SSelect expr patterns) s a
	    # a = a <++ "switch(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "){" 
	            <++ termArrayCoder (map (\(p,b)=(p,b,False)) ps) "" {s & cs_incaseexpr = True} <++ "};"
		= case d of
			(Just d) = a <++ termCoder (PDefault,d,False) s <++ ";"
					 = a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")			
	where
		(ps, d) = splitDefaultPattern patterns

	termCoder (SIf 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
		// It's only safe if there is no immediate evaluation
		| isJust mbConstructor && constructor.nr_args == length args && not (any isStrictVar constructor.args)
			= constructorInliner name constructor args s a	
		
		// custom data constructors can be inlined even at non-strict position
		| isJust mbInlineFun && inlineFun.data_cons && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"
					
			= a <++ "[" <++ termCoder name s <++ ",[" 
				<++ termArrayCoder args "," s
				<++ "]]"
	where
		mbConstructor = get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		func_name name a = a <++ escapeName s.cs_prefix (unpackVar name) // skip level information

		mbInlineFun = get (unpackVar name) s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun

	termCoder (SLit lit) s a = termCoder lit 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
		# s = pushArgs s defnames
		= a <++ "var " <++ letDefCoder newdefs s <++ ";\n " 
			<++ callWrapper body {s & cs_current_vars = defnames ++ s.cs_current_vars} <++ ";"
	where
		newdefs = case sortBindings defs of
						Just ds = ds
						Nothing = defs
						//Nothing = abort ("Cycle in let definitions is detected in function "+++toString (fromJust s.cs_inbody)+++"\n") // This is not supported currently

		defnames = map unpackBindVar newdefs

generateJS :: !Flavour !Bool !String !(Maybe ParserState) -> MaybeErrorString (StringAppender, ParserState)
generateJS f tramp saplsrc mbPst
	# pts = tokensWithPositions saplsrc
	= case parse pts of
		Ok (funcs, s) # newpst = mergeParserStates s mbPst
					  # (funcs, newpst) = if (isSet f "enableStrictnessPropagation") (doStrictnessPropagation newpst f funcs) (funcs, newpst)
					  # state = newState f tramp newpst
					  # a = newAppender <++ "/*Trampoline: "
					  # a = if tramp (a <++ "ON") (a <++ "OFF") 					  
					  # a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
					  = Ok (a, newpst)
		Error msg = Error msg
		
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) !StringAppender -> (MaybeErrorString (String, StringAppender, ParserState))
exprGenerateJS f tramp saplsrc mbPst out
	# pts = tokensWithPositions saplsrc
	= case parseExpr pts of
		Ok (body, s) # newpst = mergeParserStates s mbPst
					 # state = newState f tramp newpst
					 # a = termCoder body {state & cs_inbody=Just (NormalVar "__dummy" 0)} newAppender
					 # out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
					 = Ok (toString a, out, newpst)
		Error msg = Error msg