git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Yet more work on replacing SYB
bf47876Phil Freeman
src/Language/PureScript/CodeGen/JS.hs+1−1
compare with golang
unifiedsplit
@@ -249,7 +249,7 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
249bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
249bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
250bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
250bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
251 valNames <- replicateM (length vals) fresh
251 valNames <- replicateM (length vals) fresh
252− jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
252+ jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd
253 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
253 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
254 vals
254 vals
255 where
255 where
src/Language/PureScript/CodeGen/JS/AST.hs+82
@@ -233,3 +233,85 @@ data JS
233 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
233 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
234 --
234 --
235 | JSRaw String deriving (Show, Eq, Data, Typeable)
235 | JSRaw String deriving (Show, Eq, Data, Typeable)
236+
237+--
238+-- Traversals
239+--
240+
241+everywhereOnJS :: (JS -> JS) -> JS -> JS
242+everywhereOnJS f = go
243+ where
244+ go :: JS -> JS
245+ go (JSUnary op j) = f (JSUnary op (go j))
246+ go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
247+ go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
248+ go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
249+ go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
250+ go (JSAccessor prop j) = f (JSAccessor prop (go j))
251+ go (JSFunction name args j) = f (JSFunction name args (go j))
252+ go (JSApp j js) = f (JSApp (go j) (map go js))
253+ go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
254+ go (JSBlock js) = f (JSBlock (map go js))
255+ go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
256+ go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
257+ go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
258+ go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
259+ go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
260+ go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
261+ go (JSReturn js) = f (JSReturn (go js))
262+ go (JSThrow js) = f (JSThrow (go js))
263+ go (JSTypeOf js) = f (JSTypeOf (go js))
264+ go (JSLabel name js) = f (JSLabel name (go js))
265+ go other = f other
266+
267+everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
268+everywhereOnJSTopDown f = go . f
269+ where
270+ go :: JS -> JS
271+ go (JSUnary op j) = JSUnary op (go (f j))
272+ go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
273+ go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
274+ go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
275+ go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
276+ go (JSAccessor prop j) = JSAccessor prop (go (f j))
277+ go (JSFunction name args j) = JSFunction name args (go (f j))
278+ go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
279+ go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
280+ go (JSBlock js) = JSBlock (map (go . f) js)
281+ go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
282+ go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
283+ go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
284+ go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
285+ go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
286+ go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
287+ go (JSReturn j) = JSReturn (go (f j))
288+ go (JSThrow j) = JSThrow (go (f j))
289+ go (JSTypeOf j) = JSTypeOf (go (f j))
290+ go (JSLabel name j) = JSLabel name (go (f j))
291+ go other = f other
292+
293+everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
294+everythingOnJS (<>) f = go
295+ where
296+ go j@(JSUnary _ j1) = f j <> go j1
297+ go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
298+ go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
299+ go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
300+ go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
301+ go j@(JSAccessor _ j1) = f j <> go j1
302+ go j@(JSFunction _ _ j1) = f j <> go j1
303+ go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
304+ go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
305+ go j@(JSBlock js) = foldl (<>) (f j) (map go js)
306+ go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
307+ go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
308+ go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
309+ go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
310+ go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
311+ go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
312+ go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
313+ go j@(JSReturn j1) = f j <> go j1
314+ go j@(JSThrow j1) = f j <> go j1
315+ go j@(JSTypeOf j1) = f j <> go j1
316+ go j@(JSLabel _ j1) = f j <> go j1
317+ go other = f other
src/Language/PureScript/Declarations.hs+10−6
@@ -24,7 +24,6 @@ import Language.PureScript.CodeGen.JS.AST
24import Language.PureScript.Environment
24import Language.PureScript.Environment
25
25
26import qualified Data.Data as D
26import qualified Data.Data as D
27−import Data.Generics (mkQ, everything)
28
27
29-- |
28-- |
30-- A precedence level for an infix operator
29-- A precedence level for an infix operator
@@ -441,12 +440,17 @@ data Binder
441-- |
440-- |
442-- Collect all names introduced in binders in an expression
441-- Collect all names introduced in binders in an expression
443--
442--
444−binderNames :: (D.Data d) => d -> [Ident]
443+binderNames :: Binder -> [Ident]
445−binderNames = everything (++) (mkQ [] go)
444+binderNames = go []
446 where
445 where
447− go (VarBinder ident) = [ident]
446+ go ns (VarBinder name) = name : ns
447+ go ns (ConstructorBinder _ bs) = foldl go ns bs
448+ go ns (ObjectBinder bs) = foldl go ns (map snd bs)
449+ go ns (ArrayBinder bs) = foldl go ns bs
450+ go ns (ConsBinder b1 b2) = go (go ns b1) b2
448− go (NamedBinder ident _) = [ident]
451+ go ns (NamedBinder name b) = go (name : ns) b
452+ go ns (PositionedBinder _ b) = go ns b
449− go _ = []
453+ go ns _ = ns
450
454
451--
455--
452-- Traversals
456-- Traversals
src/Language/PureScript/Optimizer/Blocks.hs+1−3
@@ -17,15 +17,13 @@ module Language.PureScript.Optimizer.Blocks (
17 collapseNestedBlocks
17 collapseNestedBlocks
18) where
18) where
19
19
20−import Data.Generics
21−
22import Language.PureScript.CodeGen.JS.AST
20import Language.PureScript.CodeGen.JS.AST
23
21
24-- |
22-- |
25-- Collapse blocks which appear nested directly below another block
23-- Collapse blocks which appear nested directly below another block
26--
24--
27collapseNestedBlocks :: JS -> JS
25collapseNestedBlocks :: JS -> JS
28−collapseNestedBlocks = everywhere (mkT collapse)
26+collapseNestedBlocks = everywhereOnJS collapse
29 where
27 where
30 collapse :: JS -> JS
28 collapse :: JS -> JS
31 collapse (JSBlock sts) = JSBlock (concatMap go sts)
29 collapse (JSBlock sts) = JSBlock (concatMap go sts)
src/Language/PureScript/Optimizer/Common.hs+12−13
@@ -16,27 +16,26 @@
16module Language.PureScript.Optimizer.Common where
16module Language.PureScript.Optimizer.Common where
17
17
18import Data.Maybe (fromMaybe)
18import Data.Maybe (fromMaybe)
19−import Data.Generics
20
19
21import Language.PureScript.CodeGen.JS.AST
20import Language.PureScript.CodeGen.JS.AST
22
21
23applyAll :: [a -> a] -> a -> a
22applyAll :: [a -> a] -> a -> a
24applyAll = foldl1 (.)
23applyAll = foldl1 (.)
25
24
26−replaceIdent :: (Data d) => String -> JS -> d -> d
25+replaceIdent :: String -> JS -> JS -> JS
27−replaceIdent var1 js = everywhere (mkT replace)
26+replaceIdent var1 js = everywhereOnJS replace
28 where
27 where
29 replace (JSVar var2) | var1 == var2 = js
28 replace (JSVar var2) | var1 == var2 = js
30 replace other = other
29 replace other = other
31
30
32−replaceIdents :: (Data d) => [(String, JS)] -> d -> d
31+replaceIdents :: [(String, JS)] -> JS -> JS
33−replaceIdents vars = everywhere (mkT replace)
32+replaceIdents vars = everywhereOnJS replace
34 where
33 where
35 replace v@(JSVar var) = fromMaybe v $ lookup var vars
34 replace v@(JSVar var) = fromMaybe v $ lookup var vars
36 replace other = other
35 replace other = other
37
36
38−isReassigned :: (Data d) => String -> d -> Bool
37+isReassigned :: String -> JS -> Bool
39−isReassigned var1 = everything (||) (mkQ False check)
38+isReassigned var1 = everythingOnJS (||) check
40 where
39 where
41 check :: JS -> Bool
40 check :: JS -> Bool
42 check (JSFunction _ args _) | var1 `elem` args = True
41 check (JSFunction _ args _) | var1 `elem` args = True
@@ -46,14 +45,14 @@ isReassigned var1 = everything (||) (mkQ False check)
46 check (JSForIn arg _ _) | var1 == arg = True
45 check (JSForIn arg _ _) | var1 == arg = True
47 check _ = False
46 check _ = False
48
47
49−isRebound :: (Data d) => JS -> d -> Bool
48+isRebound :: JS -> JS -> Bool
50−isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) (mkQ [] variablesOf) js)
49+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
51 where
50 where
52 variablesOf (JSVar var) = [var]
51 variablesOf (JSVar var) = [var]
53 variablesOf _ = []
52 variablesOf _ = []
54
53
55−isUsed :: (Data d) => String -> d -> Bool
54+isUsed :: String -> JS -> Bool
56−isUsed var1 = everything (||) (mkQ False check)
55+isUsed var1 = everythingOnJS (||) check
57 where
56 where
58 check :: JS -> Bool
57 check :: JS -> Bool
59 check (JSVar var2) | var1 == var2 = True
58 check (JSVar var2) | var1 == var2 = True
@@ -66,8 +65,8 @@ targetVariable (JSAccessor _ tgt) = targetVariable tgt
66targetVariable (JSIndexer _ tgt) = targetVariable tgt
65targetVariable (JSIndexer _ tgt) = targetVariable tgt
67targetVariable _ = error "Invalid argument to targetVariable"
66targetVariable _ = error "Invalid argument to targetVariable"
68
67
69−isUpdated :: (Data d) => String -> d -> Bool
68+isUpdated :: String -> JS -> Bool
70−isUpdated var1 = everything (||) (mkQ False check)
69+isUpdated var1 = everythingOnJS (||) check
71 where
70 where
72 check :: JS -> Bool
71 check :: JS -> Bool
73 check (JSAssignment target _) | var1 == targetVariable target = True
72 check (JSAssignment target _) | var1 == targetVariable target = True
src/Language/PureScript/Optimizer/Inliner.hs+11−13
@@ -22,8 +22,6 @@ module Language.PureScript.Optimizer.Inliner (
22 evaluateIifes
22 evaluateIifes
23) where
23) where
24
24
25−import Data.Generics
26−
27import Language.PureScript.CodeGen.JS.AST
25import Language.PureScript.CodeGen.JS.AST
28import Language.PureScript.CodeGen.Common (identToJs)
26import Language.PureScript.CodeGen.Common (identToJs)
29import Language.PureScript.Optimizer.Common
27import Language.PureScript.Optimizer.Common
@@ -41,42 +39,42 @@ shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
41shouldInline _ = False
39shouldInline _ = False
42
40
43etaConvert :: JS -> JS
41etaConvert :: JS -> JS
44−etaConvert = everywhere (mkT convert)
42+etaConvert = everywhereOnJS convert
45 where
43 where
46 convert :: JS -> JS
44 convert :: JS -> JS
47 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
45 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
48 | all shouldInline args &&
46 | all shouldInline args &&
49 not (any (`isRebound` block) (map JSVar idents)) &&
47 not (any (`isRebound` block) (map JSVar idents)) &&
50 not (any (`isRebound` block) args)
48 not (any (`isRebound` block) args)
51− = JSBlock (replaceIdents (zip idents args) body)
49+ = JSBlock (map (replaceIdents (zip idents args)) body)
52 convert js = js
50 convert js = js
53
51
54unThunk :: JS -> JS
52unThunk :: JS -> JS
55−unThunk = everywhere (mkT convert)
53+unThunk = everywhereOnJS convert
56 where
54 where
57 convert :: JS -> JS
55 convert :: JS -> JS
58 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
56 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
59 convert js = js
57 convert js = js
60
58
61evaluateIifes :: JS -> JS
59evaluateIifes :: JS -> JS
62−evaluateIifes = everywhere (mkT convert)
60+evaluateIifes = everywhereOnJS convert
63 where
61 where
64 convert :: JS -> JS
62 convert :: JS -> JS
65 convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
63 convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
66 convert js = js
64 convert js = js
67
65
68inlineVariables :: JS -> JS
66inlineVariables :: JS -> JS
69−inlineVariables = everywhere (mkT $ removeFromBlock go)
67+inlineVariables = everywhereOnJS $ removeFromBlock go
70 where
68 where
71 go :: [JS] -> [JS]
69 go :: [JS] -> [JS]
72 go [] = []
70 go [] = []
73 go (JSVariableIntroduction var (Just js) : sts)
71 go (JSVariableIntroduction var (Just js) : sts)
74− | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
72+ | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
75− go (replaceIdent var js sts)
73+ go (map (replaceIdent var js) sts)
76 go (s:sts) = s : go sts
74 go (s:sts) = s : go sts
77
75
78inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
76inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
79−inlineOperator (m, op) f = everywhere (mkT convert)
77+inlineOperator (m, op) f = everywhereOnJS convert
80 where
78 where
81 convert :: JS -> JS
79 convert :: JS -> JS
82 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
80 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
@@ -122,7 +120,7 @@ inlineCommonOperators = applyAll
122 ]
120 ]
123 where
121 where
124 binary :: String -> String -> BinaryOperator -> JS -> JS
122 binary :: String -> String -> BinaryOperator -> JS -> JS
125− binary dictName opString op = everywhere (mkT convert)
123+ binary dictName opString op = everywhereOnJS convert
126 where
124 where
127 convert :: JS -> JS
125 convert :: JS -> JS
128 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
126 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
@@ -131,7 +129,7 @@ inlineCommonOperators = applyAll
131 isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
129 isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
132 isOp _ = False
130 isOp _ = False
133 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
131 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
134− binaryFunction dictName fnName op = everywhere (mkT convert)
132+ binaryFunction dictName fnName op = everywhereOnJS convert
135 where
133 where
136 convert :: JS -> JS
134 convert :: JS -> JS
137 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
135 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
@@ -139,7 +137,7 @@ inlineCommonOperators = applyAll
139 isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
137 isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
140 isOp _ = False
138 isOp _ = False
141 unary :: String -> String -> UnaryOperator -> JS -> JS
139 unary :: String -> String -> UnaryOperator -> JS -> JS
142− unary dictName fnName op = everywhere (mkT convert)
140+ unary dictName fnName op = everywhereOnJS convert
143 where
141 where
144 convert :: JS -> JS
142 convert :: JS -> JS
145 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
143 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
src/Language/PureScript/Optimizer/MagicDo.hs+6−7
@@ -20,7 +20,6 @@ module Language.PureScript.Optimizer.MagicDo (
20
20
21import Data.List (nub)
21import Data.List (nub)
22import Data.Maybe (fromJust, isJust)
22import Data.Maybe (fromJust, isJust)
23−import Data.Generics
24
23
25import Language.PureScript.Options
24import Language.PureScript.Options
26import Language.PureScript.CodeGen.JS.AST
25import Language.PureScript.CodeGen.JS.AST
@@ -50,7 +49,7 @@ magicDo opts | optionsNoMagicDo opts = id
50-- }
49-- }
51--
50--
52magicDo' :: JS -> JS
51magicDo' :: JS -> JS
53−magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
52+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
54 where
53 where
55 -- The name of the function block which is added to denote a do block
54 -- The name of the function block which is added to denote a do block
56 fnName = "__do"
55 fnName = "__do"
@@ -106,7 +105,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
106-- Inline functions in the ST module
105-- Inline functions in the ST module
107--
106--
108inlineST :: JS -> JS
107inlineST :: JS -> JS
109−inlineST = everywhere (mkT convertBlock)
108+inlineST = everywhereOnJS convertBlock
110 where
109 where
111 -- Look for runST blocks and inline the STRefs there.
110 -- Look for runST blocks and inline the STRefs there.
112 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
111 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
@@ -116,7 +115,7 @@ inlineST = everywhere (mkT convertBlock)
116 usages = findAllSTUsagesIn arg
115 usages = findAllSTUsagesIn arg
117 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
116 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
118 localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
117 localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
119− in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
118+ in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
120 convertBlock other = other
119 convertBlock other = other
121 -- Convert a block in a safe way, preserving object wrappers of references,
120 -- Convert a block in a safe way, preserving object wrappers of references,
122 -- or in a more aggressive way, turning wrappers into local variables depending on the
121 -- or in a more aggressive way, turning wrappers into local variables depending on the
@@ -138,18 +137,18 @@ inlineST = everywhere (mkT convertBlock)
138 isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
137 isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
139 isSTFunc _ _ = False
138 isSTFunc _ _ = False
140 -- Find all ST Refs initialized in this block
139 -- Find all ST Refs initialized in this block
141− findSTRefsIn = everything (++) (mkQ [] isSTRef)
140+ findSTRefsIn = everythingOnJS (++) isSTRef
142 where
141 where
143 isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
142 isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
144 isSTRef _ = []
143 isSTRef _ = []
145 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
144 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
146− findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
145+ findAllSTUsagesIn = everythingOnJS (++) isSTUsage
147 where
146 where
148 isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
147 isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
149 isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
148 isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
150 isSTUsage _ = []
149 isSTUsage _ = []
151 -- Find all uses of a variable
150 -- Find all uses of a variable
152− appearingIn ref = everything (++) (mkQ [] isVar)
151+ appearingIn ref = everythingOnJS (++) isVar
153 where
152 where
154 isVar e@(JSVar v) | v == ref = [e]
153 isVar e@(JSVar v) | v == ref = [e]
155 isVar _ = []
154 isVar _ = []
src/Language/PureScript/Optimizer/TCO.hs+6−8
@@ -15,8 +15,6 @@
15
15
16module Language.PureScript.Optimizer.TCO (tco) where
16module Language.PureScript.Optimizer.TCO (tco) where
17
17
18−import Data.Generics
19−
20import Language.PureScript.Options
18import Language.PureScript.Options
21import Language.PureScript.CodeGen.JS.AST
19import Language.PureScript.CodeGen.JS.AST
22
20
@@ -28,7 +26,7 @@ tco opts | optionsNoTco opts = id
28 | otherwise = tco'
26 | otherwise = tco'
29
27
30tco' :: JS -> JS
28tco' :: JS -> JS
31−tco' = everywhere (mkT convert)
29+tco' = everywhereOnJS convert
32 where
30 where
33 tcoLabel :: String
31 tcoLabel :: String
34 tcoLabel = "tco"
32 tcoLabel = "tco"
@@ -61,9 +59,9 @@ tco' = everywhere (mkT convert)
61 isTailCall :: String -> JS -> Bool
59 isTailCall :: String -> JS -> Bool
62 isTailCall ident js =
60 isTailCall ident js =
63 let
61 let
64− numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
62+ numSelfCalls = everythingOnJS (+) countSelfCalls js
65− numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
63+ numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
66− numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
64+ numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
67 in
65 in
68 numSelfCalls > 0
66 numSelfCalls > 0
69 && numSelfCalls == numSelfCallsInTailPosition
67 && numSelfCalls == numSelfCallsInTailPosition
@@ -75,12 +73,12 @@ tco' = everywhere (mkT convert)
75 countSelfCallsInTailPosition :: JS -> Int
73 countSelfCallsInTailPosition :: JS -> Int
76 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
74 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
77 countSelfCallsInTailPosition _ = 0
75 countSelfCallsInTailPosition _ = 0
78− countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
76+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
79 countSelfCallsUnderFunctions _ = 0
77 countSelfCallsUnderFunctions _ = 0
80 toLoop :: String -> [String] -> JS -> JS
78 toLoop :: String -> [String] -> JS -> JS
81 toLoop ident allArgs js = JSBlock $
79 toLoop ident allArgs js = JSBlock $
82 map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
80 map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
83− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
81+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
84 where
82 where
85 loopify :: JS -> JS
83 loopify :: JS -> JS
86 loopify (JSReturn ret) | isSelfCall ident ret =
84 loopify (JSReturn ret) | isSelfCall ident ret =
src/Language/PureScript/Optimizer/Unused.hs+3−5
@@ -18,23 +18,21 @@ module Language.PureScript.Optimizer.Unused (
18 removeCodeAfterReturnStatements
18 removeCodeAfterReturnStatements
19) where
19) where
20
20
21−import Data.Generics
22−
23import Language.PureScript.CodeGen.JS.AST
21import Language.PureScript.CodeGen.JS.AST
24import Language.PureScript.Optimizer.Common
22import Language.PureScript.Optimizer.Common
25
23
26removeUnusedVariables :: JS -> JS
24removeUnusedVariables :: JS -> JS
27−removeUnusedVariables = everywhere (mkT $ removeFromBlock withBlock)
25+removeUnusedVariables = everywhereOnJS (removeFromBlock withBlock)
28 where
26 where
29 withBlock :: [JS] -> [JS]
27 withBlock :: [JS] -> [JS]
30 withBlock sts = go sts sts
28 withBlock sts = go sts sts
31 go :: [JS] -> [JS] -> [JS]
29 go :: [JS] -> [JS] -> [JS]
32 go _ [] = []
30 go _ [] = []
33− go sts (JSVariableIntroduction var _ : rest) | not (isUsed var sts) = go sts rest
31+ go sts (JSVariableIntroduction var _ : rest) | not (any (isUsed var) sts) = go sts rest
34 go sts (s : rest) = s : go sts rest
32 go sts (s : rest) = s : go sts rest
35
33
36removeCodeAfterReturnStatements :: JS -> JS
34removeCodeAfterReturnStatements :: JS -> JS
37−removeCodeAfterReturnStatements = everywhere (mkT $ removeFromBlock go)
35+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
38 where
36 where
39 go :: [JS] -> [JS]
37 go :: [JS] -> [JS]
40 go jss | not (any isJSReturn jss) = jss
38 go jss | not (any isJSReturn jss) = jss
src/Language/PureScript/Sugar/Names.hs+1−1
@@ -215,7 +215,7 @@ renameInModule imports exports (Module mn decls exps) =
215 bindFunctionArgs pb other = return (pb, other)
215 bindFunctionArgs pb other = return (pb, other)
216
216
217 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
217 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
218− bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
218+ bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)
219
219
220 letBoundVariable :: Declaration -> Maybe Ident
220 letBoundVariable :: Declaration -> Maybe Ident
221 letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident
221 letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident