git.iko.soy/elk
on 94ebc2d help sign in
elk/src/Generate/JavaScript/Expression.hs
519 lines 14 kB history raw
1module Generate.JavaScript.Expression (generateDef) where
3import Control.Arrow (second)
4import Control.Monad.State (State, foldM)
5import qualified Data.List as List
6import qualified Data.Map as Map
7import Language.ECMAScript3.Syntax
9import AST.Expression.Optimized as Opt
10import qualified AST.Literal as L
11import qualified AST.Module.Name as ModuleName
12import qualified AST.Variable as Var
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.JavaScript.BuiltIn as BuiltIn
15import qualified Generate.JavaScript.Foreign as Foreign
16import qualified Generate.JavaScript.Literal as Literal
17import qualified Generate.JavaScript.Variable as Var
18import qualified Optimize.DecisionTree as DT
22-- CODE CHUNKS
25data Code
26 = JsExpr (Expression ())
27 | JsBlock [Statement ()]
30jsExpr :: Expression () -> State Int Code
31jsExpr exp =
32 return (JsExpr exp)
35jsBlock :: [Statement ()] -> State Int Code
36jsBlock exp =
37 return (JsBlock exp)
40isBlock :: Code -> Bool
41isBlock code =
42 case code of
43 JsBlock _ -> True
44 JsExpr _ -> False
47toStatementList :: Code -> [Statement ()]
48toStatementList code =
49 case code of
50 JsExpr expr ->
51 [ ReturnStmt () (Just expr) ]
53 JsBlock stmts ->
54 stmts
57toStatement :: Code -> Statement ()
58toStatement code =
59 case code of
60 JsExpr expr ->
61 ReturnStmt () (Just expr)
63 JsBlock [stmt] ->
64 stmt
66 JsBlock stmts ->
67 BlockStmt () stmts
70toExpr :: Code -> Expression ()
71toExpr code =
72 case code of
73 JsExpr expr ->
74 expr
76 JsBlock stmts ->
77 function [] stmts `call` []
81-- DEFINITIONS
84generateDef :: Opt.Def -> State Int [Statement ()]
85generateDef def =
86 do (home, name, jsBody) <-
87 case def of
88 Opt.TailDef (Opt.Facts home _) name argNames body ->
89 (,,) home name <$> generateTailFunction name argNames body
91 Opt.Def (Opt.Facts home _) name body ->
92 (,,) home name <$> generateJsExpr body
94 return (Var.define home name jsBody)
98-- EXPRESSIONS
101generateJsExpr :: Opt.Expr -> State Int (Expression ())
102generateJsExpr optExpr =
103 toExpr <$> generateCode optExpr
106generateCode :: Opt.Expr -> State Int Code
107generateCode expr =
108 case expr of
109 Var var ->
110 jsExpr $ Var.canonical var
112 Literal lit ->
113 jsExpr (Literal.literal lit)
115 Range lo hi ->
116 do lo' <- generateJsExpr lo
117 hi' <- generateJsExpr hi
118 jsExpr $ BuiltIn.range lo' hi'
120 Access record field ->
121 do record' <- generateJsExpr record
122 jsExpr $ DotRef () record' (var (Var.safe field))
124 Update record fields ->
125 let
126 fieldToJs (field, value) =
127 do jsValue <- generateJsExpr value
128 return (Var.safe field, jsValue)
129 in
130 do jsRecord <- generateJsExpr record
131 jsFields <- mapM fieldToJs fields
132 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
134 Record fields ->
135 let
136 toField (field, value) =
137 do jsValue <- generateJsExpr value
138 return (Var.safe field ==> jsValue)
139 in
140 do jsFields <- mapM toField fields
141 jsExpr $ ObjectLit () jsFields
143 Binop op leftExpr rightExpr ->
144 binop op leftExpr rightExpr
146 Function args body ->
147 generateFunction args body
149 Call func args ->
150 let
151 arity = length args
152 aN = "A" ++ show arity
153 in
154 do jsFunc <- generateJsExpr func
155 jsArgs <- mapM generateJsExpr args
156 jsExpr $
157 if 2 <= arity && arity <= 9 then
158 ref aN `call` (jsFunc:jsArgs)
159 else
160 foldl1 (<|) (jsFunc:jsArgs)
162 TailCall name argNames args ->
163 let
164 reassign name tempName =
165 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
166 in
167 do args' <- mapM generateJsExpr args
168 tempNames <- mapM (\_ -> Var.fresh) args
169 jsBlock $
170 VarDeclStmt () (zipWith varDecl tempNames args')
171 : zipWith reassign argNames tempNames
172 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
174 Let defs body ->
175 do stmts <- mapM generateDef defs
176 code <- generateCode body
177 jsBlock (concat stmts ++ toStatementList code)
179 If branches finally ->
180 generateIf branches finally
182 Case exprName decider jumps ->
183 JsBlock <$> generateCase exprName decider jumps
185 ExplicitList elements ->
186 do jsElements <- mapM generateJsExpr elements
187 jsExpr $ BuiltIn.list jsElements
189 Data tag members ->
190 let
191 ctor =
192 "ctor" ==> StringLit () tag
194 toEntry entry n =
195 ("_" ++ show n) ==> entry
196 in
197 do jsMembers <- mapM generateJsExpr members
198 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
200 DataAccess dataExpr index ->
201 do jsDataExpr <- generateJsExpr dataExpr
202 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
204 Cmd moduleName ->
205 jsExpr $ BuiltIn.effect moduleName
207 Sub moduleName ->
208 jsExpr $ BuiltIn.effect moduleName
210 ForeignCmd name tipe ->
211 jsExpr $ BuiltIn.foreignCmd name (Foreign.encode tipe)
213 ForeignSub name tipe ->
214 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
215 jsExpr $ BuiltIn.foreignSub name jsDecoder
217 GLShader _uid src _tipe ->
218 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
220 Crash home region maybeBranchProblem ->
221 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
222 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
226-- 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 () (Var.safe 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
264-- GENERATE IFS
267generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
268generateIf givenBranches givenFinally =
269 let
270 (branches, finally) =
271 crushIfs givenBranches givenFinally
273 convertBranch (condition, expr) =
274 (,) <$> generateJsExpr condition <*> generateCode expr
276 ifExpression (condition, branch) otherwise =
277 CondExpr () condition branch otherwise
279 ifStatement (condition, branch) otherwise =
280 IfStmt () condition branch otherwise
281 in
282 do jsBranches <- mapM convertBranch branches
283 jsFinally <- generateCode finally
285 if any isBlock (jsFinally : map snd jsBranches)
286 then
287 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
288 else
289 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
292crushIfs
293 :: [(Opt.Expr, Opt.Expr)]
294 -> Opt.Expr
295 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
296crushIfs branches finally =
297 crushIfsHelp [] branches finally
300crushIfsHelp
301 :: [(Opt.Expr, Opt.Expr)]
302 -> [(Opt.Expr, Opt.Expr)]
303 -> Opt.Expr
304 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
305crushIfsHelp visitedBranches unvisitedBranches finally =
306 case unvisitedBranches of
307 [] ->
308 case finally of
309 If subBranches subFinally ->
310 crushIfsHelp visitedBranches subBranches subFinally
312 _ ->
313 (reverse visitedBranches, finally)
315 (Literal (L.Boolean True), branch) : _ ->
316 crushIfsHelp visitedBranches [] branch
318 visiting : unvisited ->
319 crushIfsHelp (visiting : visitedBranches) unvisited finally
323-- CASE EXPRESSIONS
326generateCase
327 :: String
328 -> Opt.Decider Opt.Choice
329 -> [(Int, Opt.Expr)]
330 -> State Int [Statement ()]
331generateCase exprName decider jumps =
332 do labelRoot <- Var.fresh
333 decider <- generateDecider exprName labelRoot decider
334 foldM (goto labelRoot) decider jumps
338-- handle any jumps
341goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
342goto labelRoot deciderStmts (target, branch) =
343 let
344 labeledDeciderStmt =
345 LabelledStmt ()
346 (toLabel labelRoot target)
347 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
348 in
349 do code <- generateCode branch
350 return (labeledDeciderStmt : toStatementList code)
353toLabel :: String -> Int -> Id ()
354toLabel root target =
355 Id () (root ++ "_" ++ show target)
359-- turn deciders into ifs and switches
362generateDecider
363 :: String
364 -> String
365 -> Opt.Decider Opt.Choice
366 -> State Int [Statement ()]
367generateDecider exprName labelRoot decisionTree =
368 case decisionTree of
369 Opt.Leaf (Opt.Inline branch) ->
370 toStatementList <$> generateCode branch
372 Opt.Leaf (Opt.Jump target) ->
373 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
375 Opt.Chain testChain success failure ->
376 let
377 makeTest (path, test) =
378 do testExpr <- pathToTestableExpr exprName path test
379 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
380 in
381 do testExprs <- mapM makeTest testChain
382 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
383 thenBranch <- generateDecider exprName labelRoot success
384 elseBranch <- generateDecider exprName labelRoot failure
385 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
387 Opt.FanOut path edges fallback ->
388 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
389 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
390 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
391 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
394edgeToCaseClause
395 :: String
396 -> String
397 -> (DT.Test, Opt.Decider Opt.Choice)
398 -> State Int (CaseClause ())
399edgeToCaseClause exprName labelRoot (test, subTree) =
400 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
403testToExpr :: DT.Test -> Expression ()
404testToExpr test =
405 case test of
406 DT.Constructor (Var.Canonical _ tag) ->
407 StringLit () tag
409 DT.Literal (L.Chr char) ->
410 StringLit () [char]
412 DT.Literal lit ->
413 Literal.literal lit
417-- work with paths
420pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
421pathToTestableExpr root path exampleTest =
422 do accessExpr <- generateJsExpr (pathToExpr root path)
423 case exampleTest of
424 DT.Constructor _ ->
425 return (DotRef () accessExpr (Id () "ctor"))
427 DT.Literal (L.Chr _) ->
428 return (DotRef () accessExpr (Id () "valueOf") `call` [])
430 DT.Literal _ ->
431 return accessExpr
434pathToExpr :: String -> DT.Path -> Opt.Expr
435pathToExpr root fullPath =
436 go (Opt.Var (Var.local root)) fullPath
437 where
438 go expr path =
439 case path of
440 DT.Position index subpath ->
441 go (Opt.DataAccess expr index) subpath
443 DT.Field field subpath ->
444 go (Opt.Access expr field) subpath
446 DT.Empty ->
447 expr
449 DT.Alias ->
450 expr
454-- BINARY OPERATORS
457binop
458 :: Var.Canonical
459 -> Opt.Expr
460 -> Opt.Expr
461 -> State Int Code
462binop func left right =
463 do jsLeft <- generateJsExpr left
464 jsRight <- generateJsExpr right
465 jsExpr (makeExpr func jsLeft jsRight)
469-- BINARY OPERATOR HELPERS
472makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
473makeExpr qualifiedOp@(Var.Canonical home op) =
474 let
475 simpleMake left right =
476 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
477 in
478 if home == Var.Module (ModuleName.inCore ["Basics"]) then
479 Map.findWithDefault simpleMake op basicOps
480 else
481 simpleMake
484basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
485basicOps =
486 Map.fromList (infixOps ++ specialOps)
489infixOps :: [(String, Expression () -> Expression () -> Expression ())]
490infixOps =
491 let
492 infixOp str op =
493 (str, InfixExpr () op)
494 in
495 [ infixOp "+" OpAdd
496 , infixOp "-" OpSub
497 , infixOp "*" OpMul
498 , infixOp "/" OpDiv
499 , infixOp "&&" OpLAnd
500 , infixOp "||" OpLOr
501 ]
504specialOps :: [(String, Expression () -> Expression () -> Expression ())]
505specialOps =
506 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
507 , (,) "==" $ \a b -> BuiltIn.eq a b
508 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
509 , (,) "<" $ cmp OpLT 0
510 , (,) ">" $ cmp OpGT 0
511 , (,) "<=" $ cmp OpLT 1
512 , (,) ">=" $ cmp OpGT (-1)
513 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
514 ]
517cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
518cmp op n a b =
519 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)