git.iko.soy/elk
on 5d8dfd9 help sign in
elk/src/Generate/JavaScript/Expression.hs
520 lines 15 kB history raw
1module Generate.JavaScript.Expression (generateDef) where
3import Control.Arrow (first, second, (***))
4import Control.Monad.State (State, forM, foldM)
5import qualified Data.List as List
6import qualified Data.Map as Map
7import Language.ECMAScript3.Syntax
9import qualified AST.Expression.General as Expr
10import AST.Expression.Optimized as Opt
11import qualified AST.Literal as L
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Variable as Var
14import Generate.JavaScript.Helpers as Help
15import qualified Generate.JavaScript.BuiltIn as BuiltIn
16import qualified Generate.JavaScript.Literal as Literal
17import qualified Generate.JavaScript.Port as Port
18import qualified Generate.JavaScript.Variable as Var
19import qualified Optimize.Patterns.DecisionTree as DT
22-- CODE CHUNKS
24data Code
25 = JsExpr (Expression ())
26 | JsBlock [Statement ()]
29jsExpr :: Expression () -> State Int Code
30jsExpr exp =
31 return (JsExpr exp)
34jsBlock :: [Statement ()] -> State Int Code
35jsBlock exp =
36 return (JsBlock exp)
39isBlock :: Code -> Bool
40isBlock code =
41 case code of
42 JsBlock _ -> True
43 JsExpr _ -> False
46toStatementList :: Code -> [Statement ()]
47toStatementList code =
48 case code of
49 JsExpr expr ->
50 [ ReturnStmt () (Just expr) ]
52 JsBlock stmts ->
53 stmts
56toStatement :: Code -> Statement ()
57toStatement code =
58 case code of
59 JsExpr expr ->
60 ReturnStmt () (Just expr)
62 JsBlock [stmt] ->
63 stmt
65 JsBlock stmts ->
66 BlockStmt () stmts
69toExpr :: Code -> Expression ()
70toExpr code =
71 case code of
72 JsExpr expr ->
73 expr
75 JsBlock stmts ->
76 function [] stmts `call` []
79-- DEFINITIONS
81generateDef :: Opt.Def -> State Int (Statement ())
82generateDef def =
83 do (home, name, jsBody) <-
84 case def of
85 Opt.TailDef (Opt.Facts home _) name argNames body ->
86 (,,) home name <$> generateTailFunction name argNames body
88 Opt.Def (Opt.Facts home _) name body ->
89 (,,) home name <$> generateJsExpr body
91 return (Var.define name jsBody)
94-- EXPRESSIONS
96generateJsExpr :: Opt.Expr -> State Int (Expression ())
97generateJsExpr optExpr =
98 toExpr <$> generateCode optExpr
101generateCode :: Opt.Expr -> State Int Code
102generateCode expr =
103 case expr of
104 Var var ->
105 jsExpr $ Var.canonical var
107 Literal lit ->
108 jsExpr (Literal.literal lit)
110 Range lo hi ->
111 do lo' <- generateJsExpr lo
112 hi' <- generateJsExpr hi
113 jsExpr $ BuiltIn.range lo' hi'
115 Access record field ->
116 do record' <- generateJsExpr record
117 jsExpr $ DotRef () record' (var (Var.safe field))
119 Update record fields ->
120 let
121 fieldToJs (field, value) =
122 do jsValue <- generateJsExpr value
123 return (Var.safe field, jsValue)
124 in
125 do jsRecord <- generateJsExpr record
126 jsFields <- mapM fieldToJs fields
127 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
129 Record fields ->
130 let
131 toField (field, value) =
132 do jsValue <- generateJsExpr value
133 return (prop (Var.safe field), jsValue)
134 in
135 do jsFields <- mapM toField fields
136 jsExpr $ ObjectLit () jsFields
138 Binop op leftExpr rightExpr ->
139 binop op leftExpr rightExpr
141 Function args body ->
142 generateFunction args body
144 Call func args ->
145 let
146 arity = length args
147 aN = "A" ++ show arity
148 in
149 do jsFunc <- generateJsExpr func
150 jsArgs <- mapM generateJsExpr args
151 jsExpr $
152 if 2 <= arity && arity <= 9 then
153 ref aN `call` (jsFunc:jsArgs)
154 else
155 foldl1 (<|) (jsFunc:jsArgs)
157 TailCall name argNames args ->
158 let
159 reassign name tempName =
160 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
161 in
162 do args' <- mapM generateJsExpr args
163 tempNames <- mapM (\_ -> Var.fresh) args
164 jsBlock $
165 VarDeclStmt () (zipWith varDecl tempNames args')
166 : zipWith reassign argNames tempNames
167 ++ [ContinueStmt () (Just (Id () name))]
169 Let defs body ->
170 do stmts <- mapM generateDef defs
171 code <- generateCode body
172 jsBlock (stmts ++ toStatementList code)
174 If branches finally ->
175 generateIf branches finally
177 Case root decisionTree branches ->
178 JsBlock <$> generateCase root decisionTree branches
180 ExplicitList elements ->
181 do jsElements <- mapM generateJsExpr elements
182 jsExpr $ BuiltIn.list jsElements
184 Data tag members ->
185 do jsMembers <- mapM generateJsExpr members
186 jsExpr $ ObjectLit () (ctor : fields jsMembers)
187 where
188 ctor = (prop "ctor", StringLit () tag)
189 fields =
190 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
192 DataAccess dataExpr index ->
193 do jsDataExpr <- generateJsExpr dataExpr
194 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
196 GLShader _uid src _tipe ->
197 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
199 Port impl ->
200 case impl of
201 Expr.In name portType ->
202 jsExpr (Port.inbound name portType)
204 Expr.Out name expr portType ->
205 do expr' <- generateJsExpr expr
206 jsExpr (Port.outbound name expr' portType)
208 Expr.Task name expr portType ->
209 do expr' <- generateJsExpr expr
210 jsExpr (Port.task name expr' portType)
212 Crash region maybeCaseCrashValue ->
213 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
216-- FUNCTIONS
218generateFunction :: [String] -> Opt.Expr -> State Int Code
219generateFunction args body =
220 do code <- generateCode body
221 jsExpr (generateFunctionWithArity args code)
224generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
225generateTailFunction name args body =
226 do code <- generateCode body
227 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
228 LabelledStmt ()
229 (Id () name)
230 (WhileStmt () (BoolLit () True) (toStatement code))
233generateFunctionWithArity :: [String] -> Code -> Expression ()
234generateFunctionWithArity rawArgs code =
235 let
236 args = map Var.safe rawArgs
237 arity = length args
238 in
239 if 2 <= arity && arity <= 9 then
240 let
241 fN = "F" ++ show arity
242 in
243 ref fN <| function args (toStatementList code)
244 else
245 let
246 (lastArg:otherArgs) = reverse args
247 innerBody = function [lastArg] (toStatementList code)
248 in
249 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
252-- GENERATE IFS
254generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
255generateIf givenBranches givenFinally =
256 let
257 (branches, finally) =
258 crushIfs givenBranches givenFinally
260 convertBranch (condition, expr) =
261 (,) <$> generateJsExpr condition <*> generateCode expr
263 ifExpression (condition, branch) otherwise =
264 CondExpr () condition branch otherwise
266 ifStatement (condition, branch) otherwise =
267 IfStmt () condition branch otherwise
268 in
269 do jsBranches <- mapM convertBranch branches
270 jsFinally <- generateCode finally
272 if any isBlock (jsFinally : map snd jsBranches)
273 then
274 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
275 else
276 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
279crushIfs
280 :: [(Opt.Expr, Opt.Expr)]
281 -> Opt.Expr
282 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
283crushIfs branches finally =
284 crushIfsHelp [] branches finally
287crushIfsHelp
288 :: [(Opt.Expr, Opt.Expr)]
289 -> [(Opt.Expr, Opt.Expr)]
290 -> Opt.Expr
291 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
292crushIfsHelp visitedBranches unvisitedBranches finally =
293 case unvisitedBranches of
294 [] ->
295 case finally of
296 If subBranches subFinally ->
297 crushIfsHelp visitedBranches subBranches subFinally
299 _ ->
300 (reverse visitedBranches, finally)
302 (Literal (L.Boolean True), branch) : _ ->
303 crushIfsHelp visitedBranches [] branch
305 visiting : unvisited ->
306 crushIfsHelp (visiting : visitedBranches) unvisited finally
309-- CASE EXPRESSIONS
311generateCase
312 :: String
313 -> DT.DecisionTree Opt.Jump
314 -> [(Int, Opt.Branch)]
315 -> State Int [Statement ()]
316generateCase root decisionTree jumpBranches =
317 do decider <- generateDecisionTree root decisionTree
318 foldM (goto root) decider jumpBranches
321goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
322goto root decider (target, branch) =
323 let
324 deciderStmt =
325 LabelledStmt ()
326 (targetLabel root target)
327 (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
328 in
329 do stmts <- generateBranch root branch
330 return (deciderStmt : stmts)
333targetLabel :: String -> Int -> Id ()
334targetLabel root target =
335 Id () (root ++ "_" ++ show target)
338generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
339generateDecisionTree root decisionTree =
340 case decisionTree of
341 DT.Match (Opt.Inline branch) ->
342 generateBranch root branch
344 DT.Match (Opt.Jump target) ->
345 return [ BreakStmt () (Just (targetLabel root target)) ]
347 DT.Decision testPath [(test, subTree)] (Just fallback) ->
348 let
349 (tests, deepestSubTree) =
350 collapseTests [(testPath, test)] fallback subTree
352 makeTest (path, test) =
353 do testExpr <- pathToTestableExpr root path test
354 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
355 in
356 do testExprs <- mapM makeTest tests
357 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
358 thenBranch <- generateDecisionTree root deepestSubTree
359 elseBranch <- generateDecisionTree root fallback
360 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
362 DT.Decision testPath edges fallback ->
363 do testExpr <- pathToTestableExpr root testPath (fst (head edges))
364 caseClauses <- mapM (edgeToCaseClause root) edges
365 caseDefault <- fallbackToDefault root fallback
366 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
369collapseTests
370 :: [(DT.Path, DT.Test)]
371 -> DT.DecisionTree Opt.Jump
372 -> DT.DecisionTree Opt.Jump
373 -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
374collapseTests tests outerFallback decisionTree =
375 case decisionTree of
376 DT.Decision testPath [(test, subTree)] (Just fallback)
377 | fallback == outerFallback ->
378 collapseTests ((testPath, test) : tests) outerFallback subTree
380 _ ->
381 (tests, decisionTree)
384edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
385edgeToCaseClause root (test, subTree) =
386 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
389pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
390pathToTestableExpr root path exampleTest =
391 do accessExpr <- generateJsExpr (pathToExpr root path)
392 case exampleTest of
393 DT.Constructor _ ->
394 return (DotRef () accessExpr (Id () "ctor"))
396 DT.Literal _ ->
397 return accessExpr
400testToExpr :: DT.Test -> Expression ()
401testToExpr test =
402 case test of
403 DT.Constructor (Var.Canonical _ tag) ->
404 StringLit () tag
406 DT.Literal (L.Chr char) ->
407 StringLit () [char]
409 DT.Literal lit ->
410 Literal.literal lit
413fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
414fallbackToDefault root fallback =
415 case fallback of
416 Nothing ->
417 return []
419 Just subTree ->
420 do stmts <- generateDecisionTree root subTree
421 return [ CaseDefault () stmts ]
424generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
425generateBranch root (Opt.Branch substitutions expr) =
426 do substs <- mapM (loadPath root) substitutions
427 let substStmts =
428 if null substs then [] else [ VarDeclStmt () substs ]
429 code <- generateCode expr
430 return (substStmts ++ toStatementList code)
433loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
434loadPath root (name, path) =
435 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
436 return $ varDecl (Var.safe name) jsAccessExpr
439pathToExpr :: String -> DT.Path -> Opt.Expr
440pathToExpr root fullPath =
441 go (Opt.Var (Var.local root)) fullPath
442 where
443 go expr path =
444 case path of
445 DT.Position index subpath ->
446 go (Opt.DataAccess expr index) subpath
448 DT.Field field subpath ->
449 go (Opt.Access expr field) subpath
451 DT.Empty ->
452 expr
454 DT.Alias ->
455 expr
458-- BINARY OPERATORS
460binop
461 :: Var.Canonical
462 -> Opt.Expr
463 -> Opt.Expr
464 -> State Int Code
465binop func left right =
466 do jsLeft <- generateJsExpr left
467 jsRight <- generateJsExpr right
468 jsExpr (makeExpr func jsLeft jsRight)
471-- BINARY OPERATOR HELPERS
473makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
474makeExpr qualifiedOp@(Var.Canonical home op) =
475 let
476 simpleMake left right =
477 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
478 in
479 if home == Var.Module (ModuleName.inCore ["Basics"]) then
480 Map.findWithDefault simpleMake op basicOps
481 else
482 simpleMake
485basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
486basicOps =
487 Map.fromList (infixOps ++ specialOps)
490infixOps :: [(String, Expression () -> Expression () -> Expression ())]
491infixOps =
492 let
493 infixOp str op =
494 (str, InfixExpr () op)
495 in
496 [ infixOp "+" OpAdd
497 , infixOp "-" OpSub
498 , infixOp "*" OpMul
499 , infixOp "/" OpDiv
500 , infixOp "&&" OpLAnd
501 , infixOp "||" OpLOr
502 ]
505specialOps :: [(String, Expression () -> Expression () -> Expression ())]
506specialOps =
507 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
508 , (,) "==" $ \a b -> BuiltIn.eq a b
509 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
510 , (,) "<" $ cmp OpLT 0
511 , (,) ">" $ cmp OpGT 0
512 , (,) "<=" $ cmp OpLT 1
513 , (,) ">=" $ cmp OpGT (-1)
514 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
515 ]
518cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
519cmp op n a b =
520 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)