compiler to the new SAPL

src/Sapl/Optimization/StrictnessPropagation.icl

@@ -47,8 +47,13 @@ propBody ps flavour sd body = walk sd body
 where
 	walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
 
-	walk sd t=:(SApplication var args)
-		// We can skip the new args, cannot contain let definitions...
+    // We can skip the new expr, cannot contain let definitions...
+	walk sd t=:(SSelect expr idx) 
+		# (sd, _) = walk sd expr
+		= (sd, t)
+
+    // We can skip the new args, cannot contain let definitions...
+	walk sd t=:(SApplication (SVar var) args)
 		# nsds = map fst (map (walk newSet) strictArgs)
 		= (unions [sd:nsds], t)
 	where
@@ -57,16 +62,17 @@ where
 		checkArg (arg, i) = isStrictArg ps flavour varName nr_args i
 		strictArgs = map fst (filter checkArg (zip2 args [0..]))
 
-	walk sd (SIf c l r) 
-		# (sdl, nl) = walk newSet l
-		# (sdr, nr) = walk newSet r		
-		# (sdc, nc) = walk sd c
-		= (union sdc (intersection sdl sdr), SIf nc nl nr)
+    // We can skip the new expr, cannot contain let definitions...
+    // Args cannot be checked, we do not know the function defiition...
+	walk sd t=:(SApplication expr args)
+		// expr is always strict
+		# (sd, _) = walk sd expr
+		= (sd, t)
 
-	walk sd (SSelect p cases) 
+	walk sd (SCase p cases) 
 		# (sdp, np) = walk sd p
 		# (sdcs, ncases) = unzip (map walkcase cases)
-		= (union sdp (intersections sdcs), SSelect np ncases)
+		= (union sdp (intersections sdcs), SCase np ncases)
 	where
 		walkcase (p, c) 
 			# (sd, nc) = walk newSet c 
@@ -89,7 +95,7 @@ where
 		where
 			vn = unpackVar (unpackBindVar bnd)
 
-			// Delete itself, it dosn't need any more
+			// Delete itself, it doesn't need any more
 			walkbnd sd (SaplLetDef (TypedVar (StrictVar vn _) _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
 			walkbnd sd (SaplLetDef (TypedVar (NormalVar vn _) _) body) = delete vn sd
 		

src/Sapl/SaplParser.dcl

@@ -49,4 +49,3 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
 * @return merged parser state
 */
 mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
-			

src/Sapl/SaplParser.icl

@@ -63,98 +63,110 @@ where
 
 addTupleCons _ = returnS Void
 
-factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
-factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
-factor [TOpenParenthesis:ts] = 
-				application ts
+read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
+read_int ts = returnS (Nothing, ts)
+
+expr [TOpenParenthesis:ts] = 
+				mexpr ts
 			>>=	\(t, ts) = case hd ts of
 						TCloseParenthesis = returnS (Just t, tl ts)
-										  = returnE (ts, "Missing close parenthesis")
-factor ts = returnS (Nothing, ts)
+										  = returnE (ts, "Missing close parenthesisx")
 
-application [TOpenParenthesis:ts] = 
-				application ts
-			>>=	\(t, ts) = case hd ts of
-						TCloseParenthesis = returnS (t, tl ts)
-										  = returnE (ts, "Missing close parenthesis")
+expr [TLit lit:ts] = returnS (Just (SLit lit), ts)
 
-application [TIdentifier name:ts] = 
+expr [TIdentifier name:ts] = 
 				getLevel
 			>>= \level = returnS (NormalVar name level)
 			>>= \t = addTupleCons name
-			>>= \_ = args_factor ts
+			>>= \_ = args_expr ts
 			>>= \(as, ts) = case as of
-								[] = returnS (SVar t, ts) // !!!
-								   = returnS (SApplication t as, ts)
-
-application [TLit lit:ts] = returnS (SLit lit, ts)
-application ts = returnE (ts, "Invalid application")
-
-selectexpr [TIfKeyword:ts] = 
-				arg_adv ts 
-			>>= mandatory "Missing predicate"
-			>>= \(pred, ts) = arg_adv ts
-			>>= mandatory "Missing left hand side"
-			>>= \(lhs, ts) = arg_adv ts
-			>>= mandatory "Missing right hand side"			
-			>>= \(rhs, ts) = returnS (Just (SIf pred lhs rhs), ts)
-				
-selectexpr [TSelectKeyword:ts] = 
-				arg_adv ts
-			>>= mandatory "Missing select expression"				
-			>>= \(expr, ts) = args_pattern ts
-			>>= \(ps, ts) = if (isEmpty ps) 
-							   (returnE (ts, "Missing select patterns"))
-							   (returnS (Just (SSelect expr ps), ts))
-			
-selectexpr ts = returnS (Nothing, ts)
+								[] = returnS (Just (SVar t), ts)
+								   = returnS (Just (SApplication (SVar t) as), ts)
+
+expr [TSelectKeyword:ts] = 
+				sexpr ts 
+			>>= mandatory "Missing select expression"
+			>>= \(expr, 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)
+
+expr ts = returnS (Nothing, ts)
+
+sexpr [TOpenParenthesis:ts] = 
+				mexpr ts
+			>>=	\(t, ts) = case hd ts of
+						TCloseParenthesis = returnS (Just t, tl ts)
+										  = returnE (ts, "Missing close parenthesisx")
 
-mainexpr ts = selectexpr ts 
-			>>= \(t, ts) = case t of
-								Just t = returnS (t, ts)
-						   			   = application ts
+sexpr [TLit lit:ts] = returnS (Just (SLit lit), ts)
+
+sexpr [TIdentifier name:ts] = 
+				getLevel
+			>>= \level = returnS (NormalVar name level)
+			>>= \t = addTupleCons name
+			>>= \_ = returnS (Just (SVar t), ts)
+
+sexpr ts = returnS (Nothing, ts)
+
+mexpr ts = expr ts >>= mandatory "Missing expression"
 
 letdefinitions ts = letdef_1 ts []
 where
 	letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
 				getLevel
-			>>= \level = application ts 
+			>>= \level = body False ts 
 			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
 	letdef_1 [TIdentifier name, TAssignmentOp:ts] as = 
 				getLevel
-			>>= \level = application ts 
+			>>= \level = body False ts 
 			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
 	letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
 				getLevel
-			>>= \level = application ts 
+			>>= \level = body False ts 
 			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]			
 	letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as = 
 				getLevel
-			>>= \level = application ts 
+			>>= \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 ts as = returnS (reverse as, ts)
 
-body [TLetKeyword:ts] =
+body simple [TOpenParenthesis:ts] = 
+				body False ts
+			>>=	\(t, ts) = case hd ts of
+						TCloseParenthesis = returnS (t, tl ts)
+										  = returnE (ts, "Missing close parenthesis")
+
+body simple [TLetKeyword:ts] =
 				incLevel ts
 			>>= \ts = letdefinitions ts
 			>>= \(ds, ts) = case hd ts of
 					TInKeyword = returnS (tl ts)
 							   = returnE (ts, "Missing \"in\" keyword")
-			>>= \ts = mainexpr ts
+			>>= \ts = body False ts
 			>>= \(t, ts) = returnS (SLet t ds, ts)
 			>>= decLevel
+
+body simple [TCaseKeyword:ts] = 
+				body True ts		
+			>>= \(expr, ts) = args_pattern ts
+			>>= \(ps, ts) = if (isEmpty ps) 
+							   (returnE (ts, "Missing case patterns"))
+							   (returnS (SCase expr ps, ts))
 	
-body [TOpenBracket:ts] = skip ts	// ABC code: skip it	
+body simple [TOpenBracket:ts] = skip ts	// ABC code: skip it	
 where
 	skip [TCloseBracket:ts] = returnS (SAbortBody, ts)
 	skip [] = returnE ([], "Missing close bracket in ABC code definition")
 	skip [t:ts] = skip ts
 			
-body ts = mainexpr ts
+body simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"
 
-args_factor ts = args_ factor ts
+args_expr ts = args_ sexpr ts
 args_pattern ts = args_ arg_pattern ts
 
 args_ f ts = args` ts []
@@ -166,36 +178,28 @@ where
 
 arg_pattern [TOpenParenthesis:TLit lit:ts] =
 			case hd ts of
-				TSelectAssignmentOp = body (tl ts)
+				TCaseAssignmentOp = body False (tl ts)
 							  = returnE (ts, "Missing select assignment operator")
 		>>=	\(t, ts) = case hd ts of
 				TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
-							  = returnE (ts, "Missing close parenthesis")
+							  = returnE (ts, "Missing close parenthesis3")
 
 arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
 			incLevel ts
 		>>= \ts = addTupleCons cons
 		>>= \_ = args ts
 		>>= \(as, ts) = case hd ts of
-				TSelectAssignmentOp = body (tl ts)
+				TCaseAssignmentOp = body False (tl ts)
 							  = returnE (ts, "Missing select assignment operator")
 		>>=	\(t, ts) = case hd ts of
 				TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
-							  = returnE (ts, "Missing close parenthesis")
+							  = returnE (ts, "Missing close parenthesis4")
 		>>= decLevel
 where
 	mbCons as = if (cons=="_") PDefault (PCons cons as)
 
 arg_pattern ts = returnS (Nothing, ts)
 
-arg_adv [TOpenParenthesis:ts] = 
-				body ts >>= \(t, ts) = returnS (Just t, ts)
-			>>=	\(t, ts) = case hd ts of
-						TCloseParenthesis = returnS (t, tl ts)
-										  = returnE (ts, "Missing close parenthesis")
-		
-arg_adv ts = factor ts
-
 args ts = args_ ts []
 where
 	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as] 
@@ -258,7 +262,7 @@ func ts = returnE (ts, "Not a function or type definition")
 
 typed_caf name type ts =
 				getLevel
-			>>= \level = body ts
+			>>= \level = body False ts
 			>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)
 
 typed_fun name type ts =
@@ -268,7 +272,7 @@ typed_fun name type ts =
 					TAssignmentOp	   = returnS (True, tl ts)
 					TMacroAssignmentOp = returnS (False, tl ts)					
 									   = returnE (ts, "Missing assignment operator")
-			>>= \(func, ts) = body ts 
+			>>= \(func, ts) = body False ts 
 			>>= \(t, ts) = if func 
 							(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
 							(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))
@@ -297,7 +301,7 @@ where
 parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm,ParserState)		
 parseExpr pts 
 	# ts = map (\(PosToken _ _ t) = t) pts
-	= case (body ts) defaultState of
+	= 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)
 where

src/Sapl/SaplStruct.dcl

@@ -17,11 +17,10 @@ import Data.Maybe
 
 :: SaplTerm = SLit Literal
 			| SVar SaplVar
-			| SApplication SaplVar [SaplTerm]
-			| SIf SaplTerm SaplTerm SaplTerm
-			| SSelector SaplTerm
-			| SSelect SaplTerm [(SaplPattern, SaplTerm)]
+			| SApplication SaplTerm [SaplTerm]
+			| SCase SaplTerm [(SaplPattern, SaplTerm)]
 			| SLet SaplTerm [SaplLetDef]
+			| SSelect SaplTerm Int
 			| SAbortBody			
 
 :: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm
@@ -67,6 +66,7 @@ instance unpackVar SaplVar
 instance unpackVar SaplTypedVar
 
 unpackBindVar  :: !SaplLetDef -> SaplTypedVar
+unpackBindExpr :: !SaplLetDef -> SaplTerm
 unpackConsName :: !SaplPattern -> Maybe String
 toStrictBind   :: !SaplLetDef -> SaplLetDef
 

src/Sapl/SaplStruct.icl

@@ -86,6 +86,9 @@ where
 unpackBindVar :: !SaplLetDef -> SaplTypedVar
 unpackBindVar (SaplLetDef typedVar _) = typedVar
 
+unpackBindExpr :: !SaplLetDef -> SaplTerm
+unpackBindExpr (SaplLetDef _ expr) = expr
+
 unpackConsName :: !SaplPattern -> Maybe String
 unpackConsName (PCons cons _) = Just cons
 unpackConsName _ = Nothing

src/Sapl/SaplTokenizer.dcl

@@ -10,7 +10,7 @@ import StdString, Text.Unicode
 	     | TComment String 
 	     | TInlineAnnotation	     
 	     | TAssignmentOp
-	     | TSelectAssignmentOp
+	     | TCaseAssignmentOp
 	     | TMacroAssignmentOp
 	     | TCAFAssignmentOp	     
      	 | TLambda
@@ -22,8 +22,8 @@ import StdString, Text.Unicode
  		 | TCloseBracket
  		 | TTypeDef
 		 | TLit Literal
-		 | TSelectKeyword
-		 | TIfKeyword
+		 | TCaseKeyword
+		 | TSelectKeyword		 
 		 | TLetKeyword
 		 | TInKeyword
 		 | TEndOfLine

src/Sapl/SaplTokenizer.icl

@@ -101,7 +101,7 @@ read_token base line
 	| matchAt ":==" line start
 		= rnoarg TMacroAssignmentOp 3
 	| matchAt "->" line start
-		= rnoarg TSelectAssignmentOp 2		
+		= rnoarg TCaseAssignmentOp 2		
 	| matchCharAt '\\' line start 
 		= rnoarg TLambda 1
 	| matchCharAt ',' line start 
@@ -136,8 +136,8 @@ read_token base line
 			"false"  = return (TLit (LBool False), stop)
 			"True"   = return (TLit (LBool True), stop)
 			"true"   = return (TLit (LBool True), stop)
+			"case"   = return (TCaseKeyword, stop)
 			"select" = return (TSelectKeyword, stop)
-			"if"     = return (TIfKeyword, stop)
 			"let"	 = return (TLetKeyword, stop)
 			"in"	 = return (TInKeyword, stop)
 			str		 = if (str.[0] == '!') 
@@ -225,8 +225,8 @@ where
 	toString TCloseBracket = "}"
 	toString TTypeDef = "::"
 	toString (TLit lit) = toString lit
+	toString TCaseKeyword = "case"
 	toString TSelectKeyword = "select"
-	toString TIfKeyword = "if"
 	toString TLetKeyword = "let"
 	toString TInKeyword = "in"
 	toString TEndOfLine = "\n"

src/Sapl/Target/JS/Lifting.dcl

+definition module Sapl.Target.JS.Lifting
+
+import Sapl.SaplStruct
+
+// Returns True if a term can be inlined, i.e. no separate statement is needed
+inline :: !SaplTerm -> Bool
+
+prepareFun  :: !FuncType -> FuncType
+prepareExpr :: !SaplTerm -> SaplTerm
+
+

src/Sapl/Target/JS/Lifting.icl

+implementation module Sapl.Target.JS.Lifting
+
+import StdEnv
+import Sapl.SaplStruct
+
+inline :: !SaplTerm -> Bool
+inline (SLet _ _) = 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, [])
+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
+	= 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])
+where
+  genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {varidx = varidx + 1})
+*/
+
+walkTerm (SApplication name args) st
+	# (args, st, defs) = walkArgs args st
+	= (SApplication name args, st, 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

@@ -3,13 +3,18 @@ implementation module Sapl.Transform.AddSelectors
 import Sapl.SaplStruct
 import StdBool, StdList
 
+// do not do that for embedded "case"s, fall back may be screwed up
+
 instance addSelectors SaplTerm where
   addSelectors (SApplication v ts) = SApplication v (map addSelectors ts)
-  addSelectors (SIf c t e)  = SIf (addSelectors c) (addSelectors t) (addSelectors e)
-  addSelectors st=:(SSelect t ps=:[(PCons _ vs, SVar x)])
-    # t` = addSelectors t
-    | foldr (\v acc -> acc || eqVarByName v x) False vs = SSelector (SSelect t` ps)
-    | otherwise                                         = SSelect t` ps
+
+  addSelectors st=:(SCase t ps=:[(PCons _ 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
+    | otherwise                                         
+    	= SCase t ps
+    
   addSelectors (SLet t lds) = SLet (addSelectors t) (map addSelectors lds)
   addSelectors st = st
 

src/Sapl/Transform/Let.icl

@@ -19,7 +19,9 @@ 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 (SApplication f as) = foldl (gen vs bv) s [SVar f:as]
+	gen vs bv s (SSelect expr idx) = gen vs bv s expr
+	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) 
 		| 'Data.Set'.member v vs && v <> bv  = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
 	gen _ _ s _ = s