implementation module Sapl.Target.JS.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, Data.Maybe, Data.Void, Text.StringAppender, Sapl.FastString
import qualified Data.List as DL
import qualified Data.Map as DM
import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation
import Sapl.Transform.Let
import Sapl.Transform.AddSelectors

from Data.List import elem_by, partition

:: 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 (addSelectors 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 'DM'.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
			   	       ('DM'.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 = 'DM'.get name s.cs_constructors
		constructor = fromJust mbConstructor
		function_args = 'DM'.get name s.cs_functions	
		isCAF = isJust ('DM'.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 = 'DM'.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) ('DM'.get name s.cs_builtins))			  
	where
		mbInlineFun = 'DM'.get name s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun
		mbConstructor = 'DM'.get name s.cs_constructors
		constructor = fromJust mbConstructor
		mbCAF = 'DM'.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 ('DM'.get t s.cs_functions)		
		isStrictFunction = a || b
		where
			a = maybe False (any isStrictVar) ('DM'.get name s.cs_functions)
			b = maybe False (\{args} -> any isStrictVar args) ('DM'.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 = 'DM'.get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		mbInlineFun = 'DM'.get (unpackVar name) s.cs_inlinefuncs
		inlineFun = fromJust mbInlineFun
		mbFunction = 'DM'.get (unpackVar name) s.cs_functions
		functionArgs = fromJust mbFunction
		functionArity = length functionArgs

		tr_function_args = fromJust ('DM'.get (unpackVar (fromJust s.cs_intrfunc)) s.cs_functions)
		builtin = 'DM'.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 = 'DM'.get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		mbInlineFun = 'DM'.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=:(SSelector (SSelect expr [(PCons _ vs, SVar x)])) s a
      # (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs
      = a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
	termCoder t=:(SSelector x) s a = termCoder x 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 = 'DM'.get (unpackVar name) s.cs_constructors
		constructor = fromJust mbConstructor
		func_name name a = a <++ escapeName s.cs_prefix (unpackVar name) // skip level information

		mbInlineFun = 'DM'.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 <++ "\"use strict\";"
					  # a = a <++ "/*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