git.iko.soy/elk
on master help sign in
Break JS generation of expressions and defs into a separate file
40a7c45Evan Czaplicki
src/Generate/JavaScript.hs+3−525
compare with master
unifiedsplit
@@ -1,26 +1,13 @@
1module Generate.JavaScript (generate) where
1module Generate.JavaScript (generate) where
2
2
3−import Control.Applicative ((<$>),(<*>))
4−import Control.Arrow (first, second, (***))
5import Control.Monad.State as State
3import Control.Monad.State as State
6−import qualified Data.List as List
7−import qualified Data.Map as Map
8import Language.ECMAScript3.PrettyPrint as ES
4import Language.ECMAScript3.PrettyPrint as ES
9import Language.ECMAScript3.Syntax
5import Language.ECMAScript3.Syntax
10import qualified Text.PrettyPrint.Leijen as PP
6import qualified Text.PrettyPrint.Leijen as PP
11
7
12−import qualified AST.Expression.General as Expr
13−import AST.Expression.Optimized as Opt
14−import qualified AST.Literal as L
15import qualified AST.Module as Module
8import qualified AST.Module as Module
16−import qualified AST.Module.Name as ModuleName
17−import qualified AST.Variable as Var
18−import Generate.JavaScript.Helpers as Help
9+import qualified Generate.JavaScript.Expression as JS
19−import qualified Generate.JavaScript.BuiltIn as BuiltIn
20−import qualified Generate.JavaScript.Literal as Literal
21−import qualified Generate.JavaScript.Port as Port
22import qualified Generate.JavaScript.Variable as Var
10import qualified Generate.JavaScript.Variable as Var
23−import qualified Optimize.Patterns.DecisionTree as DT
24
11
25
12
26generate :: Module.Optimized -> String
13generate :: Module.Optimized -> String
@@ -33,515 +20,6 @@ generate module_ =
33 Var.define "_op" (ObjectLit () [])
20 Var.define "_op" (ObjectLit () [])
34
21
35 stmts =
22 stmts =
36− State.evalState (mapM generateDef definitions) 0
23+ State.evalState (mapM JS.generateDef definitions) 0
37 in
24 in
38− PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint (setup:stmts))) ""
25+ PP.displayS (PP.renderPretty 0.4 160 (ES.prettyPrint (setup:stmts))) ""
39−
40−
41−-- CODE CHUNKS
42−
43−data Code
44− = JsExpr (Expression ())
45− | JsBlock [Statement ()]
46−
47−
48−jsExpr :: Expression () -> State Int Code
49−jsExpr exp =
50− return (JsExpr exp)
51−
52−
53−jsBlock :: [Statement ()] -> State Int Code
54−jsBlock exp =
55− return (JsBlock exp)
56−
57−
58−isBlock :: Code -> Bool
59−isBlock code =
60− case code of
61− JsBlock _ -> True
62− JsExpr _ -> False
63−
64−
65−toStatementList :: Code -> [Statement ()]
66−toStatementList code =
67− case code of
68− JsExpr expr ->
69− [ ret expr ]
70− JsBlock stmts ->
71− stmts
72−
73−
74−toStatement :: Code -> Statement ()
75−toStatement code =
76− case code of
77− JsExpr expr ->
78− ret expr
79− JsBlock [stmt] ->
80− stmt
81− JsBlock stmts ->
82− BlockStmt () stmts
83−
84−
85−toExpr :: Code -> Expression ()
86−toExpr code =
87− case code of
88− JsExpr expr ->
89− expr
90−
91− JsBlock stmts ->
92− function [] stmts `call` []
93−
94−
95−-- DEFINITIONS
96−
97−generateDef :: Opt.Def -> State Int (Statement ())
98−generateDef def =
99− do (home, name, jsBody) <-
100− case def of
101− Opt.TailDef (Opt.Facts home _) name argNames body ->
102− (,,) home name <$> generateTailFunction name argNames body
103−
104− Opt.Def (Opt.Facts home _) name body ->
105− (,,) home name <$> generateJsExpr body
106−
107− return (Var.define name jsBody)
108−
109−
110−-- EXPRESSIONS
111−
112−generateJsExpr :: Opt.Expr -> State Int (Expression ())
113−generateJsExpr optExpr =
114− toExpr <$> generateCode optExpr
115−
116−
117−generateCode :: Opt.Expr -> State Int Code
118−generateCode expr =
119− case expr of
120− Var var ->
121− jsExpr $ Var.canonical var
122−
123− Literal lit ->
124− jsExpr (Literal.literal lit)
125−
126− Range lo hi ->
127− do lo' <- generateJsExpr lo
128− hi' <- generateJsExpr hi
129− jsExpr $ BuiltIn.range lo' hi'
130−
131− Access record field ->
132− do record' <- generateJsExpr record
133− jsExpr $ DotRef () record' (var (Var.safe field))
134−
135− Update record fields ->
136− let
137− fieldToJs (field, value) =
138− do jsValue <- generateJsExpr value
139− return (Var.safe field, jsValue)
140− in
141− do jsRecord <- generateJsExpr record
142− jsFields <- mapM fieldToJs fields
143− jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
144−
145− Record fields ->
146− do fields' <-
147− forM fields $ \(field, e) ->
148− (,) (Var.safe field) <$> generateJsExpr e
149−
150− let fieldMap =
151− List.foldl' combine Map.empty fields'
152−
153− jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
154− where
155− combine record (field, value) =
156− Map.insertWith (++) field [value] record
157−
158− hidden fs =
159− ObjectLit () . map (prop *** ArrayLit ()) $
160− Map.toList (Map.filter (not . null) (Map.map tail fs))
161−
162− visible fs =
163− map (first prop) (Map.toList (Map.map head fs))
164−
165− Binop op leftExpr rightExpr ->
166− binop op leftExpr rightExpr
167−
168− Function args body ->
169− generateFunction args body
170−
171− Call func args ->
172− let
173− arity = length args
174− aN = "A" ++ show arity
175− in
176− do jsFunc <- generateJsExpr func
177− jsArgs <- mapM generateJsExpr args
178− jsExpr $
179− if 2 <= arity && arity <= 9 then
180− ref aN `call` (jsFunc:jsArgs)
181− else
182− foldl1 (<|) (jsFunc:jsArgs)
183−
184− TailCall name argNames args ->
185− let
186− reassign name tempName =
187− ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
188− in
189− do args' <- mapM generateJsExpr args
190− tempNames <- mapM (\_ -> Var.fresh) args
191− jsBlock $
192− VarDeclStmt () (zipWith varDecl tempNames args')
193− : zipWith reassign argNames tempNames
194− ++ [ContinueStmt () (Just (Id () name))]
195−
196− Let defs body ->
197− do stmts <- mapM generateDef defs
198− code <- generateCode body
199− jsBlock (stmts ++ toStatementList code)
200−
201− If branches finally ->
202− generateIf branches finally
203−
204− Case root decisionTree branches ->
205− JsBlock <$> generateCase root decisionTree branches
206−
207− ExplicitList elements ->
208− do jsElements <- mapM generateJsExpr elements
209− jsExpr $ BuiltIn.list jsElements
210−
211− Data tag members ->
212− do jsMembers <- mapM generateJsExpr members
213− jsExpr $ ObjectLit () (ctor : fields jsMembers)
214− where
215− ctor = (prop "ctor", string tag)
216− fields =
217− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
218−
219− DataAccess dataExpr index ->
220− do jsDataExpr <- generateJsExpr dataExpr
221− jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
222−
223− GLShader _uid src _tipe ->
224− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
225−
226− Port impl ->
227− case impl of
228− Expr.In name portType ->
229− jsExpr (Port.inbound name portType)
230−
231− Expr.Out name expr portType ->
232− do expr' <- generateJsExpr expr
233− jsExpr (Port.outbound name expr' portType)
234−
235− Expr.Task name expr portType ->
236− do expr' <- generateJsExpr expr
237− jsExpr (Port.task name expr' portType)
238−
239− Crash region maybeCaseCrashValue ->
240− jsExpr $ BuiltIn.crash region maybeCaseCrashValue
241−
242−
243−-- FUNCTIONS
244−
245−generateFunction :: [String] -> Opt.Expr -> State Int Code
246−generateFunction args body =
247− do code <- generateCode body
248− jsExpr (generateFunctionWithArity args code)
249−
250−
251−generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
252−generateTailFunction name args body =
253− do code <- generateCode body
254− return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
255− LabelledStmt ()
256− (Id () name)
257− (WhileStmt () (BoolLit () True) (toStatement code))
258−
259−
260−generateFunctionWithArity :: [String] -> Code -> Expression ()
261−generateFunctionWithArity rawArgs code =
262− let
263− args = map Var.safe rawArgs
264− arity = length args
265− in
266− if 2 <= arity && arity <= 9 then
267− let
268− fN = "F" ++ show arity
269− in
270− ref fN <| function args (toStatementList code)
271− else
272− let
273− (lastArg:otherArgs) = reverse args
274− innerBody = function [lastArg] (toStatementList code)
275− in
276− foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
277−
278−
279−-- GENERATE IFS
280−
281−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
282−generateIf givenBranches givenFinally =
283− let
284− (branches, finally) =
285− crushIfs givenBranches givenFinally
286−
287− convertBranch (condition, expr) =
288− (,) <$> generateJsExpr condition <*> generateCode expr
289−
290− ifExpression (condition, branch) otherwise =
291− CondExpr () condition branch otherwise
292−
293− ifStatement (condition, branch) otherwise =
294− IfStmt () condition branch otherwise
295− in
296− do jsBranches <- mapM convertBranch branches
297− jsFinally <- generateCode finally
298−
299− if any isBlock (jsFinally : map snd jsBranches)
300− then
301− jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
302− else
303− jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
304−
305−
306−crushIfs
307− :: [(Opt.Expr, Opt.Expr)]
308− -> Opt.Expr
309− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
310−crushIfs branches finally =
311− crushIfsHelp [] branches finally
312−
313−
314−crushIfsHelp
315− :: [(Opt.Expr, Opt.Expr)]
316− -> [(Opt.Expr, Opt.Expr)]
317− -> Opt.Expr
318− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
319−crushIfsHelp visitedBranches unvisitedBranches finally =
320− case unvisitedBranches of
321− [] ->
322− case finally of
323− If subBranches subFinally ->
324− crushIfsHelp visitedBranches subBranches subFinally
325−
326− _ ->
327− (reverse visitedBranches, finally)
328−
329− (Literal (L.Boolean True), branch) : _ ->
330− crushIfsHelp visitedBranches [] branch
331−
332− visiting : unvisited ->
333− crushIfsHelp (visiting : visitedBranches) unvisited finally
334−
335−
336−-- CASE EXPRESSIONS
337−
338−generateCase
339− :: String
340− -> DT.DecisionTree Opt.Jump
341− -> [(Int, Opt.Branch)]
342− -> State Int [Statement ()]
343−generateCase root decisionTree jumpBranches =
344− do decider <- generateDecisionTree root decisionTree
345− foldM (goto root) decider jumpBranches
346−
347−
348−goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
349−goto root decider (target, branch) =
350− let
351− deciderStmt =
352− LabelledStmt ()
353− (targetLabel root target)
354− (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
355− in
356− do stmts <- generateBranch root branch
357− return (deciderStmt : stmts)
358−
359−
360−targetLabel :: String -> Int -> Id ()
361−targetLabel root target =
362− Id () (root ++ "_" ++ show target)
363−
364−
365−generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
366−generateDecisionTree root decisionTree =
367− case decisionTree of
368− DT.Match (Opt.Inline branch) ->
369− generateBranch root branch
370−
371− DT.Match (Opt.Jump target) ->
372− return [ BreakStmt () (Just (targetLabel root target)) ]
373−
374− DT.Decision testPath [(test, subTree)] (Just fallback) ->
375− let
376− (tests, deepestSubTree) =
377− collapseTests [(testPath, test)] fallback subTree
378−
379− makeTest (path, test) =
380− do testExpr <- pathToTestableExpr root path test
381− return (InfixExpr () OpStrictEq testExpr (testToExpr test))
382− in
383− do testExprs <- mapM makeTest tests
384− let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
385− thenBranch <- generateDecisionTree root deepestSubTree
386− elseBranch <- generateDecisionTree root fallback
387− return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
388−
389− DT.Decision testPath edges fallback ->
390− do testExpr <- pathToTestableExpr root testPath (fst (head edges))
391− caseClauses <- mapM (edgeToCaseClause root) edges
392− caseDefault <- fallbackToDefault root fallback
393− return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
394−
395−
396−collapseTests
397− :: [(DT.Path, DT.Test)]
398− -> DT.DecisionTree Opt.Jump
399− -> DT.DecisionTree Opt.Jump
400− -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
401−collapseTests tests outerFallback decisionTree =
402− case decisionTree of
403− DT.Decision testPath [(test, subTree)] (Just fallback)
404− | fallback == outerFallback ->
405− collapseTests ((testPath, test) : tests) outerFallback subTree
406−
407− _ ->
408− (tests, decisionTree)
409−
410−
411−edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
412−edgeToCaseClause root (test, subTree) =
413− CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
414−
415−
416−pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
417−pathToTestableExpr root path exampleTest =
418− do accessExpr <- generateJsExpr (pathToExpr root path)
419− case exampleTest of
420− DT.Constructor _ ->
421− return (DotRef () accessExpr (Id () "ctor"))
422−
423− DT.Literal _ ->
424− return accessExpr
425−
426−
427−testToExpr :: DT.Test -> Expression ()
428−testToExpr test =
429− case test of
430− DT.Constructor (Var.Canonical _ tag) ->
431− StringLit () tag
432−
433− DT.Literal (L.Chr char) ->
434− StringLit () [char]
435−
436− DT.Literal lit ->
437− Literal.literal lit
438−
439−
440−fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
441−fallbackToDefault root fallback =
442− case fallback of
443− Nothing ->
444− return []
445−
446− Just subTree ->
447− do stmts <- generateDecisionTree root subTree
448− return [ CaseDefault () stmts ]
449−
450−
451−generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
452−generateBranch root (Opt.Branch substitutions expr) =
453− do substs <- mapM (loadPath root) substitutions
454− let substStmts =
455− if null substs then [] else [ VarDeclStmt () substs ]
456− code <- generateCode expr
457− return (substStmts ++ toStatementList code)
458−
459−
460−loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
461−loadPath root (name, path) =
462− do jsAccessExpr <- generateJsExpr (pathToExpr root path)
463− return $ varDecl (Var.safe name) jsAccessExpr
464−
465−
466−pathToExpr :: String -> DT.Path -> Opt.Expr
467−pathToExpr root fullPath =
468− go (Opt.Var (Var.local root)) fullPath
469− where
470− go expr path =
471− case path of
472− DT.Position index subpath ->
473− go (Opt.DataAccess expr index) subpath
474−
475− DT.Field field subpath ->
476− go (Opt.Access expr field) subpath
477−
478− DT.Empty ->
479− expr
480−
481− DT.Alias ->
482− expr
483−
484−
485−-- BINARY OPERATORS
486−
487−binop
488− :: Var.Canonical
489− -> Opt.Expr
490− -> Opt.Expr
491− -> State Int Code
492−binop func left right =
493− do jsLeft <- generateJsExpr left
494− jsRight <- generateJsExpr right
495− jsExpr (makeExpr func jsLeft jsRight)
496−
497−
498−-- BINARY OPERATOR HELPERS
499−
500−makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
501−makeExpr qualifiedOp@(Var.Canonical home op) =
502− let
503− simpleMake left right =
504− ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
505− in
506− if home == Var.Module (ModuleName.inCore ["Basics"]) then
507− Map.findWithDefault simpleMake op basicOps
508− else
509− simpleMake
510−
511−
512−basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
513−basicOps =
514− Map.fromList (infixOps ++ specialOps)
515−
516−
517−infixOps :: [(String, Expression () -> Expression () -> Expression ())]
518−infixOps =
519− let
520− infixOp str op =
521− (str, InfixExpr () op)
522− in
523− [ infixOp "+" OpAdd
524− , infixOp "-" OpSub
525− , infixOp "*" OpMul
526− , infixOp "/" OpDiv
527− , infixOp "&&" OpLAnd
528− , infixOp "||" OpLOr
529− ]
530−
531−
532−specialOps :: [(String, Expression () -> Expression () -> Expression ())]
533−specialOps =
534− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
535− , (,) "==" $ \a b -> BuiltIn.eq a b
536− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
537− , (,) "<" $ cmp OpLT 0
538− , (,) ">" $ cmp OpGT 0
539− , (,) "<=" $ cmp OpLT 1
540− , (,) ">=" $ cmp OpGT (-1)
541− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
542− ]
543−
544−
545−cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
546−cmp op n a b =
547− InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
src/Generate/JavaScript/Expression.hsnew file+528
@@ -0,0 +1,528 @@
1+module Generate.JavaScript.Expression (generateDef) where
2+
3+import Control.Arrow (first, second, (***))
4+import Control.Monad.State (State, forM, foldM)
5+import qualified Data.List as List
6+import qualified Data.Map as Map
7+import Language.ECMAScript3.Syntax
8+
9+import qualified AST.Expression.General as Expr
10+import AST.Expression.Optimized as Opt
11+import qualified AST.Literal as L
12+import qualified AST.Module.Name as ModuleName
13+import qualified AST.Variable as Var
14+import Generate.JavaScript.Helpers as Help
15+import qualified Generate.JavaScript.BuiltIn as BuiltIn
16+import qualified Generate.JavaScript.Literal as Literal
17+import qualified Generate.JavaScript.Port as Port
18+import qualified Generate.JavaScript.Variable as Var
19+import qualified Optimize.Patterns.DecisionTree as DT
20+
21+
22+-- CODE CHUNKS
23+
24+data Code
25+ = JsExpr (Expression ())
26+ | JsBlock [Statement ()]
27+
28+
29+jsExpr :: Expression () -> State Int Code
30+jsExpr exp =
31+ return (JsExpr exp)
32+
33+
34+jsBlock :: [Statement ()] -> State Int Code
35+jsBlock exp =
36+ return (JsBlock exp)
37+
38+
39+isBlock :: Code -> Bool
40+isBlock code =
41+ case code of
42+ JsBlock _ -> True
43+ JsExpr _ -> False
44+
45+
46+toStatementList :: Code -> [Statement ()]
47+toStatementList code =
48+ case code of
49+ JsExpr expr ->
50+ [ ret expr ]
51+ JsBlock stmts ->
52+ stmts
53+
54+
55+toStatement :: Code -> Statement ()
56+toStatement code =
57+ case code of
58+ JsExpr expr ->
59+ ret expr
60+ JsBlock [stmt] ->
61+ stmt
62+ JsBlock stmts ->
63+ BlockStmt () stmts
64+
65+
66+toExpr :: Code -> Expression ()
67+toExpr code =
68+ case code of
69+ JsExpr expr ->
70+ expr
71+
72+ JsBlock stmts ->
73+ function [] stmts `call` []
74+
75+
76+-- DEFINITIONS
77+
78+generateDef :: Opt.Def -> State Int (Statement ())
79+generateDef def =
80+ do (home, name, jsBody) <-
81+ case def of
82+ Opt.TailDef (Opt.Facts home _) name argNames body ->
83+ (,,) home name <$> generateTailFunction name argNames body
84+
85+ Opt.Def (Opt.Facts home _) name body ->
86+ (,,) home name <$> generateJsExpr body
87+
88+ return (Var.define name jsBody)
89+
90+
91+-- EXPRESSIONS
92+
93+generateJsExpr :: Opt.Expr -> State Int (Expression ())
94+generateJsExpr optExpr =
95+ toExpr <$> generateCode optExpr
96+
97+
98+generateCode :: Opt.Expr -> State Int Code
99+generateCode expr =
100+ case expr of
101+ Var var ->
102+ jsExpr $ Var.canonical var
103+
104+ Literal lit ->
105+ jsExpr (Literal.literal lit)
106+
107+ Range lo hi ->
108+ do lo' <- generateJsExpr lo
109+ hi' <- generateJsExpr hi
110+ jsExpr $ BuiltIn.range lo' hi'
111+
112+ Access record field ->
113+ do record' <- generateJsExpr record
114+ jsExpr $ DotRef () record' (var (Var.safe field))
115+
116+ Update record fields ->
117+ let
118+ fieldToJs (field, value) =
119+ do jsValue <- generateJsExpr value
120+ return (Var.safe field, jsValue)
121+ in
122+ do jsRecord <- generateJsExpr record
123+ jsFields <- mapM fieldToJs fields
124+ jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
125+
126+ Record fields ->
127+ do fields' <-
128+ forM fields $ \(field, e) ->
129+ (,) (Var.safe field) <$> generateJsExpr e
130+
131+ let fieldMap =
132+ List.foldl' combine Map.empty fields'
133+
134+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
135+ where
136+ combine record (field, value) =
137+ Map.insertWith (++) field [value] record
138+
139+ hidden fs =
140+ ObjectLit () . map (prop *** ArrayLit ()) $
141+ Map.toList (Map.filter (not . null) (Map.map tail fs))
142+
143+ visible fs =
144+ map (first prop) (Map.toList (Map.map head fs))
145+
146+ Binop op leftExpr rightExpr ->
147+ binop op leftExpr rightExpr
148+
149+ Function args body ->
150+ generateFunction args body
151+
152+ Call func args ->
153+ let
154+ arity = length args
155+ aN = "A" ++ show arity
156+ in
157+ do jsFunc <- generateJsExpr func
158+ jsArgs <- mapM generateJsExpr args
159+ jsExpr $
160+ if 2 <= arity && arity <= 9 then
161+ ref aN `call` (jsFunc:jsArgs)
162+ else
163+ foldl1 (<|) (jsFunc:jsArgs)
164+
165+ TailCall name argNames args ->
166+ let
167+ reassign name tempName =
168+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
169+ in
170+ do args' <- mapM generateJsExpr args
171+ tempNames <- mapM (\_ -> Var.fresh) args
172+ jsBlock $
173+ VarDeclStmt () (zipWith varDecl tempNames args')
174+ : zipWith reassign argNames tempNames
175+ ++ [ContinueStmt () (Just (Id () name))]
176+
177+ Let defs body ->
178+ do stmts <- mapM generateDef defs
179+ code <- generateCode body
180+ jsBlock (stmts ++ toStatementList code)
181+
182+ If branches finally ->
183+ generateIf branches finally
184+
185+ Case root decisionTree branches ->
186+ JsBlock <$> generateCase root decisionTree branches
187+
188+ ExplicitList elements ->
189+ do jsElements <- mapM generateJsExpr elements
190+ jsExpr $ BuiltIn.list jsElements
191+
192+ Data tag members ->
193+ do jsMembers <- mapM generateJsExpr members
194+ jsExpr $ ObjectLit () (ctor : fields jsMembers)
195+ where
196+ ctor = (prop "ctor", string tag)
197+ fields =
198+ zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
199+
200+ DataAccess dataExpr index ->
201+ do jsDataExpr <- generateJsExpr dataExpr
202+ jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
203+
204+ GLShader _uid src _tipe ->
205+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
206+
207+ Port impl ->
208+ case impl of
209+ Expr.In name portType ->
210+ jsExpr (Port.inbound name portType)
211+
212+ Expr.Out name expr portType ->
213+ do expr' <- generateJsExpr expr
214+ jsExpr (Port.outbound name expr' portType)
215+
216+ Expr.Task name expr portType ->
217+ do expr' <- generateJsExpr expr
218+ jsExpr (Port.task name expr' portType)
219+
220+ Crash region maybeCaseCrashValue ->
221+ jsExpr $ BuiltIn.crash region maybeCaseCrashValue
222+
223+
224+-- FUNCTIONS
225+
226+generateFunction :: [String] -> Opt.Expr -> State Int Code
227+generateFunction args body =
228+ do code <- generateCode body
229+ jsExpr (generateFunctionWithArity args code)
230+
231+
232+generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
233+generateTailFunction name args body =
234+ do code <- generateCode body
235+ return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
236+ LabelledStmt ()
237+ (Id () name)
238+ (WhileStmt () (BoolLit () True) (toStatement code))
239+
240+
241+generateFunctionWithArity :: [String] -> Code -> Expression ()
242+generateFunctionWithArity rawArgs code =
243+ let
244+ args = map Var.safe rawArgs
245+ arity = length args
246+ in
247+ if 2 <= arity && arity <= 9 then
248+ let
249+ fN = "F" ++ show arity
250+ in
251+ ref fN <| function args (toStatementList code)
252+ else
253+ let
254+ (lastArg:otherArgs) = reverse args
255+ innerBody = function [lastArg] (toStatementList code)
256+ in
257+ foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
258+
259+
260+-- GENERATE IFS
261+
262+generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
263+generateIf givenBranches givenFinally =
264+ let
265+ (branches, finally) =
266+ crushIfs givenBranches givenFinally
267+
268+ convertBranch (condition, expr) =
269+ (,) <$> generateJsExpr condition <*> generateCode expr
270+
271+ ifExpression (condition, branch) otherwise =
272+ CondExpr () condition branch otherwise
273+
274+ ifStatement (condition, branch) otherwise =
275+ IfStmt () condition branch otherwise
276+ in
277+ do jsBranches <- mapM convertBranch branches
278+ jsFinally <- generateCode finally
279+
280+ if any isBlock (jsFinally : map snd jsBranches)
281+ then
282+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
283+ else
284+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
285+
286+
287+crushIfs
288+ :: [(Opt.Expr, Opt.Expr)]
289+ -> Opt.Expr
290+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
291+crushIfs branches finally =
292+ crushIfsHelp [] branches finally
293+
294+
295+crushIfsHelp
296+ :: [(Opt.Expr, Opt.Expr)]
297+ -> [(Opt.Expr, Opt.Expr)]
298+ -> Opt.Expr
299+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
300+crushIfsHelp visitedBranches unvisitedBranches finally =
301+ case unvisitedBranches of
302+ [] ->
303+ case finally of
304+ If subBranches subFinally ->
305+ crushIfsHelp visitedBranches subBranches subFinally
306+
307+ _ ->
308+ (reverse visitedBranches, finally)
309+
310+ (Literal (L.Boolean True), branch) : _ ->
311+ crushIfsHelp visitedBranches [] branch
312+
313+ visiting : unvisited ->
314+ crushIfsHelp (visiting : visitedBranches) unvisited finally
315+
316+
317+-- CASE EXPRESSIONS
318+
319+generateCase
320+ :: String
321+ -> DT.DecisionTree Opt.Jump
322+ -> [(Int, Opt.Branch)]
323+ -> State Int [Statement ()]
324+generateCase root decisionTree jumpBranches =
325+ do decider <- generateDecisionTree root decisionTree
326+ foldM (goto root) decider jumpBranches
327+
328+
329+goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
330+goto root decider (target, branch) =
331+ let
332+ deciderStmt =
333+ LabelledStmt ()
334+ (targetLabel root target)
335+ (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
336+ in
337+ do stmts <- generateBranch root branch
338+ return (deciderStmt : stmts)
339+
340+
341+targetLabel :: String -> Int -> Id ()
342+targetLabel root target =
343+ Id () (root ++ "_" ++ show target)
344+
345+
346+generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
347+generateDecisionTree root decisionTree =
348+ case decisionTree of
349+ DT.Match (Opt.Inline branch) ->
350+ generateBranch root branch
351+
352+ DT.Match (Opt.Jump target) ->
353+ return [ BreakStmt () (Just (targetLabel root target)) ]
354+
355+ DT.Decision testPath [(test, subTree)] (Just fallback) ->
356+ let
357+ (tests, deepestSubTree) =
358+ collapseTests [(testPath, test)] fallback subTree
359+
360+ makeTest (path, test) =
361+ do testExpr <- pathToTestableExpr root path test
362+ return (InfixExpr () OpStrictEq testExpr (testToExpr test))
363+ in
364+ do testExprs <- mapM makeTest tests
365+ let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
366+ thenBranch <- generateDecisionTree root deepestSubTree
367+ elseBranch <- generateDecisionTree root fallback
368+ return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
369+
370+ DT.Decision testPath edges fallback ->
371+ do testExpr <- pathToTestableExpr root testPath (fst (head edges))
372+ caseClauses <- mapM (edgeToCaseClause root) edges
373+ caseDefault <- fallbackToDefault root fallback
374+ return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
375+
376+
377+collapseTests
378+ :: [(DT.Path, DT.Test)]
379+ -> DT.DecisionTree Opt.Jump
380+ -> DT.DecisionTree Opt.Jump
381+ -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
382+collapseTests tests outerFallback decisionTree =
383+ case decisionTree of
384+ DT.Decision testPath [(test, subTree)] (Just fallback)
385+ | fallback == outerFallback ->
386+ collapseTests ((testPath, test) : tests) outerFallback subTree
387+
388+ _ ->
389+ (tests, decisionTree)
390+
391+
392+edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
393+edgeToCaseClause root (test, subTree) =
394+ CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
395+
396+
397+pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
398+pathToTestableExpr root path exampleTest =
399+ do accessExpr <- generateJsExpr (pathToExpr root path)
400+ case exampleTest of
401+ DT.Constructor _ ->
402+ return (DotRef () accessExpr (Id () "ctor"))
403+
404+ DT.Literal _ ->
405+ return accessExpr
406+
407+
408+testToExpr :: DT.Test -> Expression ()
409+testToExpr test =
410+ case test of
411+ DT.Constructor (Var.Canonical _ tag) ->
412+ StringLit () tag
413+
414+ DT.Literal (L.Chr char) ->
415+ StringLit () [char]
416+
417+ DT.Literal lit ->
418+ Literal.literal lit
419+
420+
421+fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
422+fallbackToDefault root fallback =
423+ case fallback of
424+ Nothing ->
425+ return []
426+
427+ Just subTree ->
428+ do stmts <- generateDecisionTree root subTree
429+ return [ CaseDefault () stmts ]
430+
431+
432+generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
433+generateBranch root (Opt.Branch substitutions expr) =
434+ do substs <- mapM (loadPath root) substitutions
435+ let substStmts =
436+ if null substs then [] else [ VarDeclStmt () substs ]
437+ code <- generateCode expr
438+ return (substStmts ++ toStatementList code)
439+
440+
441+loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
442+loadPath root (name, path) =
443+ do jsAccessExpr <- generateJsExpr (pathToExpr root path)
444+ return $ varDecl (Var.safe name) jsAccessExpr
445+
446+
447+pathToExpr :: String -> DT.Path -> Opt.Expr
448+pathToExpr root fullPath =
449+ go (Opt.Var (Var.local root)) fullPath
450+ where
451+ go expr path =
452+ case path of
453+ DT.Position index subpath ->
454+ go (Opt.DataAccess expr index) subpath
455+
456+ DT.Field field subpath ->
457+ go (Opt.Access expr field) subpath
458+
459+ DT.Empty ->
460+ expr
461+
462+ DT.Alias ->
463+ expr
464+
465+
466+-- BINARY OPERATORS
467+
468+binop
469+ :: Var.Canonical
470+ -> Opt.Expr
471+ -> Opt.Expr
472+ -> State Int Code
473+binop func left right =
474+ do jsLeft <- generateJsExpr left
475+ jsRight <- generateJsExpr right
476+ jsExpr (makeExpr func jsLeft jsRight)
477+
478+
479+-- BINARY OPERATOR HELPERS
480+
481+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
482+makeExpr qualifiedOp@(Var.Canonical home op) =
483+ let
484+ simpleMake left right =
485+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
486+ in
487+ if home == Var.Module (ModuleName.inCore ["Basics"]) then
488+ Map.findWithDefault simpleMake op basicOps
489+ else
490+ simpleMake
491+
492+
493+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
494+basicOps =
495+ Map.fromList (infixOps ++ specialOps)
496+
497+
498+infixOps :: [(String, Expression () -> Expression () -> Expression ())]
499+infixOps =
500+ let
501+ infixOp str op =
502+ (str, InfixExpr () op)
503+ in
504+ [ infixOp "+" OpAdd
505+ , infixOp "-" OpSub
506+ , infixOp "*" OpMul
507+ , infixOp "/" OpDiv
508+ , infixOp "&&" OpLAnd
509+ , infixOp "||" OpLOr
510+ ]
511+
512+
513+specialOps :: [(String, Expression () -> Expression () -> Expression ())]
514+specialOps =
515+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
516+ , (,) "==" $ \a b -> BuiltIn.eq a b
517+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
518+ , (,) "<" $ cmp OpLT 0
519+ , (,) ">" $ cmp OpGT 0
520+ , (,) "<=" $ cmp OpLT 1
521+ , (,) ">=" $ cmp OpGT (-1)
522+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
523+ ]
524+
525+
526+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
527+cmp op n a b =
528+ InfixExpr () op (BuiltIn.compare a b) (IntLit () n)