git.iko.soy/elk
on 97552fd help sign in
elk/src/Generate/JavaScript/Expression.hs
531 lines 16 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 do fields' <-
131 forM fields $ \(field, e) ->
132 (,) (Var.safe field) <$> generateJsExpr e
134 let fieldMap =
135 List.foldl' combine Map.empty fields'
137 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
138 where
139 combine record (field, value) =
140 Map.insertWith (++) field [value] record
142 hidden fs =
143 ObjectLit () . map (prop *** ArrayLit ()) $
144 Map.toList (Map.filter (not . null) (Map.map tail fs))
146 visible fs =
147 map (first prop) (Map.toList (Map.map head fs))
149 Binop op leftExpr rightExpr ->
150 binop op leftExpr rightExpr
152 Function args body ->
153 generateFunction args body
155 Call func args ->
156 let
157 arity = length args
158 aN = "A" ++ show arity
159 in
160 do jsFunc <- generateJsExpr func
161 jsArgs <- mapM generateJsExpr args
162 jsExpr $
163 if 2 <= arity && arity <= 9 then
164 ref aN `call` (jsFunc:jsArgs)
165 else
166 foldl1 (<|) (jsFunc:jsArgs)
168 TailCall name argNames args ->
169 let
170 reassign name tempName =
171 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
172 in
173 do args' <- mapM generateJsExpr args
174 tempNames <- mapM (\_ -> Var.fresh) args
175 jsBlock $
176 VarDeclStmt () (zipWith varDecl tempNames args')
177 : zipWith reassign argNames tempNames
178 ++ [ContinueStmt () (Just (Id () name))]
180 Let defs body ->
181 do stmts <- mapM generateDef defs
182 code <- generateCode body
183 jsBlock (stmts ++ toStatementList code)
185 If branches finally ->
186 generateIf branches finally
188 Case root decisionTree branches ->
189 JsBlock <$> generateCase root decisionTree branches
191 ExplicitList elements ->
192 do jsElements <- mapM generateJsExpr elements
193 jsExpr $ BuiltIn.list jsElements
195 Data tag members ->
196 do jsMembers <- mapM generateJsExpr members
197 jsExpr $ ObjectLit () (ctor : fields jsMembers)
198 where
199 ctor = (prop "ctor", StringLit () tag)
200 fields =
201 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
203 DataAccess dataExpr index ->
204 do jsDataExpr <- generateJsExpr dataExpr
205 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
207 GLShader _uid src _tipe ->
208 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
210 Port impl ->
211 case impl of
212 Expr.In name portType ->
213 jsExpr (Port.inbound name portType)
215 Expr.Out name expr portType ->
216 do expr' <- generateJsExpr expr
217 jsExpr (Port.outbound name expr' portType)
219 Expr.Task name expr portType ->
220 do expr' <- generateJsExpr expr
221 jsExpr (Port.task name expr' portType)
223 Crash region maybeCaseCrashValue ->
224 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
227-- FUNCTIONS
229generateFunction :: [String] -> Opt.Expr -> State Int Code
230generateFunction args body =
231 do code <- generateCode body
232 jsExpr (generateFunctionWithArity args code)
235generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
236generateTailFunction name args body =
237 do code <- generateCode body
238 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
239 LabelledStmt ()
240 (Id () name)
241 (WhileStmt () (BoolLit () True) (toStatement code))
244generateFunctionWithArity :: [String] -> Code -> Expression ()
245generateFunctionWithArity rawArgs code =
246 let
247 args = map Var.safe rawArgs
248 arity = length args
249 in
250 if 2 <= arity && arity <= 9 then
251 let
252 fN = "F" ++ show arity
253 in
254 ref fN <| function args (toStatementList code)
255 else
256 let
257 (lastArg:otherArgs) = reverse args
258 innerBody = function [lastArg] (toStatementList code)
259 in
260 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
263-- GENERATE IFS
265generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
266generateIf givenBranches givenFinally =
267 let
268 (branches, finally) =
269 crushIfs givenBranches givenFinally
271 convertBranch (condition, expr) =
272 (,) <$> generateJsExpr condition <*> generateCode expr
274 ifExpression (condition, branch) otherwise =
275 CondExpr () condition branch otherwise
277 ifStatement (condition, branch) otherwise =
278 IfStmt () condition branch otherwise
279 in
280 do jsBranches <- mapM convertBranch branches
281 jsFinally <- generateCode finally
283 if any isBlock (jsFinally : map snd jsBranches)
284 then
285 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
286 else
287 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
290crushIfs
291 :: [(Opt.Expr, Opt.Expr)]
292 -> Opt.Expr
293 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
294crushIfs branches finally =
295 crushIfsHelp [] branches finally
298crushIfsHelp
299 :: [(Opt.Expr, Opt.Expr)]
300 -> [(Opt.Expr, Opt.Expr)]
301 -> Opt.Expr
302 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
303crushIfsHelp visitedBranches unvisitedBranches finally =
304 case unvisitedBranches of
305 [] ->
306 case finally of
307 If subBranches subFinally ->
308 crushIfsHelp visitedBranches subBranches subFinally
310 _ ->
311 (reverse visitedBranches, finally)
313 (Literal (L.Boolean True), branch) : _ ->
314 crushIfsHelp visitedBranches [] branch
316 visiting : unvisited ->
317 crushIfsHelp (visiting : visitedBranches) unvisited finally
320-- CASE EXPRESSIONS
322generateCase
323 :: String
324 -> DT.DecisionTree Opt.Jump
325 -> [(Int, Opt.Branch)]
326 -> State Int [Statement ()]
327generateCase root decisionTree jumpBranches =
328 do decider <- generateDecisionTree root decisionTree
329 foldM (goto root) decider jumpBranches
332goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
333goto root decider (target, branch) =
334 let
335 deciderStmt =
336 LabelledStmt ()
337 (targetLabel root target)
338 (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
339 in
340 do stmts <- generateBranch root branch
341 return (deciderStmt : stmts)
344targetLabel :: String -> Int -> Id ()
345targetLabel root target =
346 Id () (root ++ "_" ++ show target)
349generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
350generateDecisionTree root decisionTree =
351 case decisionTree of
352 DT.Match (Opt.Inline branch) ->
353 generateBranch root branch
355 DT.Match (Opt.Jump target) ->
356 return [ BreakStmt () (Just (targetLabel root target)) ]
358 DT.Decision testPath [(test, subTree)] (Just fallback) ->
359 let
360 (tests, deepestSubTree) =
361 collapseTests [(testPath, test)] fallback subTree
363 makeTest (path, test) =
364 do testExpr <- pathToTestableExpr root path test
365 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
366 in
367 do testExprs <- mapM makeTest tests
368 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
369 thenBranch <- generateDecisionTree root deepestSubTree
370 elseBranch <- generateDecisionTree root fallback
371 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
373 DT.Decision testPath edges fallback ->
374 do testExpr <- pathToTestableExpr root testPath (fst (head edges))
375 caseClauses <- mapM (edgeToCaseClause root) edges
376 caseDefault <- fallbackToDefault root fallback
377 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
380collapseTests
381 :: [(DT.Path, DT.Test)]
382 -> DT.DecisionTree Opt.Jump
383 -> DT.DecisionTree Opt.Jump
384 -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
385collapseTests tests outerFallback decisionTree =
386 case decisionTree of
387 DT.Decision testPath [(test, subTree)] (Just fallback)
388 | fallback == outerFallback ->
389 collapseTests ((testPath, test) : tests) outerFallback subTree
391 _ ->
392 (tests, decisionTree)
395edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
396edgeToCaseClause root (test, subTree) =
397 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
400pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
401pathToTestableExpr root path exampleTest =
402 do accessExpr <- generateJsExpr (pathToExpr root path)
403 case exampleTest of
404 DT.Constructor _ ->
405 return (DotRef () accessExpr (Id () "ctor"))
407 DT.Literal _ ->
408 return accessExpr
411testToExpr :: DT.Test -> Expression ()
412testToExpr test =
413 case test of
414 DT.Constructor (Var.Canonical _ tag) ->
415 StringLit () tag
417 DT.Literal (L.Chr char) ->
418 StringLit () [char]
420 DT.Literal lit ->
421 Literal.literal lit
424fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
425fallbackToDefault root fallback =
426 case fallback of
427 Nothing ->
428 return []
430 Just subTree ->
431 do stmts <- generateDecisionTree root subTree
432 return [ CaseDefault () stmts ]
435generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
436generateBranch root (Opt.Branch substitutions expr) =
437 do substs <- mapM (loadPath root) substitutions
438 let substStmts =
439 if null substs then [] else [ VarDeclStmt () substs ]
440 code <- generateCode expr
441 return (substStmts ++ toStatementList code)
444loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
445loadPath root (name, path) =
446 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
447 return $ varDecl (Var.safe name) jsAccessExpr
450pathToExpr :: String -> DT.Path -> Opt.Expr
451pathToExpr root fullPath =
452 go (Opt.Var (Var.local root)) fullPath
453 where
454 go expr path =
455 case path of
456 DT.Position index subpath ->
457 go (Opt.DataAccess expr index) subpath
459 DT.Field field subpath ->
460 go (Opt.Access expr field) subpath
462 DT.Empty ->
463 expr
465 DT.Alias ->
466 expr
469-- BINARY OPERATORS
471binop
472 :: Var.Canonical
473 -> Opt.Expr
474 -> Opt.Expr
475 -> State Int Code
476binop func left right =
477 do jsLeft <- generateJsExpr left
478 jsRight <- generateJsExpr right
479 jsExpr (makeExpr func jsLeft jsRight)
482-- BINARY OPERATOR HELPERS
484makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
485makeExpr qualifiedOp@(Var.Canonical home op) =
486 let
487 simpleMake left right =
488 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
489 in
490 if home == Var.Module (ModuleName.inCore ["Basics"]) then
491 Map.findWithDefault simpleMake op basicOps
492 else
493 simpleMake
496basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
497basicOps =
498 Map.fromList (infixOps ++ specialOps)
501infixOps :: [(String, Expression () -> Expression () -> Expression ())]
502infixOps =
503 let
504 infixOp str op =
505 (str, InfixExpr () op)
506 in
507 [ infixOp "+" OpAdd
508 , infixOp "-" OpSub
509 , infixOp "*" OpMul
510 , infixOp "/" OpDiv
511 , infixOp "&&" OpLAnd
512 , infixOp "||" OpLOr
513 ]
516specialOps :: [(String, Expression () -> Expression () -> Expression ())]
517specialOps =
518 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
519 , (,) "==" $ \a b -> BuiltIn.eq a b
520 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
521 , (,) "<" $ cmp OpLT 0
522 , (,) ">" $ cmp OpGT 0
523 , (,) "<=" $ cmp OpLT 1
524 , (,) ">=" $ cmp OpGT (-1)
525 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
526 ]
529cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
530cmp op n a b =
531 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)