git.iko.soy/elk
on 505bafc help sign in
elk/src/Generate/JavaScript/Expression.hs
545 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 Range lo hi ->
118 do lo' <- generateJsExpr lo
119 hi' <- generateJsExpr hi
120 jsExpr $ BuiltIn.range lo' hi'
122 Access record field ->
123 do record' <- generateJsExpr record
124 jsExpr $ DotRef () record' (var (Var.safe field))
126 Update record fields ->
127 let
128 fieldToJs (field, value) =
129 do jsValue <- generateJsExpr value
130 return (Var.safe field, jsValue)
131 in
132 do jsRecord <- generateJsExpr record
133 jsFields <- mapM fieldToJs fields
134 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
136 Record fields ->
137 let
138 toField (field, value) =
139 do jsValue <- generateJsExpr value
140 return (Var.safe field ==> jsValue)
141 in
142 do jsFields <- mapM toField fields
143 jsExpr $ ObjectLit () jsFields
145 Binop op leftExpr rightExpr ->
146 binop op leftExpr rightExpr
148 Function args body ->
149 generateFunction args body
151 Call func args ->
152 let
153 arity = length args
154 aN = "A" ++ show arity
155 in
156 do jsFunc <- generateJsExpr func
157 jsArgs <- mapM generateJsExpr args
158 jsExpr $
159 if 2 <= arity && arity <= 9 then
160 ref aN `call` (jsFunc:jsArgs)
161 else
162 foldl1 (<|) (jsFunc:jsArgs)
164 TailCall name argNames args ->
165 let
166 reassign name tempName =
167 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
168 in
169 do args' <- mapM generateJsExpr args
170 tempNames <- mapM (\_ -> Var.fresh) args
171 jsBlock $
172 VarDeclStmt () (zipWith varDecl tempNames args')
173 : zipWith reassign argNames tempNames
174 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
176 Let defs body ->
177 do stmts <- mapM generateDef defs
178 code <- generateCode body
179 jsBlock (concat stmts ++ toStatementList code)
181 If branches finally ->
182 generateIf branches finally
184 Case exprName decider jumps ->
185 JsBlock <$> generateCase exprName decider jumps
187 ExplicitList elements ->
188 do jsElements <- mapM generateJsExpr elements
189 jsExpr $ BuiltIn.list jsElements
191 Data tag members ->
192 let
193 ctor =
194 "ctor" ==> StringLit () tag
196 toEntry entry n =
197 ("_" ++ show n) ==> entry
198 in
199 do jsMembers <- mapM generateJsExpr members
200 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
202 DataAccess dataExpr index ->
203 do jsDataExpr <- generateJsExpr dataExpr
204 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
206 Cmd moduleName ->
207 jsExpr $ BuiltIn.effect moduleName
209 Sub moduleName ->
210 jsExpr $ BuiltIn.effect moduleName
212 OutgoingPort name tipe ->
213 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
215 IncomingPort name tipe ->
216 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
217 jsExpr $ BuiltIn.incomingPort name jsDecoder
219 Program kind body ->
220 generateProgram kind body
222 GLShader _uid src _tipe ->
223 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
225 Crash home region maybeBranchProblem ->
226 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
227 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
231-- PROGRAMS
234generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code
235generateProgram kind body =
236 let
237 gen fields =
238 generateCode $ Record (("main", body) : fields)
239 in
240 case kind of
241 Expr.VDom ->
242 gen []
244 Expr.NoFlags ->
245 gen []
247 Expr.Flags tipe ->
248 gen [ ("flags", Foreign.decode tipe) ]
252-- FUNCTIONS
255generateFunction :: [String] -> Opt.Expr -> State Int Code
256generateFunction args body =
257 do code <- generateCode body
258 jsExpr (generateFunctionWithArity args code)
261generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
262generateTailFunction name args body =
263 do code <- generateCode body
264 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
265 LabelledStmt ()
266 (Id () (Var.safe name))
267 (WhileStmt () (BoolLit () True) (toStatement code))
270generateFunctionWithArity :: [String] -> Code -> Expression ()
271generateFunctionWithArity rawArgs code =
272 let
273 args = map Var.safe rawArgs
274 arity = length args
275 in
276 if 2 <= arity && arity <= 9 then
277 let
278 fN = "F" ++ show arity
279 in
280 ref fN <| function args (toStatementList code)
281 else
282 let
283 (lastArg:otherArgs) = reverse args
284 innerBody = function [lastArg] (toStatementList code)
285 in
286 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
290-- GENERATE IFS
293generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
294generateIf givenBranches givenFinally =
295 let
296 (branches, finally) =
297 crushIfs givenBranches givenFinally
299 convertBranch (condition, expr) =
300 (,) <$> generateJsExpr condition <*> generateCode expr
302 ifExpression (condition, branch) otherwise =
303 CondExpr () condition branch otherwise
305 ifStatement (condition, branch) otherwise =
306 IfStmt () condition branch otherwise
307 in
308 do jsBranches <- mapM convertBranch branches
309 jsFinally <- generateCode finally
311 if any isBlock (jsFinally : map snd jsBranches)
312 then
313 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
314 else
315 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
318crushIfs
319 :: [(Opt.Expr, Opt.Expr)]
320 -> Opt.Expr
321 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
322crushIfs branches finally =
323 crushIfsHelp [] branches finally
326crushIfsHelp
327 :: [(Opt.Expr, Opt.Expr)]
328 -> [(Opt.Expr, Opt.Expr)]
329 -> Opt.Expr
330 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
331crushIfsHelp visitedBranches unvisitedBranches finally =
332 case unvisitedBranches of
333 [] ->
334 case finally of
335 If subBranches subFinally ->
336 crushIfsHelp visitedBranches subBranches subFinally
338 _ ->
339 (reverse visitedBranches, finally)
341 (Literal (L.Boolean True), branch) : _ ->
342 crushIfsHelp visitedBranches [] branch
344 visiting : unvisited ->
345 crushIfsHelp (visiting : visitedBranches) unvisited finally
349-- CASE EXPRESSIONS
352generateCase
353 :: String
354 -> Opt.Decider Opt.Choice
355 -> [(Int, Opt.Expr)]
356 -> State Int [Statement ()]
357generateCase exprName decider jumps =
358 do labelRoot <- Var.fresh
359 decider <- generateDecider exprName labelRoot decider
360 foldM (goto labelRoot) decider jumps
364-- handle any jumps
367goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
368goto labelRoot deciderStmts (target, branch) =
369 let
370 labeledDeciderStmt =
371 LabelledStmt ()
372 (toLabel labelRoot target)
373 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
374 in
375 do code <- generateCode branch
376 return (labeledDeciderStmt : toStatementList code)
379toLabel :: String -> Int -> Id ()
380toLabel root target =
381 Id () (root ++ "_" ++ show target)
385-- turn deciders into ifs and switches
388generateDecider
389 :: String
390 -> String
391 -> Opt.Decider Opt.Choice
392 -> State Int [Statement ()]
393generateDecider exprName labelRoot decisionTree =
394 case decisionTree of
395 Opt.Leaf (Opt.Inline branch) ->
396 toStatementList <$> generateCode branch
398 Opt.Leaf (Opt.Jump target) ->
399 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
401 Opt.Chain testChain success failure ->
402 let
403 makeTest (path, test) =
404 do testExpr <- pathToTestableExpr exprName path test
405 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
406 in
407 do testExprs <- mapM makeTest testChain
408 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
409 thenBranch <- generateDecider exprName labelRoot success
410 elseBranch <- generateDecider exprName labelRoot failure
411 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
413 Opt.FanOut path edges fallback ->
414 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
415 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
416 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
417 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
420edgeToCaseClause
421 :: String
422 -> String
423 -> (DT.Test, Opt.Decider Opt.Choice)
424 -> State Int (CaseClause ())
425edgeToCaseClause exprName labelRoot (test, subTree) =
426 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
429testToExpr :: DT.Test -> Expression ()
430testToExpr test =
431 case test of
432 DT.Constructor (Var.Canonical _ tag) ->
433 StringLit () tag
435 DT.Literal (L.Chr char) ->
436 StringLit () [char]
438 DT.Literal lit ->
439 Literal.literal lit
443-- work with paths
446pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
447pathToTestableExpr root path exampleTest =
448 do accessExpr <- generateJsExpr (pathToExpr root path)
449 case exampleTest of
450 DT.Constructor _ ->
451 return (DotRef () accessExpr (Id () "ctor"))
453 DT.Literal (L.Chr _) ->
454 return (DotRef () accessExpr (Id () "valueOf") `call` [])
456 DT.Literal _ ->
457 return accessExpr
460pathToExpr :: String -> DT.Path -> Opt.Expr
461pathToExpr root fullPath =
462 go (Opt.Var (Var.local root)) fullPath
463 where
464 go expr path =
465 case path of
466 DT.Position index subpath ->
467 go (Opt.DataAccess expr index) subpath
469 DT.Field field subpath ->
470 go (Opt.Access expr field) subpath
472 DT.Empty ->
473 expr
475 DT.Alias ->
476 expr
480-- BINARY OPERATORS
483binop
484 :: Var.Canonical
485 -> Opt.Expr
486 -> Opt.Expr
487 -> State Int Code
488binop func left right =
489 do jsLeft <- generateJsExpr left
490 jsRight <- generateJsExpr right
491 jsExpr (makeExpr func jsLeft jsRight)
495-- BINARY OPERATOR HELPERS
498makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
499makeExpr qualifiedOp@(Var.Canonical home op) =
500 let
501 simpleMake left right =
502 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
503 in
504 if home == Var.Module (ModuleName.inCore ["Basics"]) then
505 Map.findWithDefault simpleMake op basicOps
506 else
507 simpleMake
510basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
511basicOps =
512 Map.fromList (infixOps ++ specialOps)
515infixOps :: [(String, Expression () -> Expression () -> Expression ())]
516infixOps =
517 let
518 infixOp str op =
519 (str, InfixExpr () op)
520 in
521 [ infixOp "+" OpAdd
522 , infixOp "-" OpSub
523 , infixOp "*" OpMul
524 , infixOp "/" OpDiv
525 , infixOp "&&" OpLAnd
526 , infixOp "||" OpLOr
527 ]
530specialOps :: [(String, Expression () -> Expression () -> Expression ())]
531specialOps =
532 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
533 , (,) "==" $ \a b -> BuiltIn.eq a b
534 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
535 , (,) "<" $ cmp OpLT 0
536 , (,) ">" $ cmp OpGT 0
537 , (,) "<=" $ cmp OpLT 1
538 , (,) ">=" $ cmp OpGT (-1)
539 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
540 ]
543cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
544cmp op n a b =
545 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)