git.iko.soy/elk
on master help sign in
Reduce the number of unnecessary closures
e240f77Evan Czaplicki
src/Generate/JavaScript.hs+75−34
compare with master
unifiedsplit
@@ -5,12 +5,13 @@ import Control.Arrow (first,(***))
5import Control.Monad.State
5import Control.Monad.State
6import qualified Data.List as List
6import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
9import qualified Data.Set as Set
9import Language.ECMAScript3.PrettyPrint
10import Language.ECMAScript3.PrettyPrint
10import Language.ECMAScript3.Syntax
11import Language.ECMAScript3.Syntax
11
12
12import AST.Module
13import AST.Module
13−import AST.Expression.General
14+import AST.Expression.General as Expr
14import qualified AST.Expression.Canonical as Canonical
15import qualified AST.Expression.Canonical as Canonical
15import qualified AST.Helpers as Help
16import qualified AST.Helpers as Help
16import AST.Literal
17import AST.Literal
@@ -59,8 +60,10 @@ literal lit =
59 Boolean b -> BoolLit () b
60 Boolean b -> BoolLit () b
60
61
61
62
63+-- EXPRESSIONS
64+
62expression :: Canonical.Expr -> State Int (Expression ())
65expression :: Canonical.Expr -> State Int (Expression ())
63−expression (A.A region expr) =
66+expression annotatedExpr@(A.A region expr) =
64 case expr of
67 case expr of
65 Var var ->
68 Var var ->
66 return $ Var.canonical var
69 return $ Var.canonical var
@@ -118,33 +121,8 @@ expression (A.A region expr) =
118 Binop op e1 e2 ->
121 Binop op e1 e2 ->
119 binop region op e1 e2
122 binop region op e1 e2
120
123
121− Lambda pattern rawBody@(A.A ann _) ->
124+ Lambda _ _ ->
122− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
125+ generateFunction (Expr.collectLambdas annotatedExpr)
123− body' <- expression body
124− return $
125− case length args < 2 || length args > 9 of
126− True -> foldr (==>) body' (map (:[]) args)
127− False -> ref ("F" ++ show (length args)) <| (args ==> body')
128− where
129− depattern (args, body) pattern =
130− case pattern of
131− A.A _ (P.Var x) ->
132− return (args ++ [ Var.varName x ], body)
133−
134− _ ->
135− do arg <- Case.newVar
136− return
137− ( args ++ [arg]
138− , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
139− )
140−
141− (patterns, innerBody) =
142− collect [pattern] rawBody
143−
144− collect patterns lexpr@(A.A _ expr) =
145− case expr of
146− Lambda p e -> collect (p:patterns) e
147− _ -> (patterns, lexpr)
148
126
149 App e1 e2 ->
127 App e1 e2 ->
150 do func' <- expression func
128 do func' <- expression func
@@ -162,11 +140,10 @@ expression (A.A region expr) =
162 (A.A _ (App f arg)) -> getArgs f (arg : args)
140 (A.A _ (App f arg)) -> getArgs f (arg : args)
163 _ -> (func, args)
141 _ -> (func, args)
164
142
165− Let defs e ->
143+ Let defs body ->
166− do let (defs',e') = flattenLets defs e
144+ do (stmts, bodyExpr) <- generateLetPieces defs body
167− stmts <- concat <$> mapM definition defs'
168− exp <- expression e'
169− return $ function [] (stmts ++ [ ret exp ]) `call` []
145+ return $ function [] (stmts ++ [ ret bodyExpr ]) `call` []
146+
170
147
171 MultiIf branches ->
148 MultiIf branches ->
172 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
149 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
@@ -224,6 +201,70 @@ expression (A.A region expr) =
224 return (Port.task name expr' portType)
201 return (Port.task name expr' portType)
225
202
226
203
204+-- FUNCTIONS
205+
206+generateFunction
207+ :: ([P.CanonicalPattern], Canonical.Expr)
208+ -> State Int (Expression ())
209+generateFunction (args, initialBody) =
210+ do (argVars, patternDefs) <- destructuredArgs args
211+ (stmts, expr) <- generateLetPieces patternDefs initialBody
212+ return (generateFunctionWithArity argVars stmts expr)
213+
214+
215+generateFunctionWithArity :: [String] -> [Statement ()] -> Expression () -> Expression ()
216+generateFunctionWithArity args stmts expr =
217+ let
218+ arity = length args
219+ in
220+ if 2 <= arity && arity <= 9 then
221+ let
222+ fN = "F" ++ show arity
223+ in
224+ ref fN <| function args (stmts ++ [ret expr])
225+ else
226+ let
227+ (lastArg:otherArgs) = reverse args
228+ innerBody = function [lastArg] (stmts ++ [ret expr])
229+ in
230+ foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
231+
232+
233+destructuredArgs :: [P.CanonicalPattern] -> State Int ([String], [Canonical.Def])
234+destructuredArgs args =
235+ do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
236+ return (argVars, Maybe.catMaybes maybePatternDefs)
237+
238+
239+destructPattern :: P.CanonicalPattern -> State Int (String, Maybe Canonical.Def)
240+destructPattern pattern@(A.A ann pat) =
241+ case pat of
242+ P.Var x ->
243+ return (Var.varName x, Nothing)
244+
245+ _ ->
246+ do arg <- Case.newVar
247+ return
248+ ( arg
249+ , Just $ Canonical.Definition pattern (A.A ann (localVar arg)) Nothing
250+ )
251+
252+
253+-- LET EXPRESSIONS
254+
255+generateLetPieces
256+ :: [Canonical.Def]
257+ -> Canonical.Expr
258+ -> State Int ([Statement ()], Expression ())
259+generateLetPieces givenDefs givenBody =
260+ do let (defs, body) = flattenLets givenDefs givenBody
261+ stmts <- concat <$> mapM definition defs
262+ expr <- expression body
263+ return (stmts, expr)
264+
265+
266+-- DEFINITIONS
267+
227definition :: Canonical.Def -> State Int [Statement ()]
268definition :: Canonical.Def -> State Int [Statement ()]
228definition (Canonical.Definition annPattern expr@(A.A region _) _) =
269definition (Canonical.Definition annPattern expr@(A.A region _) _) =
229 do expr' <- expression expr
270 do expr' <- expression expr