git.iko.soy/elk
on c9f3911 help sign in
elk/src/Generate/JavaScript/Expression.hs
528 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 [ ret expr ]
51 JsBlock stmts ->
52 stmts
55toStatement :: Code -> Statement ()
56toStatement code =
57 case code of
58 JsExpr expr ->
59 ret expr
60 JsBlock [stmt] ->
61 stmt
62 JsBlock stmts ->
63 BlockStmt () stmts
66toExpr :: Code -> Expression ()
67toExpr code =
68 case code of
69 JsExpr expr ->
70 expr
72 JsBlock stmts ->
73 function [] stmts `call` []
76-- DEFINITIONS
78generateDef :: Opt.Def -> State Int (Statement ())
79generateDef 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
85 Opt.Def (Opt.Facts home _) name body ->
86 (,,) home name <$> generateJsExpr body
88 return (Var.define name jsBody)
91-- EXPRESSIONS
93generateJsExpr :: Opt.Expr -> State Int (Expression ())
94generateJsExpr optExpr =
95 toExpr <$> generateCode optExpr
98generateCode :: Opt.Expr -> State Int Code
99generateCode expr =
100 case expr of
101 Var var ->
102 jsExpr $ Var.canonical var
104 Literal lit ->
105 jsExpr (Literal.literal lit)
107 Range lo hi ->
108 do lo' <- generateJsExpr lo
109 hi' <- generateJsExpr hi
110 jsExpr $ BuiltIn.range lo' hi'
112 Access record field ->
113 do record' <- generateJsExpr record
114 jsExpr $ DotRef () record' (var (Var.safe field))
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
126 Record fields ->
127 do fields' <-
128 forM fields $ \(field, e) ->
129 (,) (Var.safe field) <$> generateJsExpr e
131 let fieldMap =
132 List.foldl' combine Map.empty fields'
134 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
135 where
136 combine record (field, value) =
137 Map.insertWith (++) field [value] record
139 hidden fs =
140 ObjectLit () . map (prop *** ArrayLit ()) $
141 Map.toList (Map.filter (not . null) (Map.map tail fs))
143 visible fs =
144 map (first prop) (Map.toList (Map.map head fs))
146 Binop op leftExpr rightExpr ->
147 binop op leftExpr rightExpr
149 Function args body ->
150 generateFunction args body
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)
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))]
177 Let defs body ->
178 do stmts <- mapM generateDef defs
179 code <- generateCode body
180 jsBlock (stmts ++ toStatementList code)
182 If branches finally ->
183 generateIf branches finally
185 Case root decisionTree branches ->
186 JsBlock <$> generateCase root decisionTree branches
188 ExplicitList elements ->
189 do jsElements <- mapM generateJsExpr elements
190 jsExpr $ BuiltIn.list jsElements
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 .. ]
200 DataAccess dataExpr index ->
201 do jsDataExpr <- generateJsExpr dataExpr
202 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
204 GLShader _uid src _tipe ->
205 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
207 Port impl ->
208 case impl of
209 Expr.In name portType ->
210 jsExpr (Port.inbound name portType)
212 Expr.Out name expr portType ->
213 do expr' <- generateJsExpr expr
214 jsExpr (Port.outbound name expr' portType)
216 Expr.Task name expr portType ->
217 do expr' <- generateJsExpr expr
218 jsExpr (Port.task name expr' portType)
220 Crash region maybeCaseCrashValue ->
221 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
224-- FUNCTIONS
226generateFunction :: [String] -> Opt.Expr -> State Int Code
227generateFunction args body =
228 do code <- generateCode body
229 jsExpr (generateFunctionWithArity args code)
232generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
233generateTailFunction name args body =
234 do code <- generateCode body
235 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
236 LabelledStmt ()
237 (Id () name)
238 (WhileStmt () (BoolLit () True) (toStatement code))
241generateFunctionWithArity :: [String] -> Code -> Expression ()
242generateFunctionWithArity 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
260-- GENERATE IFS
262generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
263generateIf givenBranches givenFinally =
264 let
265 (branches, finally) =
266 crushIfs givenBranches givenFinally
268 convertBranch (condition, expr) =
269 (,) <$> generateJsExpr condition <*> generateCode expr
271 ifExpression (condition, branch) otherwise =
272 CondExpr () condition branch otherwise
274 ifStatement (condition, branch) otherwise =
275 IfStmt () condition branch otherwise
276 in
277 do jsBranches <- mapM convertBranch branches
278 jsFinally <- generateCode finally
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))
287crushIfs
288 :: [(Opt.Expr, Opt.Expr)]
289 -> Opt.Expr
290 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
291crushIfs branches finally =
292 crushIfsHelp [] branches finally
295crushIfsHelp
296 :: [(Opt.Expr, Opt.Expr)]
297 -> [(Opt.Expr, Opt.Expr)]
298 -> Opt.Expr
299 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
300crushIfsHelp visitedBranches unvisitedBranches finally =
301 case unvisitedBranches of
302 [] ->
303 case finally of
304 If subBranches subFinally ->
305 crushIfsHelp visitedBranches subBranches subFinally
307 _ ->
308 (reverse visitedBranches, finally)
310 (Literal (L.Boolean True), branch) : _ ->
311 crushIfsHelp visitedBranches [] branch
313 visiting : unvisited ->
314 crushIfsHelp (visiting : visitedBranches) unvisited finally
317-- CASE EXPRESSIONS
319generateCase
320 :: String
321 -> DT.DecisionTree Opt.Jump
322 -> [(Int, Opt.Branch)]
323 -> State Int [Statement ()]
324generateCase root decisionTree jumpBranches =
325 do decider <- generateDecisionTree root decisionTree
326 foldM (goto root) decider jumpBranches
329goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
330goto 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)
341targetLabel :: String -> Int -> Id ()
342targetLabel root target =
343 Id () (root ++ "_" ++ show target)
346generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
347generateDecisionTree root decisionTree =
348 case decisionTree of
349 DT.Match (Opt.Inline branch) ->
350 generateBranch root branch
352 DT.Match (Opt.Jump target) ->
353 return [ BreakStmt () (Just (targetLabel root target)) ]
355 DT.Decision testPath [(test, subTree)] (Just fallback) ->
356 let
357 (tests, deepestSubTree) =
358 collapseTests [(testPath, test)] fallback subTree
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) ]
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) ]
377collapseTests
378 :: [(DT.Path, DT.Test)]
379 -> DT.DecisionTree Opt.Jump
380 -> DT.DecisionTree Opt.Jump
381 -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
382collapseTests 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
388 _ ->
389 (tests, decisionTree)
392edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
393edgeToCaseClause root (test, subTree) =
394 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
397pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
398pathToTestableExpr root path exampleTest =
399 do accessExpr <- generateJsExpr (pathToExpr root path)
400 case exampleTest of
401 DT.Constructor _ ->
402 return (DotRef () accessExpr (Id () "ctor"))
404 DT.Literal _ ->
405 return accessExpr
408testToExpr :: DT.Test -> Expression ()
409testToExpr test =
410 case test of
411 DT.Constructor (Var.Canonical _ tag) ->
412 StringLit () tag
414 DT.Literal (L.Chr char) ->
415 StringLit () [char]
417 DT.Literal lit ->
418 Literal.literal lit
421fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
422fallbackToDefault root fallback =
423 case fallback of
424 Nothing ->
425 return []
427 Just subTree ->
428 do stmts <- generateDecisionTree root subTree
429 return [ CaseDefault () stmts ]
432generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
433generateBranch 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)
441loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
442loadPath root (name, path) =
443 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
444 return $ varDecl (Var.safe name) jsAccessExpr
447pathToExpr :: String -> DT.Path -> Opt.Expr
448pathToExpr 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
456 DT.Field field subpath ->
457 go (Opt.Access expr field) subpath
459 DT.Empty ->
460 expr
462 DT.Alias ->
463 expr
466-- BINARY OPERATORS
468binop
469 :: Var.Canonical
470 -> Opt.Expr
471 -> Opt.Expr
472 -> State Int Code
473binop func left right =
474 do jsLeft <- generateJsExpr left
475 jsRight <- generateJsExpr right
476 jsExpr (makeExpr func jsLeft jsRight)
479-- BINARY OPERATOR HELPERS
481makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
482makeExpr 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
493basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
494basicOps =
495 Map.fromList (infixOps ++ specialOps)
498infixOps :: [(String, Expression () -> Expression () -> Expression ())]
499infixOps =
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 ]
513specialOps :: [(String, Expression () -> Expression () -> Expression ())]
514specialOps =
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 ]
526cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
527cmp op n a b =
528 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)