From a10a0f19c55f61a0a37fc82bd0bc93e9b1825303 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?L=C3=A1szl=C3=B3=20Domoszlai?= <dlacko@gmail.com>
Date: Thu, 20 Nov 2014 22:23:47 +0000
Subject: [PATCH] small optimization with selectors

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@622 cb785ff4-4565-4a15-8565-04c4fcf96d79
---
 src/Sapl/SaplStruct.dcl                |  1 +
 src/Sapl/Target/JS/CodeGeneratorJS.icl |  9 ++++++++-
 src/Sapl/Transform/AddSelectors.dcl    |  7 +++++++
 src/Sapl/Transform/AddSelectors.icl    | 17 +++++++++++++++++
 4 files changed, 33 insertions(+), 1 deletion(-)
 create mode 100644 src/Sapl/Transform/AddSelectors.dcl
 create mode 100644 src/Sapl/Transform/AddSelectors.icl

diff --git a/src/Sapl/SaplStruct.dcl b/src/Sapl/SaplStruct.dcl
index 59a79de..12885f9 100644
--- a/src/Sapl/SaplStruct.dcl
+++ b/src/Sapl/SaplStruct.dcl
@@ -19,6 +19,7 @@ import Data.Maybe
 			| SVar SaplVar
 			| SApplication SaplVar [SaplTerm]
 			| SIf SaplTerm SaplTerm SaplTerm
+			| SSelector SaplTerm
 			| SSelect SaplTerm [(SaplPattern, SaplTerm)]
 			| SLet SaplTerm [SaplLetDef]
 			| SAbortBody			
diff --git a/src/Sapl/Target/JS/CodeGeneratorJS.icl b/src/Sapl/Target/JS/CodeGeneratorJS.icl
index 25a7a92..1504fce 100644
--- a/src/Sapl/Target/JS/CodeGeneratorJS.icl
+++ b/src/Sapl/Target/JS/CodeGeneratorJS.icl
@@ -9,9 +9,11 @@ implementation module Sapl.Target.JS.CodeGeneratorJS
  */
 
 import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastString
+import qualified Data.List as DL
 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
 
@@ -110,7 +112,7 @@ isTailRecursive var (SLet body _) = isTailRecursive var body
 isTailRecursive _ _ = False
 
 funcCoder :: !FuncType !CoderState !StringAppender -> StringAppender
-funcCoder (FTFunc name body args) s a = normalFunc name body args s a
+funcCoder (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
@@ -579,6 +581,11 @@ where
 	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)
diff --git a/src/Sapl/Transform/AddSelectors.dcl b/src/Sapl/Transform/AddSelectors.dcl
new file mode 100644
index 0000000..634fe3b
--- /dev/null
+++ b/src/Sapl/Transform/AddSelectors.dcl
@@ -0,0 +1,7 @@
+definition module Sapl.Transform.AddSelectors
+
+from Sapl.SaplStruct import :: SaplTerm
+
+class addSelectors t :: !t -> t
+
+instance addSelectors SaplTerm
diff --git a/src/Sapl/Transform/AddSelectors.icl b/src/Sapl/Transform/AddSelectors.icl
new file mode 100644
index 0000000..950123f
--- /dev/null
+++ b/src/Sapl/Transform/AddSelectors.icl
@@ -0,0 +1,17 @@
+implementation module Sapl.Transform.AddSelectors
+
+import Sapl.SaplStruct
+import StdBool, StdList
+
+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 (SLet t lds) = SLet (addSelectors t) (map addSelectors lds)
+  addSelectors st = st
+
+instance addSelectors SaplLetDef where
+  addSelectors (SaplLetDef v t) = SaplLetDef v (addSelectors t)
-- 
GitLab