git.iko.soy/elk
on ea2a61e help sign in
elk/src/Generate/JavaScript/Expression.hs
636 lines 17 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 qualified AST.Expression.Canonical as Can
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.Foreign as Foreign
17import qualified Generate.JavaScript.Literal as Literal
18import qualified Generate.JavaScript.Variable as Var
19import qualified Optimize.DecisionTree as DT
23-- CODE CHUNKS
26data Code
27 = JsExpr (Expression ())
28 | JsBlock [Statement ()]
31jsExpr :: Expression () -> State Int Code
32jsExpr exp =
33 return (JsExpr exp)
36jsBlock :: [Statement ()] -> State Int Code
37jsBlock exp =
38 return (JsBlock exp)
41isBlock :: Code -> Bool
42isBlock code =
43 case code of
44 JsBlock _ -> True
45 JsExpr _ -> False
48toStatementList :: Code -> [Statement ()]
49toStatementList code =
50 case code of
51 JsExpr expr ->
52 [ ReturnStmt () (Just expr) ]
54 JsBlock stmts ->
55 stmts
58toStatement :: Code -> Statement ()
59toStatement code =
60 case code of
61 JsExpr expr ->
62 ReturnStmt () (Just expr)
64 JsBlock [stmt] ->
65 stmt
67 JsBlock stmts ->
68 BlockStmt () stmts
71toExpr :: Code -> Expression ()
72toExpr code =
73 case code of
74 JsExpr expr ->
75 expr
77 JsBlock stmts ->
78 function [] stmts `call` []
82-- DEFINITIONS
85generateDef :: Opt.Def -> State Int [Statement ()]
86generateDef def =
87 do (home, name, jsBody) <-
88 case def of
89 Opt.TailDef (Opt.Facts home) name argNames body ->
90 (,,) home name <$> generateTailFunction name argNames body
92 Opt.Def (Opt.Facts home) name body ->
93 (,,) home name <$> generateJsExpr body
95 return (Var.define home name jsBody)
99-- EXPRESSIONS
102generateJsExpr :: Opt.Expr -> State Int (Expression ())
103generateJsExpr optExpr =
104 toExpr <$> generateCode optExpr
107generateCode :: Opt.Expr -> State Int Code
108generateCode expr =
109 case expr of
110 Var var ->
111 jsExpr $ Var.canonical var
113 Literal lit ->
114 jsExpr (Literal.literal lit)
116 Access record field ->
117 do record' <- generateJsExpr record
118 jsExpr $ DotRef () record' (var (Var.safe field))
120 Update record fields ->
121 let
122 fieldToJs (field, value) =
123 do jsValue <- generateJsExpr value
124 return (Var.safe field, jsValue)
125 in
126 do jsRecord <- generateJsExpr record
127 jsFields <- mapM fieldToJs fields
128 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
130 Record fields ->
131 let
132 toField (field, value) =
133 do jsValue <- generateJsExpr value
134 return (Var.safe field ==> jsValue)
135 in
136 do jsFields <- mapM toField fields
137 jsExpr $ ObjectLit () jsFields
139 Binop op leftExpr rightExpr ->
140 binop op leftExpr rightExpr
142 Function args body ->
143 generateFunction args body
145 Call func args ->
146 generateCall func args
148 TailCall name argNames args ->
149 let
150 reassign name tempName =
151 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
152 in
153 do args' <- mapM generateJsExpr args
154 tempNames <- mapM (\_ -> Var.fresh) args
155 jsBlock $
156 VarDeclStmt () (zipWith varDecl tempNames args')
157 : zipWith reassign argNames tempNames
158 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
160 Let defs body ->
161 do stmts <- mapM generateDef defs
162 code <- generateCode body
163 jsBlock (concat stmts ++ toStatementList code)
165 If branches finally ->
166 generateIf branches finally
168 Case exprName decider jumps ->
169 JsBlock <$> generateCase exprName decider jumps
171 List elements ->
172 do jsElements <- mapM generateJsExpr elements
173 jsExpr $ BuiltIn.list jsElements
175 Ctor tag members ->
176 let
177 ctor =
178 "ctor" ==> StringLit () tag
180 toEntry entry n =
181 ("_" ++ show n) ==> entry
182 in
183 do jsMembers <- mapM generateJsExpr members
184 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
186 CtorAccess dataExpr index ->
187 do jsDataExpr <- generateJsExpr dataExpr
188 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
190 Cmd moduleName ->
191 jsExpr $ BuiltIn.effect moduleName
193 Sub moduleName ->
194 jsExpr $ BuiltIn.effect moduleName
196 OutgoingPort name tipe ->
197 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
199 IncomingPort name tipe ->
200 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
201 jsExpr $ BuiltIn.incomingPort name jsDecoder
203 Program kind body ->
204 generateProgram kind body
206 GLShader _uid src _tipe ->
207 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
209 Crash home region maybeBranchProblem ->
210 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
211 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
215-- PROGRAMS
218generateProgram :: Can.Main -> Opt.Expr -> State Int Code
219generateProgram kind body =
220 case kind of
221 Can.VDom ->
222 do html <- generateJsExpr body
223 jsExpr (Var.staticProgram <| html)
225 Can.NoFlags ->
226 do almostProgram <- generateJsExpr body
227 jsExpr (almostProgram `call` [])
229 Can.Flags tipe ->
230 do almostProgram <- generateJsExpr body
231 flagDecoder <- generateJsExpr (Foreign.decode tipe)
232 jsExpr (almostProgram <| flagDecoder)
236-- FUNCTIONS
239generateFunction :: [String] -> Opt.Expr -> State Int Code
240generateFunction args body =
241 do code <- generateCode body
242 jsExpr (generateFunctionWithArity args code)
245generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
246generateTailFunction name args body =
247 do code <- generateCode body
248 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
249 LabelledStmt ()
250 (Id () (Var.safe name))
251 (WhileStmt () (BoolLit () True) (toStatement code))
254generateFunctionWithArity :: [String] -> Code -> Expression ()
255generateFunctionWithArity rawArgs code =
256 let
257 args = map Var.safe rawArgs
258 arity = length args
259 in
260 if 2 <= arity && arity <= 9 then
261 let
262 fN = "F" ++ show arity
263 in
264 ref fN <| function args (toStatementList code)
265 else
266 let
267 (lastArg:otherArgs) = reverse args
268 innerBody = function [lastArg] (toStatementList code)
269 in
270 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
274-- GENERATE CALL
277generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
278generateCall func args =
279 case (func, args) of
280 (Opt.Var var, [arg]) ->
281 case getUnaryOp var of
282 Just op ->
283 do jsArg <- generateJsExpr arg
284 jsExpr $ PrefixExpr () op jsArg
286 Nothing ->
287 generateCallHelp func args
289 (Opt.Var var, [ arg1, arg2 ]) ->
290 case getBinaryOp var arg1 arg2 of
291 Just (op, left, right) ->
292 do jsLeft <- generateJsExpr left
293 jsRight <- generateJsExpr right
294 jsExpr $ InfixExpr () op jsLeft jsRight
296 Nothing ->
297 generateCallHelp func args
299 _ ->
300 generateCallHelp func args
303generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
304generateCallHelp func args =
305 let
306 arity = length args
307 aN = "A" ++ show arity
308 in
309 do jsFunc <- generateJsExpr func
310 jsArgs <- mapM generateJsExpr args
311 jsExpr $
312 if 2 <= arity && arity <= 9 then
313 ref aN `call` (jsFunc:jsArgs)
314 else
315 foldl1 (<|) (jsFunc:jsArgs)
318getUnaryOp :: Var.Canonical -> Maybe PrefixOp
319getUnaryOp var =
320 if var == bitwiseComplement then
321 Just PrefixBNot
323 else if var == basicsNot then
324 Just PrefixLNot
326 else
327 Nothing
330getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (InfixOp, Opt.Expr, Opt.Expr)
331getBinaryOp (Var.Canonical home name) left right =
332 if home /= bitwise then
333 Nothing
335 else
336 case name of
337 "and" -> Just ( OpBAnd, left, right )
338 "or" -> Just ( OpBOr, left, right )
339 "xor" -> Just ( OpBXor, left, right )
340 "shiftLeftBy" -> Just ( OpLShift, right, left )
341 "shiftRightBy" -> Just ( OpSpRShift, right, left )
342 "shiftRightZfBy" -> Just ( OpZfRShift, right, left )
343 _ -> Nothing
346bitwiseComplement :: Var.Canonical
347bitwiseComplement =
348 Var.inCore ["Bitwise"] "complement"
351basicsNot :: Var.Canonical
352basicsNot =
353 Var.inCore ["Basics"] "not"
356bitwise :: Var.Home
357bitwise =
358 Var.Module (ModuleName.inCore ["Bitwise"])
362-- GENERATE IFS
365generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
366generateIf givenBranches givenFinally =
367 let
368 (branches, finally) =
369 crushIfs givenBranches givenFinally
371 convertBranch (condition, expr) =
372 (,) <$> generateJsExpr condition <*> generateCode expr
374 ifExpression (condition, branch) otherwise =
375 CondExpr () condition branch otherwise
377 ifStatement (condition, branch) otherwise =
378 IfStmt () condition branch otherwise
379 in
380 do jsBranches <- mapM convertBranch branches
381 jsFinally <- generateCode finally
383 if any isBlock (jsFinally : map snd jsBranches)
384 then
385 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
386 else
387 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
390crushIfs
391 :: [(Opt.Expr, Opt.Expr)]
392 -> Opt.Expr
393 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
394crushIfs branches finally =
395 crushIfsHelp [] branches finally
398crushIfsHelp
399 :: [(Opt.Expr, Opt.Expr)]
400 -> [(Opt.Expr, Opt.Expr)]
401 -> Opt.Expr
402 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
403crushIfsHelp visitedBranches unvisitedBranches finally =
404 case unvisitedBranches of
405 [] ->
406 case finally of
407 If subBranches subFinally ->
408 crushIfsHelp visitedBranches subBranches subFinally
410 _ ->
411 (reverse visitedBranches, finally)
413 (Literal (L.Boolean True), branch) : _ ->
414 crushIfsHelp visitedBranches [] branch
416 visiting : unvisited ->
417 crushIfsHelp (visiting : visitedBranches) unvisited finally
421-- CASE EXPRESSIONS
424generateCase
425 :: String
426 -> Opt.Decider Opt.Choice
427 -> [(Int, Opt.Expr)]
428 -> State Int [Statement ()]
429generateCase exprName decider jumps =
430 do labelRoot <- Var.fresh
431 decider <- generateDecider exprName labelRoot decider
432 foldM (goto labelRoot) decider jumps
436-- handle any jumps
439goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
440goto labelRoot deciderStmts (target, branch) =
441 let
442 labeledDeciderStmt =
443 LabelledStmt ()
444 (toLabel labelRoot target)
445 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
446 in
447 do code <- generateCode branch
448 return (labeledDeciderStmt : toStatementList code)
451toLabel :: String -> Int -> Id ()
452toLabel root target =
453 Id () (root ++ "_" ++ show target)
457-- turn deciders into ifs and switches
460generateDecider
461 :: String
462 -> String
463 -> Opt.Decider Opt.Choice
464 -> State Int [Statement ()]
465generateDecider exprName labelRoot decisionTree =
466 case decisionTree of
467 Opt.Leaf (Opt.Inline branch) ->
468 toStatementList <$> generateCode branch
470 Opt.Leaf (Opt.Jump target) ->
471 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
473 Opt.Chain testChain success failure ->
474 let
475 makeTest (path, test) =
476 do testExpr <- pathToTestableExpr exprName path test
477 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
478 in
479 do testExprs <- mapM makeTest testChain
480 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
481 thenBranch <- generateDecider exprName labelRoot success
482 elseBranch <- generateDecider exprName labelRoot failure
483 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
485 Opt.FanOut path edges fallback ->
486 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
487 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
488 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
489 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
492edgeToCaseClause
493 :: String
494 -> String
495 -> (DT.Test, Opt.Decider Opt.Choice)
496 -> State Int (CaseClause ())
497edgeToCaseClause exprName labelRoot (test, subTree) =
498 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
501testToExpr :: DT.Test -> Expression ()
502testToExpr test =
503 case test of
504 DT.Constructor (Var.Canonical _ tag) ->
505 StringLit () tag
507 DT.Literal (L.Chr char) ->
508 StringLit () [char]
510 DT.Literal lit ->
511 Literal.literal lit
515-- work with paths
518pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
519pathToTestableExpr root path exampleTest =
520 do accessExpr <- generateJsExpr (pathToExpr root path)
521 case exampleTest of
522 DT.Constructor _ ->
523 return (DotRef () accessExpr (Id () "ctor"))
525 DT.Literal (L.Chr _) ->
526 return (DotRef () accessExpr (Id () "valueOf") `call` [])
528 DT.Literal _ ->
529 return accessExpr
532pathToExpr :: String -> DT.Path -> Opt.Expr
533pathToExpr root fullPath =
534 go (Opt.Var (Var.local root)) fullPath
535 where
536 go expr path =
537 case path of
538 DT.Position index subpath ->
539 go (Opt.CtorAccess expr index) subpath
541 DT.Field field subpath ->
542 go (Opt.Access expr field) subpath
544 DT.Empty ->
545 expr
547 DT.Alias ->
548 expr
552-- BINARY OPERATORS
555binop
556 :: Var.Canonical
557 -> Opt.Expr
558 -> Opt.Expr
559 -> State Int Code
560binop func left right =
561 do jsLeft <- generateJsExpr left
562 jsRight <- generateJsExpr right
563 jsExpr (binopHelp func jsLeft jsRight)
567-- BINARY OPERATOR HELPERS
570binopHelp :: Var.Canonical -> Expression () -> Expression () -> Expression ()
571binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
572 let
573 simpleMake left right =
574 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
575 in
576 if home == basicsModule then
577 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
579 else if op == "::" && (home == listModule || home == listModuleInternals) then
580 BuiltIn.cons leftExpr rightExpr
582 else
583 simpleMake leftExpr rightExpr
586listModule :: Var.Home
587listModule =
588 Var.Module (ModuleName.inCore ["List"])
591listModuleInternals :: Var.Home
592listModuleInternals =
593 Var.TopLevel (ModuleName.inCore ["List"])
596basicsModule :: Var.Home
597basicsModule =
598 Var.Module (ModuleName.inCore ["Basics"])
601basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
602basicOps =
603 Map.fromList (infixOps ++ specialOps)
606infixOps :: [(String, Expression () -> Expression () -> Expression ())]
607infixOps =
608 let
609 infixOp str op =
610 (str, InfixExpr () op)
611 in
612 [ infixOp "+" OpAdd
613 , infixOp "-" OpSub
614 , infixOp "*" OpMul
615 , infixOp "/" OpDiv
616 , infixOp "&&" OpLAnd
617 , infixOp "||" OpLOr
618 ]
621specialOps :: [(String, Expression () -> Expression () -> Expression ())]
622specialOps =
623 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
624 , (,) "==" $ \a b -> BuiltIn.eq a b
625 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
626 , (,) "<" $ cmp OpLT 0
627 , (,) ">" $ cmp OpGT 0
628 , (,) "<=" $ cmp OpLT 1
629 , (,) ">=" $ cmp OpGT (-1)
630 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
631 ]
634cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
635cmp op n a b =
636 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)