git.iko.soy/elk
on 0d71129 help sign in
elk/src/Generate/JavaScript/Expression.hs
618 lines 16 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.General as Expr (Main(..))
10import AST.Expression.Optimized as Opt
11import qualified AST.Literal as L
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Type as Type
14import qualified AST.Variable as Var
15import Generate.JavaScript.Helpers as Help
16import qualified Generate.JavaScript.BuiltIn as BuiltIn
17import qualified Generate.JavaScript.Foreign as Foreign
18import qualified Generate.JavaScript.Literal as Literal
19import qualified Generate.JavaScript.Variable as Var
20import qualified Optimize.DecisionTree as DT
24-- CODE CHUNKS
27data Code
28 = JsExpr (Expression ())
29 | JsBlock [Statement ()]
32jsExpr :: Expression () -> State Int Code
33jsExpr exp =
34 return (JsExpr exp)
37jsBlock :: [Statement ()] -> State Int Code
38jsBlock exp =
39 return (JsBlock exp)
42isBlock :: Code -> Bool
43isBlock code =
44 case code of
45 JsBlock _ -> True
46 JsExpr _ -> False
49toStatementList :: Code -> [Statement ()]
50toStatementList code =
51 case code of
52 JsExpr expr ->
53 [ ReturnStmt () (Just expr) ]
55 JsBlock stmts ->
56 stmts
59toStatement :: Code -> Statement ()
60toStatement code =
61 case code of
62 JsExpr expr ->
63 ReturnStmt () (Just expr)
65 JsBlock [stmt] ->
66 stmt
68 JsBlock stmts ->
69 BlockStmt () stmts
72toExpr :: Code -> Expression ()
73toExpr code =
74 case code of
75 JsExpr expr ->
76 expr
78 JsBlock stmts ->
79 function [] stmts `call` []
83-- DEFINITIONS
86generateDef :: Opt.Def -> State Int [Statement ()]
87generateDef def =
88 do (home, name, jsBody) <-
89 case def of
90 Opt.TailDef (Opt.Facts home) name argNames body ->
91 (,,) home name <$> generateTailFunction name argNames body
93 Opt.Def (Opt.Facts home) name body ->
94 (,,) home name <$> generateJsExpr body
96 return (Var.define home name jsBody)
100-- EXPRESSIONS
103generateJsExpr :: Opt.Expr -> State Int (Expression ())
104generateJsExpr optExpr =
105 toExpr <$> generateCode optExpr
108generateCode :: Opt.Expr -> State Int Code
109generateCode expr =
110 case expr of
111 Var var ->
112 jsExpr $ Var.canonical var
114 Literal lit ->
115 jsExpr (Literal.literal lit)
117 Access record field ->
118 do record' <- generateJsExpr record
119 jsExpr $ DotRef () record' (var (Var.safe field))
121 Update record fields ->
122 let
123 fieldToJs (field, value) =
124 do jsValue <- generateJsExpr value
125 return (Var.safe field, jsValue)
126 in
127 do jsRecord <- generateJsExpr record
128 jsFields <- mapM fieldToJs fields
129 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
131 Record fields ->
132 let
133 toField (field, value) =
134 do jsValue <- generateJsExpr value
135 return (Var.safe field ==> jsValue)
136 in
137 do jsFields <- mapM toField fields
138 jsExpr $ ObjectLit () jsFields
140 Binop op leftExpr rightExpr ->
141 binop op leftExpr rightExpr
143 Function args body ->
144 generateFunction args body
146 Call func args ->
147 generateCall func args
149 TailCall name argNames args ->
150 let
151 reassign name tempName =
152 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
153 in
154 do args' <- mapM generateJsExpr args
155 tempNames <- mapM (\_ -> Var.fresh) args
156 jsBlock $
157 VarDeclStmt () (zipWith varDecl tempNames args')
158 : zipWith reassign argNames tempNames
159 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
161 Let defs body ->
162 do stmts <- mapM generateDef defs
163 code <- generateCode body
164 jsBlock (concat stmts ++ toStatementList code)
166 If branches finally ->
167 generateIf branches finally
169 Case exprName decider jumps ->
170 JsBlock <$> generateCase exprName decider jumps
172 ExplicitList elements ->
173 do jsElements <- mapM generateJsExpr elements
174 jsExpr $ BuiltIn.list jsElements
176 Data tag members ->
177 let
178 ctor =
179 "ctor" ==> StringLit () tag
181 toEntry entry n =
182 ("_" ++ show n) ==> entry
183 in
184 do jsMembers <- mapM generateJsExpr members
185 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
187 DataAccess dataExpr index ->
188 do jsDataExpr <- generateJsExpr dataExpr
189 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
191 Cmd moduleName ->
192 jsExpr $ BuiltIn.effect moduleName
194 Sub moduleName ->
195 jsExpr $ BuiltIn.effect moduleName
197 OutgoingPort name tipe ->
198 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
200 IncomingPort name tipe ->
201 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
202 jsExpr $ BuiltIn.incomingPort name jsDecoder
204 Program kind body ->
205 generateProgram kind body
207 GLShader _uid src _tipe ->
208 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
210 Crash home region maybeBranchProblem ->
211 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
212 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
216-- PROGRAMS
219generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code
220generateProgram kind body =
221 case kind of
222 Expr.VDom ->
223 do html <- generateJsExpr body
224 jsExpr (Var.coreNative "Platform" "htmlToProgram" <| html)
226 Expr.NoFlags ->
227 do almostProgram <- generateJsExpr body
228 jsExpr (almostProgram `call` [])
230 Expr.Flags tipe ->
231 do almostProgram <- generateJsExpr body
232 flagDecoder <- generateJsExpr (Foreign.decode tipe)
233 jsExpr (almostProgram <| flagDecoder)
237-- FUNCTIONS
240generateFunction :: [String] -> Opt.Expr -> State Int Code
241generateFunction args body =
242 do code <- generateCode body
243 jsExpr (generateFunctionWithArity args code)
246generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
247generateTailFunction name args body =
248 do code <- generateCode body
249 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
250 LabelledStmt ()
251 (Id () (Var.safe name))
252 (WhileStmt () (BoolLit () True) (toStatement code))
255generateFunctionWithArity :: [String] -> Code -> Expression ()
256generateFunctionWithArity rawArgs code =
257 let
258 args = map Var.safe rawArgs
259 arity = length args
260 in
261 if 2 <= arity && arity <= 9 then
262 let
263 fN = "F" ++ show arity
264 in
265 ref fN <| function args (toStatementList code)
266 else
267 let
268 (lastArg:otherArgs) = reverse args
269 innerBody = function [lastArg] (toStatementList code)
270 in
271 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
275-- GENERATE CALL
278generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
279generateCall func args =
280 case (func, args) of
281 (Opt.Var var, [arg]) ->
282 case getUnaryOp var of
283 Just op ->
284 do jsArg <- generateJsExpr arg
285 jsExpr $ PrefixExpr () op jsArg
287 Nothing ->
288 generateCallHelp func args
290 (Opt.Var var, [left, right]) ->
291 case getBinaryOp var of
292 Just op ->
293 do jsLeft <- generateJsExpr left
294 jsRight <- generateJsExpr right
295 jsExpr $ InfixExpr () op jsLeft jsRight
297 Nothing ->
298 generateCallHelp func args
300 _ ->
301 generateCallHelp func args
304generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
305generateCallHelp func args =
306 let
307 arity = length args
308 aN = "A" ++ show arity
309 in
310 do jsFunc <- generateJsExpr func
311 jsArgs <- mapM generateJsExpr args
312 jsExpr $
313 if 2 <= arity && arity <= 9 then
314 ref aN `call` (jsFunc:jsArgs)
315 else
316 foldl1 (<|) (jsFunc:jsArgs)
319getUnaryOp :: Var.Canonical -> Maybe PrefixOp
320getUnaryOp var =
321 if var == bitwiseComplement then
322 Just PrefixBNot
324 else if var == basicsNot then
325 Just PrefixLNot
327 else
328 Nothing
331getBinaryOp :: Var.Canonical -> Maybe InfixOp
332getBinaryOp (Var.Canonical home name) =
333 if home /= bitwise then
334 Nothing
336 else
337 case name of
338 "and" -> Just OpBAnd
339 "or" -> Just OpBOr
340 "xor" -> Just OpBXor
341 "shiftLeftBy" -> Just OpLShift
342 "shiftRightBy" -> Just OpSpRShift
343 "shiftRightZfBy" -> Just OpZfRShift
344 _ -> Nothing
347bitwiseComplement :: Var.Canonical
348bitwiseComplement =
349 Var.inCore ["Bitwise"] "complement"
352basicsNot :: Var.Canonical
353basicsNot =
354 Var.inCore ["Basics"] "not"
357bitwise :: Var.Home
358bitwise =
359 Var.Module (ModuleName.inCore ["Bitwise"])
363-- GENERATE IFS
366generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
367generateIf givenBranches givenFinally =
368 let
369 (branches, finally) =
370 crushIfs givenBranches givenFinally
372 convertBranch (condition, expr) =
373 (,) <$> generateJsExpr condition <*> generateCode expr
375 ifExpression (condition, branch) otherwise =
376 CondExpr () condition branch otherwise
378 ifStatement (condition, branch) otherwise =
379 IfStmt () condition branch otherwise
380 in
381 do jsBranches <- mapM convertBranch branches
382 jsFinally <- generateCode finally
384 if any isBlock (jsFinally : map snd jsBranches)
385 then
386 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
387 else
388 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
391crushIfs
392 :: [(Opt.Expr, Opt.Expr)]
393 -> Opt.Expr
394 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
395crushIfs branches finally =
396 crushIfsHelp [] branches finally
399crushIfsHelp
400 :: [(Opt.Expr, Opt.Expr)]
401 -> [(Opt.Expr, Opt.Expr)]
402 -> Opt.Expr
403 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
404crushIfsHelp visitedBranches unvisitedBranches finally =
405 case unvisitedBranches of
406 [] ->
407 case finally of
408 If subBranches subFinally ->
409 crushIfsHelp visitedBranches subBranches subFinally
411 _ ->
412 (reverse visitedBranches, finally)
414 (Literal (L.Boolean True), branch) : _ ->
415 crushIfsHelp visitedBranches [] branch
417 visiting : unvisited ->
418 crushIfsHelp (visiting : visitedBranches) unvisited finally
422-- CASE EXPRESSIONS
425generateCase
426 :: String
427 -> Opt.Decider Opt.Choice
428 -> [(Int, Opt.Expr)]
429 -> State Int [Statement ()]
430generateCase exprName decider jumps =
431 do labelRoot <- Var.fresh
432 decider <- generateDecider exprName labelRoot decider
433 foldM (goto labelRoot) decider jumps
437-- handle any jumps
440goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
441goto labelRoot deciderStmts (target, branch) =
442 let
443 labeledDeciderStmt =
444 LabelledStmt ()
445 (toLabel labelRoot target)
446 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
447 in
448 do code <- generateCode branch
449 return (labeledDeciderStmt : toStatementList code)
452toLabel :: String -> Int -> Id ()
453toLabel root target =
454 Id () (root ++ "_" ++ show target)
458-- turn deciders into ifs and switches
461generateDecider
462 :: String
463 -> String
464 -> Opt.Decider Opt.Choice
465 -> State Int [Statement ()]
466generateDecider exprName labelRoot decisionTree =
467 case decisionTree of
468 Opt.Leaf (Opt.Inline branch) ->
469 toStatementList <$> generateCode branch
471 Opt.Leaf (Opt.Jump target) ->
472 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
474 Opt.Chain testChain success failure ->
475 let
476 makeTest (path, test) =
477 do testExpr <- pathToTestableExpr exprName path test
478 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
479 in
480 do testExprs <- mapM makeTest testChain
481 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
482 thenBranch <- generateDecider exprName labelRoot success
483 elseBranch <- generateDecider exprName labelRoot failure
484 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
486 Opt.FanOut path edges fallback ->
487 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
488 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
489 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
490 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
493edgeToCaseClause
494 :: String
495 -> String
496 -> (DT.Test, Opt.Decider Opt.Choice)
497 -> State Int (CaseClause ())
498edgeToCaseClause exprName labelRoot (test, subTree) =
499 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
502testToExpr :: DT.Test -> Expression ()
503testToExpr test =
504 case test of
505 DT.Constructor (Var.Canonical _ tag) ->
506 StringLit () tag
508 DT.Literal (L.Chr char) ->
509 StringLit () [char]
511 DT.Literal lit ->
512 Literal.literal lit
516-- work with paths
519pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
520pathToTestableExpr root path exampleTest =
521 do accessExpr <- generateJsExpr (pathToExpr root path)
522 case exampleTest of
523 DT.Constructor _ ->
524 return (DotRef () accessExpr (Id () "ctor"))
526 DT.Literal (L.Chr _) ->
527 return (DotRef () accessExpr (Id () "valueOf") `call` [])
529 DT.Literal _ ->
530 return accessExpr
533pathToExpr :: String -> DT.Path -> Opt.Expr
534pathToExpr root fullPath =
535 go (Opt.Var (Var.local root)) fullPath
536 where
537 go expr path =
538 case path of
539 DT.Position index subpath ->
540 go (Opt.DataAccess expr index) subpath
542 DT.Field field subpath ->
543 go (Opt.Access expr field) subpath
545 DT.Empty ->
546 expr
548 DT.Alias ->
549 expr
553-- BINARY OPERATORS
556binop
557 :: Var.Canonical
558 -> Opt.Expr
559 -> Opt.Expr
560 -> State Int Code
561binop func left right =
562 do jsLeft <- generateJsExpr left
563 jsRight <- generateJsExpr right
564 jsExpr (makeExpr func jsLeft jsRight)
568-- BINARY OPERATOR HELPERS
571makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
572makeExpr qualifiedOp@(Var.Canonical home op) =
573 let
574 simpleMake left right =
575 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
576 in
577 if home == Var.Module (ModuleName.inCore ["Basics"]) then
578 Map.findWithDefault simpleMake op basicOps
579 else
580 simpleMake
583basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
584basicOps =
585 Map.fromList (infixOps ++ specialOps)
588infixOps :: [(String, Expression () -> Expression () -> Expression ())]
589infixOps =
590 let
591 infixOp str op =
592 (str, InfixExpr () op)
593 in
594 [ infixOp "+" OpAdd
595 , infixOp "-" OpSub
596 , infixOp "*" OpMul
597 , infixOp "/" OpDiv
598 , infixOp "&&" OpLAnd
599 , infixOp "||" OpLOr
600 ]
603specialOps :: [(String, Expression () -> Expression () -> Expression ())]
604specialOps =
605 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
606 , (,) "==" $ \a b -> BuiltIn.eq a b
607 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
608 , (,) "<" $ cmp OpLT 0
609 , (,) ">" $ cmp OpGT 0
610 , (,) "<=" $ cmp OpLT 1
611 , (,) ">=" $ cmp OpGT (-1)
612 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
613 ]
616cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
617cmp op n a b =
618 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)