git.iko.soy/elk
on 4bec0ec help sign in
elk/src/Generate/JavaScript/Expression.hs
540 lines 15 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 let
148 arity = length args
149 aN = "A" ++ show arity
150 in
151 do jsFunc <- generateJsExpr func
152 jsArgs <- mapM generateJsExpr args
153 jsExpr $
154 if 2 <= arity && arity <= 9 then
155 ref aN `call` (jsFunc:jsArgs)
156 else
157 foldl1 (<|) (jsFunc:jsArgs)
159 TailCall name argNames args ->
160 let
161 reassign name tempName =
162 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
163 in
164 do args' <- mapM generateJsExpr args
165 tempNames <- mapM (\_ -> Var.fresh) args
166 jsBlock $
167 VarDeclStmt () (zipWith varDecl tempNames args')
168 : zipWith reassign argNames tempNames
169 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
171 Let defs body ->
172 do stmts <- mapM generateDef defs
173 code <- generateCode body
174 jsBlock (concat stmts ++ toStatementList code)
176 If branches finally ->
177 generateIf branches finally
179 Case exprName decider jumps ->
180 JsBlock <$> generateCase exprName decider jumps
182 ExplicitList elements ->
183 do jsElements <- mapM generateJsExpr elements
184 jsExpr $ BuiltIn.list jsElements
186 Data tag members ->
187 let
188 ctor =
189 "ctor" ==> StringLit () tag
191 toEntry entry n =
192 ("_" ++ show n) ==> entry
193 in
194 do jsMembers <- mapM generateJsExpr members
195 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
197 DataAccess dataExpr index ->
198 do jsDataExpr <- generateJsExpr dataExpr
199 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
201 Cmd moduleName ->
202 jsExpr $ BuiltIn.effect moduleName
204 Sub moduleName ->
205 jsExpr $ BuiltIn.effect moduleName
207 OutgoingPort name tipe ->
208 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
210 IncomingPort name tipe ->
211 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
212 jsExpr $ BuiltIn.incomingPort name jsDecoder
214 Program kind body ->
215 generateProgram kind body
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-- PROGRAMS
229generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code
230generateProgram kind body =
231 case kind of
232 Expr.VDom ->
233 do html <- generateJsExpr body
234 jsExpr (Var.coreNative "Platform" "htmlToProgram" <| html)
236 Expr.NoFlags ->
237 do almostProgram <- generateJsExpr body
238 jsExpr (almostProgram `call` [])
240 Expr.Flags tipe ->
241 do almostProgram <- generateJsExpr body
242 flagDecoder <- generateJsExpr (Foreign.decode tipe)
243 jsExpr (almostProgram <| flagDecoder)
247-- FUNCTIONS
250generateFunction :: [String] -> Opt.Expr -> State Int Code
251generateFunction args body =
252 do code <- generateCode body
253 jsExpr (generateFunctionWithArity args code)
256generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
257generateTailFunction name args body =
258 do code <- generateCode body
259 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
260 LabelledStmt ()
261 (Id () (Var.safe name))
262 (WhileStmt () (BoolLit () True) (toStatement code))
265generateFunctionWithArity :: [String] -> Code -> Expression ()
266generateFunctionWithArity rawArgs code =
267 let
268 args = map Var.safe rawArgs
269 arity = length args
270 in
271 if 2 <= arity && arity <= 9 then
272 let
273 fN = "F" ++ show arity
274 in
275 ref fN <| function args (toStatementList code)
276 else
277 let
278 (lastArg:otherArgs) = reverse args
279 innerBody = function [lastArg] (toStatementList code)
280 in
281 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
285-- GENERATE IFS
288generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
289generateIf givenBranches givenFinally =
290 let
291 (branches, finally) =
292 crushIfs givenBranches givenFinally
294 convertBranch (condition, expr) =
295 (,) <$> generateJsExpr condition <*> generateCode expr
297 ifExpression (condition, branch) otherwise =
298 CondExpr () condition branch otherwise
300 ifStatement (condition, branch) otherwise =
301 IfStmt () condition branch otherwise
302 in
303 do jsBranches <- mapM convertBranch branches
304 jsFinally <- generateCode finally
306 if any isBlock (jsFinally : map snd jsBranches)
307 then
308 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
309 else
310 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
313crushIfs
314 :: [(Opt.Expr, Opt.Expr)]
315 -> Opt.Expr
316 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
317crushIfs branches finally =
318 crushIfsHelp [] branches finally
321crushIfsHelp
322 :: [(Opt.Expr, Opt.Expr)]
323 -> [(Opt.Expr, Opt.Expr)]
324 -> Opt.Expr
325 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
326crushIfsHelp visitedBranches unvisitedBranches finally =
327 case unvisitedBranches of
328 [] ->
329 case finally of
330 If subBranches subFinally ->
331 crushIfsHelp visitedBranches subBranches subFinally
333 _ ->
334 (reverse visitedBranches, finally)
336 (Literal (L.Boolean True), branch) : _ ->
337 crushIfsHelp visitedBranches [] branch
339 visiting : unvisited ->
340 crushIfsHelp (visiting : visitedBranches) unvisited finally
344-- CASE EXPRESSIONS
347generateCase
348 :: String
349 -> Opt.Decider Opt.Choice
350 -> [(Int, Opt.Expr)]
351 -> State Int [Statement ()]
352generateCase exprName decider jumps =
353 do labelRoot <- Var.fresh
354 decider <- generateDecider exprName labelRoot decider
355 foldM (goto labelRoot) decider jumps
359-- handle any jumps
362goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
363goto labelRoot deciderStmts (target, branch) =
364 let
365 labeledDeciderStmt =
366 LabelledStmt ()
367 (toLabel labelRoot target)
368 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
369 in
370 do code <- generateCode branch
371 return (labeledDeciderStmt : toStatementList code)
374toLabel :: String -> Int -> Id ()
375toLabel root target =
376 Id () (root ++ "_" ++ show target)
380-- turn deciders into ifs and switches
383generateDecider
384 :: String
385 -> String
386 -> Opt.Decider Opt.Choice
387 -> State Int [Statement ()]
388generateDecider exprName labelRoot decisionTree =
389 case decisionTree of
390 Opt.Leaf (Opt.Inline branch) ->
391 toStatementList <$> generateCode branch
393 Opt.Leaf (Opt.Jump target) ->
394 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
396 Opt.Chain testChain success failure ->
397 let
398 makeTest (path, test) =
399 do testExpr <- pathToTestableExpr exprName path test
400 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
401 in
402 do testExprs <- mapM makeTest testChain
403 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
404 thenBranch <- generateDecider exprName labelRoot success
405 elseBranch <- generateDecider exprName labelRoot failure
406 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
408 Opt.FanOut path edges fallback ->
409 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
410 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
411 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
412 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
415edgeToCaseClause
416 :: String
417 -> String
418 -> (DT.Test, Opt.Decider Opt.Choice)
419 -> State Int (CaseClause ())
420edgeToCaseClause exprName labelRoot (test, subTree) =
421 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
424testToExpr :: DT.Test -> Expression ()
425testToExpr test =
426 case test of
427 DT.Constructor (Var.Canonical _ tag) ->
428 StringLit () tag
430 DT.Literal (L.Chr char) ->
431 StringLit () [char]
433 DT.Literal lit ->
434 Literal.literal lit
438-- work with paths
441pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
442pathToTestableExpr root path exampleTest =
443 do accessExpr <- generateJsExpr (pathToExpr root path)
444 case exampleTest of
445 DT.Constructor _ ->
446 return (DotRef () accessExpr (Id () "ctor"))
448 DT.Literal (L.Chr _) ->
449 return (DotRef () accessExpr (Id () "valueOf") `call` [])
451 DT.Literal _ ->
452 return accessExpr
455pathToExpr :: String -> DT.Path -> Opt.Expr
456pathToExpr root fullPath =
457 go (Opt.Var (Var.local root)) fullPath
458 where
459 go expr path =
460 case path of
461 DT.Position index subpath ->
462 go (Opt.DataAccess expr index) subpath
464 DT.Field field subpath ->
465 go (Opt.Access expr field) subpath
467 DT.Empty ->
468 expr
470 DT.Alias ->
471 expr
475-- BINARY OPERATORS
478binop
479 :: Var.Canonical
480 -> Opt.Expr
481 -> Opt.Expr
482 -> State Int Code
483binop func left right =
484 do jsLeft <- generateJsExpr left
485 jsRight <- generateJsExpr right
486 jsExpr (makeExpr func jsLeft jsRight)
490-- BINARY OPERATOR HELPERS
493makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
494makeExpr qualifiedOp@(Var.Canonical home op) =
495 let
496 simpleMake left right =
497 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
498 in
499 if home == Var.Module (ModuleName.inCore ["Basics"]) then
500 Map.findWithDefault simpleMake op basicOps
501 else
502 simpleMake
505basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
506basicOps =
507 Map.fromList (infixOps ++ specialOps)
510infixOps :: [(String, Expression () -> Expression () -> Expression ())]
511infixOps =
512 let
513 infixOp str op =
514 (str, InfixExpr () op)
515 in
516 [ infixOp "+" OpAdd
517 , infixOp "-" OpSub
518 , infixOp "*" OpMul
519 , infixOp "/" OpDiv
520 , infixOp "&&" OpLAnd
521 , infixOp "||" OpLOr
522 ]
525specialOps :: [(String, Expression () -> Expression () -> Expression ())]
526specialOps =
527 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
528 , (,) "==" $ \a b -> BuiltIn.eq a b
529 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
530 , (,) "<" $ cmp OpLT 0
531 , (,) ">" $ cmp OpGT 0
532 , (,) "<=" $ cmp OpLT 1
533 , (,) ">=" $ cmp OpGT (-1)
534 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
535 ]
538cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
539cmp op n a b =
540 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)