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, 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.Target.JS.Lifting
import Sapl.Transform.AddSelectors
import Sapl.Transform.TailRecursion
import StdDebug

from Data.List import elem_by, partition

:: CoderState = { cs_inbody 		:: !Maybe SaplTypedVar     // The body of the function which is being generated (not signature)
				, cs_intrfunc		:: !Maybe SaplTypedVar     // The name of the currently generated function if it is tail recursive
				, cs_inletbind		:: !Maybe SaplTypedVar     // The name of the let binding we are in
				, cs_futuredefs		:: ![SaplTypedVar]     	   // for finding out about let-rec and let bindings defined later 
				, cs_incaseexpr		:: !Bool
				, cs_current_vars 	:: ![SaplTypedVar]		 		
				, cs_constructors	:: !Map String ConstructorDef
				, cs_functions		:: !Map String [SaplTypedVar]
				, cs_CAFs			:: !Map String ()
				, 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_inletbind		= 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.Flavour.fun_prefix
			 }

pushArgs :: !CoderState ![SaplTypedVar] -> 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_inletbind
		= a <++ "var " <++ termCoder (fromJust s.cs_inletbind) {s & cs_futuredefs = []} <++ "=" <++ forceTermCoder t s <++ ";"
	| 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 :: !SaplTypedVar !SaplTerm -> Bool
isTailRecursive var (SCase _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar avar
isTailRecursive var (SLet body _) = isTailRecursive var body
isTailRecursive _ _ = False

strictnessMap :: !SaplType !CoderState -> Int
strictnessMap NoType _ = 0
strictnessMap (Type cons) {cs_constructors} 
	= case 'DM'.get cons cs_constructors of
		Nothing = 0
		(Just {args}) = toInt args 0
where
	toInt [] _ = 0
	toInt [TypedVar (StrictVar _ _) _:as] i = (toInt as (i+1)) bitor (2 << i)
	toInt [TypedVar (NormalVar _ _) _:as] i = toInt as (i+1)	

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 :: !SaplTypedVar !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 :: !SaplTypedVar !SaplTerm ![SaplTypedVar] !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_ [TypedVar (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 :: ![SaplTypedVar] !StringAppender -> StringAppender
recordFieldCoder [TypedVar t _] a = a <++ "\"" <++ unpackVar t <++ "\""
recordFieldCoder [TypedVar 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 ![SaplTypedVar] 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 [TypedVar (NormalVar _ _) _] [t] sep s a = termCoder t s a
	argsCoder [TypedVar (StrictVar _ _) _] [t] sep s a = forceTermCoder t s a	
	argsCoder [TypedVar (NormalVar _ _) _:fs] [t:ts] sep s a 
			= a <++ termCoder t s <++ sep <++ argsCoder fs ts sep s
	argsCoder [TypedVar (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 (SCase _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
containsUnsafeSelect s (SLet b _) = containsUnsafeSelect s b
containsUnsafeSelect s _ = False

isUsed :: SaplTerm SaplVar -> Bool
isUsed body var = w (unpackVar var) body
where
	w vn (SVar bvar) = unpackVar bvar == vn
	w vn (SApplication bvar bargs) = w vn bvar || any (w vn) bargs
	w vn (SCase bexpr branches) = w vn bexpr || any (w vn) (map snd branches)
	w vn (SLet bexpr bdefs) = w vn bexpr || any (w vn) (map unpackBindExpr bdefs)
	w vn (SSelect bexpr _ _) = w vn bexpr
	w vn (SUpdate bexpr _ updates) = w vn bexpr || any (w vn) (map snd updates)
	w _ _ = 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 <++ ": "

		# (fargs, _) = foldl (\(fs, i) a -> if (isUsed body a) ([(a,i):fs],i+1) (fs,i+1)) ([], 0) args 

		= case fargs of
			[] = a <++ callWrapper body s
			fargs = a <++ "var " <++ instargs (reverse fargs) s <++ callWrapper body s
						
	where 
		instargs [(t,i)] s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "];"
		instargs [(t,i):ts] s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "]," <++ instargs ts s
		instargs [] s a = a

		get_cons   = get_cons_or_die s cons

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

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

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

instance TermCoder SaplTypedVar
where
	forceTermCoder var s a = forceTermCoder (removeTypeInfo var) s a
	trampolineCoder var s a = trampolineCoder (removeTypeInfo var) s a
	termCoder var s a = termCoder (removeTypeInfo var) s a

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.InlineFunDef.data_cons && inlineFun.InlineFunDef.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) (map removeTypeInfo 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 [TypedVar (NormalVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
		findLocalVar [TypedVar (StrictVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
		findLocalVar [] = 0
		isLocalVar = elem_by eqVarByName t (map removeTypeInfo 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] !Bool !CoderState !StringAppender -> StringAppender
letDefCoder [t] needsvar s a | inline (unpackBindExpr t) 
		= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
		= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
		
letDefCoder all=:[t:ts] needsvar s a | inline (unpackBindExpr t) 
	= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} 
		<++ letDefCoder ts False {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
	fvs = map (toNormalVar o unpackBindVar) all

letDefCoder all=:[t:ts] needsvar s a
	= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} <++ ";\n"
		<++ letDefCoder ts True {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 (SVar 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 | inline body
		= a <++ termCoder name {s & cs_futuredefs = []} <++ "=" 
			<++ (if (isStrictVar name) forceTermCoder termCoder) body s

	termCoder (SaplLetDef name body) s a
		= a <++ (if (isStrictVar name) forceTermCoder termCoder) body {s & cs_inletbind = Just name}
			
	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 (SVar 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 (SVar name) (take functionArity args)) s <++ ",[" 
							 <++ termArrayCoder (drop functionArity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
				
		| isJust mbInlineFun && inlineFun.InlineFunDef.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.InlineFunDef.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.InlineFunDef.arity args) <++ ",[" 
							 <++ termArrayCoder (drop inlineFun.InlineFunDef.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
			# setters = filter (not o isSame) (zip2 tr_function_args args)
			= case sortSetters setters of
				Nothing
					# (tr_function_args, args) = unzip setters	
					= a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";" 
						<++ mta_2 tr_function_args 0 s <++ "continue;"
				// Reverse topological order is probably safe
				(Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue;"
				
		where
			mta_1 [TypedVar (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

			isSame (TypedVar var1 _, SVar var2) = unpackVar var1 == unpackVar var2
			isSame _ = False

			gen_setters [(TypedVar (StrictVar vn _) _,expr):ss] s a 
				= a <++ escapeName s.cs_prefix vn <++ "=" <++ forceTermCoder expr s <++ ";" <++ gen_setters ss s
			gen_setters [(TypedVar (NormalVar vn _) _,expr):ss] s a 
				= a <++ escapeName s.cs_prefix vn <++ "=" <++ termCoder expr s <++ ";" <++ gen_setters ss s
			gen_setters [] s a = a

	forceTermCoder (SApplication sel=:(SSelect _ _ _) args) s a
		= a <++ "Sapl.fapp(" <++ forceTermCoder sel s <++ ",["  
				<++ termArrayCoder args "," s
				<++ "])"

	forceTermCoder t=:(SSelect expr type idx) s a 
		| isStrict idx 
			= a <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "]"
			= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
	where
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0
	
	// It is always in a strict let bind
	forceTermCoder t=:(SUpdate expr type updates) s a
      = a <++ "var " <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "=" <++ forceTermCoder expr {s & cs_inletbind = Nothing} <++ ".slice(0);" <++ genUpd updates;
	where
		var = fromJust s.cs_inletbind
	
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0
	
		genUpd [] a = a
		genUpd [(idx, expr):us] a 
			= a <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "[" <++ idx + 2 <++ "]=" <++ 
			(if (isStrict idx) forceTermCoder termCoder) expr {s & cs_inletbind = Nothing} <++ ";" <++ genUpd us

	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 (SVar name) args) s a
		| isJust mbConstructor && constructor.nr_args == length args
			= constructorInliner name constructor args s a	

		| isJust mbInlineFun && inlineFun.InlineFunDef.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=:(SSelect expr type idx) s a
		| isStrict idx
			= a <++ "[Sapl.sselect,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
			= a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"			
	where
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0

	// Should not happen, at this point "update" is always at strict position
	termCoder t=:(SUpdate _ _ _) s a
      = a <++ "/* UPD */"

	termCoder t=:(SCase 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=:(SCase expr [(PLit (LBool True), true_expr),(PLit (LBool False), false_expr)]) s a
		= termCodeIf expr true_expr false_expr s a

	termCoder t=:(SCase expr [(PLit (LBool False), false_expr),(PLit (LBool True), true_expr)]) s a
		= termCodeIf expr true_expr false_expr s a
	
	termCoder t=:(SCase 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 (SApplication (SVar 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.InlineFunDef.data_cons && inlineFun.InlineFunDef.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

    // Dynamic application: fun part is always strict
	termCoder (SApplication sel=:(SSelect _ _ _) args) s a
		= a <++ "[" <++ forceTermCoder sel s <++ ",["  
				<++ termArrayCoder args "," s
				<++ "]]"

	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 <++ letDefCoder newdefs True s
			<++ 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

termCodeIf cond_expr true_expr false_expr s a 
	| inline cond_expr && inline true_expr && inline false_expr && 
	  not (isJust s.cs_intrfunc && (isTailRecursive (fromJust s.cs_intrfunc) true_expr || isTailRecursive (fromJust s.cs_intrfunc) false_expr))
	    = a <++ "(" <++ forceTermCoder cond_expr {s & cs_intrfunc = Nothing} <++ "?" 
	        <++ forceTermCoder true_expr {s & cs_incaseexpr = True} <++ ":" <++ forceTermCoder false_expr {s & cs_incaseexpr = True} <++ ")"

termCodeIf cond_expr texpr fexpr s a
	    = a <++ "if(" <++ forceTermCoder cond_expr {s & cs_intrfunc = Nothing} <++ "){" 
	        <++ callWrapper texpr {s & cs_incaseexpr = True} <++ "}else{" <++ callWrapper fexpr {s & cs_incaseexpr = True} <++ "}"
	
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 (isStrictArgFlavour f) funcs) (funcs, newpst)
					  # state = newState f tramp newpst
					  # a = newAppender <++ "\"use strict\";"
					  # a = a <++ "/*Trampoline: "
					  # a = if tramp (a <++ "ON") (a <++ "OFF")
					  
					  // Lift + generated update functions
					  # (funcs, genfuns) = foldl (upd (isStrictArgFlavour f newpst)) ([], 'DM'.newMap) funcs
					  # funcs = reverse funcs ++ 'DM'.elems genfuns 
					  
					  # a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
					  = Ok (a, newpst)
		Error msg = Error msg	
where		
  upd :: (String Int Int -> Bool) ([FuncType], Map String FuncType) FuncType -> ([FuncType], Map String FuncType)
  upd sf (nfs, genfuns) fun 
  	= let (nfun, ngenfuns) = prepareFun sf fun genfuns in ([nfun:nfs], 'DM'.union genfuns ngenfuns)
  		
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
					 
					  // Lift + generated update functions. TODO: do not skip generated functions
					  # (body, _) = prepareExpr (isStrictArgFlavour f newpst) body 'DM'.newMap
					 
					 # a = termCoder body {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
					 # out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
					 = Ok (toString a, out, newpst)
		Error msg = Error msg