"update" syntax

src/Sapl/Optimization/StrictnessPropagation.icl

@@ -49,7 +49,13 @@ where
 	walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
 
     // We can skip the new expr, cannot contain let definitions...
-	walk sd t=:(SSelect expr idx) 
+	walk sd t=:(SUpdate expr _ updates) 
+		# (sd, _) = walk sd expr
+		// TODO: updates
+		= (sd, t)
+
+    // We can skip the new expr, cannot contain let definitions...
+	walk sd t=:(SSelect expr _ idx) 
 		# (sd, _) = walk sd expr
 		= (sd, t)
 
@@ -64,7 +70,7 @@ where
 		strictArgs = map fst (filter checkArg (zip2 args [0..]))
 
     // We can skip the new expr, cannot contain let definitions...
-    // Args cannot be checked, we do not know the function defiition...
+    // Args cannot be checked, we do not know the function definition...
 	walk sd t=:(SApplication expr args)
 		// expr is always strict
 		# (sd, _) = walk sd expr

src/Sapl/SaplParser.icl

@@ -66,6 +66,9 @@ addTupleCons _ = returnS Void
 read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
 read_int ts = returnS (Nothing, ts)
 
+type [TTypeDef, TIdentifier type:ts] = returnS (Type type, ts)
+type ts = returnS (NoType, ts) 
+
 expr [TOpenParenthesis:ts] = 
 				mexpr ts
 			>>=	\(t, ts) = case hd ts of
@@ -86,12 +89,35 @@ expr [TIdentifier name:ts] =
 expr [TSelectKeyword:ts] = 
 				sexpr ts 
 			>>= mandatory "Missing select expression"
-			>>= \(expr, ts) = read_int ts
+			>>= \(expr, ts) = type ts			
+			>>= \(ty, ts) = read_int ts			
 			>>= mandatory "Missing select index"
 			>>= \(idx, ts) = args_expr ts
 			>>= \(as, ts) = case as of
-								[] = returnS (Just (SSelect expr idx), ts)
-								   = returnS (Just (SApplication (SSelect expr idx) as), ts)
+								[] = returnS (Just (SSelect expr ty idx), ts)
+								   = returnS (Just (SApplication (SSelect expr ty idx) as), ts)
+
+expr [TUpdateKeyword:ts] = 
+				sexpr ts 
+			>>= mandatory "Missing update expression"
+			>>= \(expr, ts) = type ts
+			>>= \(ty, ts) = upd_list ts
+			>>= \(upds, ts) = returnS (Just (SUpdate expr ty upds), ts)
+where
+	upd_list [TOpenSquareBracket:ts] = 
+				update_1 ts []
+			>>=	\(us, ts) = case hd ts of
+						TCloseSquareBracket = returnS (us, tl ts)
+								      = returnE (ts, "Missing close square bracket")
+	upd_list ts = returnE (ts, "Missing open bracket")
+
+	update_1 [TLit (LInt idx),TColon:ts] as =
+			 	expr ts
+		 	>>= mandatory "Missing field update expression"
+		 	>>= \(expr, ts) = update_2 ts [(idx, expr):as]
+	update_1 ts as = returnE (ts, "Invalid field \"update\"")
+	update_2 [TComma: ts] as = update_1 ts as
+	update_2 ts as = returnS (reverse as, ts)	
 
 expr ts = returnS (Nothing, ts)
 
@@ -132,7 +158,7 @@ where
 			>>= \level = body False ts 
 			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
 	letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
-	letdef_2 [TColon: ts] as = letdef_1 ts as
+	letdef_2 [TComma: ts] as = letdef_1 ts as
 	letdef_2 ts as = returnS (reverse as, ts)
 
 body simple [TOpenParenthesis:ts] = 
@@ -220,7 +246,7 @@ where
 	args_1 [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) (Type type):as]	
 	args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) NoType:as]	
 	args_1 ts as = returnE (ts, "Missing argument")
-	args_2 [TColon:ts] as = args_1 ts as
+	args_2 [TComma:ts] as = args_1 ts as
 	args_2 ts as = returnS (reverse as, ts)
 
 args_adt ts = args_1 ts [] 0
@@ -291,7 +317,7 @@ parse pts
 	# ts = map (\(PosToken _ _ t) = t) pts
 	= case (program ts []) defaultState of
 				Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps)
-				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
+				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
 where
 	findpos rest_ts 
 		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
@@ -303,7 +329,7 @@ parseExpr pts
 	# ts = map (\(PosToken _ _ t) = t) pts
 	= case (body False ts) defaultState of
 				Ok ((fts, _),ps) = Ok (fts,ps)
-				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
+				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
 where
 	findpos rest_ts 
 		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts

src/Sapl/SaplStruct.dcl

@@ -20,7 +20,8 @@ import Data.Maybe
 			| SApplication SaplTerm [SaplTerm]
 			| SCase SaplTerm [(SaplPattern, SaplTerm)]
 			| SLet SaplTerm [SaplLetDef]
-			| SSelect SaplTerm Int
+			| SSelect SaplTerm SaplType Int
+			| SUpdate SaplTerm SaplType [(Int, SaplTerm)]			
 			| SAbortBody			
 
 :: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm

src/Sapl/SaplTokenizer.dcl

@@ -14,16 +14,20 @@ import StdString, Text.Unicode
 	     | TMacroAssignmentOp
 	     | TCAFAssignmentOp	     
      	 | TLambda
+     	 | TComma
      	 | TColon
      	 | TVerticalBar     	 
 		 | TOpenParenthesis
  		 | TCloseParenthesis
  		 | TOpenBracket
  		 | TCloseBracket
+ 		 | TOpenSquareBracket
+ 		 | TCloseSquareBracket
  		 | TTypeDef
 		 | TLit Literal
 		 | TCaseKeyword
-		 | TSelectKeyword		 
+		 | TSelectKeyword
+		 | TUpdateKeyword		 
 		 | TLetKeyword
 		 | TInKeyword
 		 | TEndOfLine

src/Sapl/SaplTokenizer.icl

@@ -10,7 +10,7 @@ is_stopchar :: !Char -> Bool
 is_stopchar char 
 	= (char == '=') || (char == ':') || (char == ')') || (char == '(') || 
 	  (char == '|') || (char == '{') || (char == '}') || (char == ',') || 
-	  (char == ';') || isSpace char
+	  (char == '[') || (char == ']') || isSpace char
 
 not_stopchar = not o is_stopchar
 is_space c = isSpace c && not_eol c
@@ -78,7 +78,7 @@ read_token :: !Int !String -> (!Int, !Int, !Token)
 read_token base line
 	| start > ((size line)-1) 
 		= rnoarg TEndOfLine 0	
-	| matchCharAt ';' line start || matchCharAt '\n' line start
+	| matchCharAt '\n' line start
 		= rnoarg TEndOfLine 1
 	// Skip <{ and }> from the identifier. It's to help parsing "strange" function names
 	| matchAt "!<{" line start
@@ -102,10 +102,10 @@ read_token base line
 		= rnoarg TMacroAssignmentOp 3
 	| matchAt "->" line start
 		= rnoarg TCaseAssignmentOp 2		
-	| matchCharAt '\\' line start 
-		= rnoarg TLambda 1
 	| matchCharAt ',' line start 
-		= rnoarg TColon 1
+		= rnoarg TComma 1
+	| matchCharAt ':' line start 
+		= rnoarg TColon 1		
 	| matchCharAt '(' line start 
 		= rnoarg TOpenParenthesis 1
 	| matchCharAt ')' line start 
@@ -114,6 +114,10 @@ read_token base line
 		= rnoarg TOpenBracket 1
 	| matchCharAt '}' line start 
 		= rnoarg TCloseBracket 1
+	| matchCharAt '[' line start 
+		= rnoarg TOpenSquareBracket 1
+	| matchCharAt ']' line start 
+		= rnoarg TCloseSquareBracket 1
 	| matchCharAt '"' line start
 		# (nextbase,ustr) = read_string_lit '"' (start+1) line
 		= return (TLit (LString ustr), nextbase)
@@ -138,6 +142,7 @@ read_token base line
 			"true"   = return (TLit (LBool True), stop)
 			"case"   = return (TCaseKeyword, stop)
 			"select" = return (TSelectKeyword, stop)
+			"update" = return (TUpdateKeyword, stop)
 			"let"	 = return (TLetKeyword, stop)
 			"in"	 = return (TInKeyword, stop)
 			str		 = if (str.[0] == '!') 
@@ -216,8 +221,8 @@ where
 	toString TAssignmentOp = "="
 	toString TMacroAssignmentOp = ":=="
 	toString TCAFAssignmentOp = "=:"
-	toString TLambda = "\\"
-	toString TColon = ","
+	toString TComma = ","
+	toString TColon = ":"
 	toString TVerticalBar = "|"
 	toString TOpenParenthesis = "("
 	toString TCloseParenthesis = ")"

src/Sapl/Target/JS/CodeGeneratorJS.icl

@@ -16,6 +16,7 @@ import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimizati
 import Sapl.Transform.Let
 import Sapl.Target.JS.Lifting
 import Sapl.Transform.AddSelectors
+import StdDebug
 
 from Data.List import elem_by, partition
 
@@ -109,6 +110,17 @@ isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar av
 isTailRecursive var (SLet body _) = isTailRecursive var body
 isTailRecursive _ _ = False
 
+strictnessMap :: !SaplType !CoderState -> Int
+strictnessMap NoType _ = 0
+strictnessMap (Type cons) {cs_constructors} 
+	= case 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
@@ -569,13 +581,32 @@ where
 				= 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 (SApplication sel=:(SSelect _ _) args) s a
+	forceTermCoder (SApplication sel=:(SSelect _ _ _) args) s a
 		= a <++ "Sapl.fapp(" <++ forceTermCoder sel s <++ ",["  
 				<++ termArrayCoder args "," s
 				<++ "])"
 
-	forceTermCoder t=:(SSelect expr idx) s a
-      = a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
+	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
 
@@ -604,8 +635,17 @@ where
 	termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
 	termCoder t=:(SVar var) s a = termCoder var s a
 		
-	termCoder t=:(SSelect expr idx) s a
-      = a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
+	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 thi spoint "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} <++  ";"
@@ -680,7 +720,7 @@ where
 		inlineFun = fromJust mbInlineFun
 
     // Dynamic application: fun part is always strict
-	termCoder (SApplication sel=:(SSelect _ _) args) s a
+	termCoder (SApplication sel=:(SSelect _ _ _) args) s a
 		= a <++ "[" <++ forceTermCoder sel s <++ ",["  
 				<++ termArrayCoder args "," s
 				<++ "]]"
@@ -724,18 +764,31 @@ generateJS f tramp saplsrc mbPst
 					  # 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 <++ "*/") (map prepareFun funcs)
+					  # a = if tramp (a <++ "ON") (a <++ "OFF")
+					  
+					  // Lift + generated update functions
+					  # (funcs, genfuns) = foldl (upd (isStrictArgFlavour f newpst)) ([], newMap) funcs
+					  # funcs = reverse funcs ++ elems genfuns 
+					  
+					  # a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
 					  = Ok (a, newpst)
-		Error msg = Error msg
-		
+		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], 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
-					 # a = termCoder (prepareExpr body) {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
+					 
+					  // Lift + generated update functions. TODO: do not skip generated functions
+					  # (body, _) = prepareExpr (isStrictArgFlavour f newpst) body 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

src/Sapl/Target/JS/Lifting.dcl

 definition module Sapl.Target.JS.Lifting
 
 import Sapl.SaplStruct
+import Data.Map
 
 // Returns True if a term can be inlined, i.e. no separate statement is needed
 inline :: !SaplTerm -> Bool
 
-prepareFun  :: !FuncType -> FuncType
-prepareExpr :: !SaplTerm -> SaplTerm
+// First function: decide on strictness. See doStrictnessPropagation
+// Map: generated functions
+prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
+prepareExpr :: (!String !Int !Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
 
 

src/Sapl/Target/JS/Lifting.icl

@@ -2,89 +2,146 @@ implementation module Sapl.Target.JS.Lifting
 
 import StdEnv
 import Sapl.SaplStruct
+import Data.Map
 
 inline :: !SaplTerm -> Bool
 inline (SLet _ _) = False
+inline (SUpdate _ _ _) = False
 inline (SCase cond [(PLit (LBool true), case1),(PLit (LBool false), case2)]) = inline cond && inline case1 && inline case2
 inline (SCase cond [(PLit (LBool false), case1),(PLit (LBool true), case2)]) = inline cond && inline case1 && inline case2
 inline (SCase _ _) = False
 inline _ = True
 
-prepareFun :: !FuncType -> FuncType
-prepareFun (FTFunc name body args) = FTFunc name (prepareExpr body) args
-prepareFun (FTCAF name body) = FTCAF name (prepareExpr body)
-prepareFun ftype = ftype
-
-:: LiftingState = {varidx :: Int}
-
-prepareExpr :: !SaplTerm -> SaplTerm
-prepareExpr t 
-	# (t, st, defs) = walkTerm t {varidx = 1} 
-	= case defs of
-		[] = t
-		defs = SLet t defs
-	
-walkTerm :: !SaplTerm !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef])
-walkTerm (SCase cond patterns) st | not (inline cond)
-	# (letvar, st) = genVar st
-	# casevar = SVar (removeTypeInfo letvar)	
-	
-	# (patterns, st, pdefs) = walkPatterns patterns st
-	# defs = [SaplLetDef letvar cond:pdefs]
- 
-	= case defs of
-		[] = (SCase casevar patterns, st, [])
-		defs = (SLet (SCase casevar patterns) defs, st, [])
+prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
+prepareFun sf (FTFunc name body args) genfuns
+	# (body, genfuns) = prepareExpr sf body genfuns 
+	= (FTFunc name body args,genfuns)
+prepareFun sf (FTCAF name body) genfuns
+	# (body, genfuns) = prepareExpr sf body genfuns
+	= (FTCAF name body, genfuns)
+prepareFun _ ftype genfuns = (ftype, genfuns)
+
+:: LiftingState = {varidx :: Int, genfuns :: Map String FuncType}
+
+genUpdateFun :: SaplTerm -> FuncType
+genUpdateFun (SUpdate _ ty updates)
+	= FTFunc (TypedVar (NormalVar funName 0) NoType) 
+			 (SUpdate (SVar (NormalVar "e" 0)) ty
+			 	[(idx, SVar (NormalVar ("a" +++ toString i) 0)) \\ i <- [1..length updates] & idx <- map fst updates])
+			 [TypedVar (NormalVar "e" 0) NoType:[TypedVar (NormalVar ("a" +++ toString i) 0) NoType \\ i <- [1..length updates]]]
 where
-  genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {varidx = varidx + 1})
-
-walkTerm c=:(SCase cond patterns) st
-	# (cond, st, cdefs) = walkTerm cond st
-	# (patterns, st, pdefs) = walkPatterns patterns st
-	# defs = cdefs ++ pdefs
+	funName = case ty of
+				NoType = "update$" +++ toString (mask updates 0) 
+				(Type tn) = "update$" +++ tn +++ "_" +++ toString (mask updates 0) 
+				
+	mask [] bits = bits	
+	mask [(idx,_):us] bits = mask us ((1 << idx) bitor bits)
+	
+prepareExpr :: (!String !Int !Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
+prepareExpr sf t genfuns
+	# (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns} 
 	= case defs of
-		[] = (SCase cond patterns, st, []) // TODO: move to pattern
-		defs = (SLet (SCase cond patterns) defs, st, [])
-
-// TODO: bindings (insert) strict?
-walkTerm (SLet expr bindings) st
-	# (expr, st, defs) = walkTerm expr st 
-	=  case defs of
-		[] = (SLet expr bindings, st, [])  
-		defs = (SLet expr (bindings ++ defs), st, [])  
-
-walkTerm (SSelect expr idx) st
-	# (expr, st, defs) = walkTerm expr st 
-	=  (SSelect expr idx, st, defs)  
-
-/*
-walkTerm (SApplication sel=:(SSelect sexpr _) args) st
-	# (letvar, st) = genVar st
-	# selvar = SVar (removeTypeInfo letvar)
-	# (args, st, defs) = walkArgs args st
-	= (SApplication selvar args, st, [SaplLetDef letvar sel:defs])
+		[] = (t, st.genfuns)
+		defs = (SLet t defs, st.genfuns)
 where
-  genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {varidx = varidx + 1})
-*/
+	walkTerm :: !SaplTerm !Bool !Bool !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef])
+	walkTerm (SCase cond patterns) _ _ st | not (inline cond)
+		# (cond, st, cdefs) = walkTerm cond True True st	
+		# (letvar, st) = genVar st
+		# casevar = SVar (removeTypeInfo letvar)
+		# (patterns, st) = walkPatterns patterns st
+		# defs = [SaplLetDef letvar cond:cdefs]
+		= case defs of
+			[] = (SCase casevar patterns, st, [])
+			defs = (SLet (SCase casevar patterns) defs, st, [])
+	where
+	  genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {st & varidx = varidx + 1})
+
+	walkTerm c=:(SCase cond patterns) doNotLift _ st
+		# (cond, st, cdefs) = walkTerm cond False True st
+		# (patterns, st) = walkPatterns patterns st
+		# defs = cdefs
+		= case defs of
+			[] = (SCase cond patterns, st, []) // TODO: move to pattern?
+			defs = (SLet (SCase cond patterns) defs, st, [])
+
+	walkTerm (SLet expr bindings) doNotLift _ st
+		# (expr, st, edefs) = walkTerm expr False True st 
+		# (bindings, st, bdefs) = walkBindings bindings st 	
+		# defs = edefs ++ bdefs
+		=  case defs of
+			[] = (SLet expr (bindings ++ defs), st, [])  
+			defs = (SLet expr (bindings ++ defs), st, [])  
+
+	walkTerm (SSelect expr ty idx) doNotLift strictPosition st
+		# (expr, st, defs) = walkTerm expr False strictPosition st 
+		=  (SSelect expr ty idx, st, defs)  
+
+	walkTerm (SUpdate expr ty updates) False True st
+		# (letvar, st) = genVar st
+		# updvar = SVar (removeTypeInfo letvar)	
+		# (updates, st, udefs) = walkUpdates updates st
+		# (expr, st, edefs) = walkTerm expr False True st 
+		= (updvar, st, [SaplLetDef letvar (SUpdate expr ty updates):edefs++udefs])	
+	where
+		genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {st & varidx = varidx + 1})
+
+	walkTerm (SUpdate expr ty updates) False False st
+		# (expr, st, edefs) = walkTerm expr False False st 
+		# (updates, st, udefs) = walkUpdates updates st
+		// Generate new fun and lift it in the same time
+		# (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) newMap 
+		# funname = extractName genfun
+		=  (SApplication (SVar funname) [expr:map snd updates], 
+					{st & genfuns = put (unpackVar funname) genfun st.genfuns}, edefs ++ udefs)  
+	where
+		extractName (FTFunc (TypedVar name _) _ _) = name
+
+	walkTerm (SUpdate expr ty updates) _ strictPosition st
+		# (expr, st, edefs) = walkTerm expr False strictPosition st 
+		# (updates, st, udefs) = walkUpdates updates st
+		=  (SUpdate expr ty updates, st, edefs ++ udefs)  
+
+	walkTerm (SApplication v=:(SVar name) args) doNotLift strictPosition st
+		# (args, st, defs) = walkArgs [sf (unpackVar name) (length args) i \\ i <- [0..]] args st
+		= (SApplication v args, st, defs)
+
+	walkTerm (SApplication name args) doNotLift strictPosition st
+		# (args, st, defs) = walkArgs (repeat False) args st
+		= (SApplication name args, st, defs)
+
+	walkTerm t _ _ st = (t, st, [])
+
+	walkArgs _ [] st = ([], st, [])
+	walkArgs [isStrict:si] [t:ts] st
+		# (t, st, def) = walkTerm t False isStrict st 
+		# (ts, st, defs) = walkArgs si ts st
+		= ([t:ts], st, def ++ defs)
+	
+	walkPatterns [] st = ([], st)
+	walkPatterns [(p, t):ps] st 
+		# (t, st, defs) = walkTerm t False True st 
+		# t = case defs of
+			[]  = t
+			defs = SLet t defs 	 
+		# (ps, st) = walkPatterns ps st
+		= ([(p,t):ps], st)	
+	
+	walkBindings [] st = ([], st, [])
+	walkBindings [SaplLetDef var expr:bs] st 
+		# (expr, st, def) = walkTerm expr True (isStrictVar var) st
+		# (bs, st, defs) = walkBindings bs st
+		= ([SaplLetDef var expr:bs], st, def ++ defs)
 
-walkTerm (SApplication name args) st
-	# (args, st, defs) = walkArgs args st
-	= (SApplication name args, st, defs)
+	walkUpdates [] st = ([], st, [])
+	walkUpdates [(idx,expr):us] st 
+		# (expr, st, def) = walkTerm expr True False st
+		# (us, st, defs) = walkUpdates us st
+		= ([(idx, expr):us], st, def ++ defs)
 
-walkTerm t st = (t, st, [])
 
-walkArgs [] st = ([], st, [])
-walkArgs [t:ts] st
-	# (t, st, def) = walkTerm t st 
-	# (ts, st, defs) = walkArgs ts st
-	= ([t:ts], st, def ++ defs)
+		
 	
-walkPatterns [] st = ([], st, [])
-walkPatterns [(p, t):ps] st 
-	# (t, st, def) = walkTerm t st 
-	# (ts, st, defs) = walkPatterns ps st
-	= ([(p, t):ts], st, def ++ defs)
-
 
 
 

src/Sapl/Transform/AddSelectors.icl

@@ -8,10 +8,10 @@ import StdBool, StdList
 instance addSelectors SaplTerm where
   addSelectors (SApplication v ts) = SApplication v (map addSelectors ts)
 
-  addSelectors st=:(SCase t ps=:[(PCons _ vs, SVar x)])
+  addSelectors st=:(SCase t ps=:[(PCons cons vs, SVar x)])
     | foldr (\v acc -> acc || eqVarByName v x) False vs 
     	# (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs  
-    	= SSelect t idx
+    	= SSelect t (Type cons)  idx
     | otherwise                                         
     	= SCase t ps
     

src/Sapl/Transform/Let.icl

@@ -19,7 +19,8 @@ where
 genGraph :: !(Set SaplVar) ![SaplLetDef] -> (!Set (SaplVar,SaplVar), !Set SaplVar)
 genGraph binds defs = foldl (\s (SaplLetDef (TypedVar bv _) body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
 where
-	gen vs bv s (SSelect expr idx) = gen vs bv s expr
+	gen vs bv s (SSelect expr _ idx) = gen vs bv s expr
+	gen vs bv s (SUpdate expr _ updates) = foldl (gen vs bv) (gen vs bv s expr) (map snd updates)
 	gen vs bv s (SApplication (SVar f) as) = foldl (gen vs bv) s [SVar f:as]
 	gen vs bv s (SApplication expr as) = foldl (gen vs bv) (gen vs bv s expr) as
 	gen vs bv (es,is) (SVar v)