git.iko.soy/elk
on 856ac59 help sign in
elk/src/Generate/JavaScript/Expression.hs
531 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.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 Range lo hi ->
117 do lo' <- generateJsExpr lo
118 hi' <- generateJsExpr hi
119 jsExpr $ BuiltIn.range lo' hi'
121 Access record field ->
122 do record' <- generateJsExpr record
123 jsExpr $ DotRef () record' (var (Var.safe field))
125 Update record fields ->
126 let
127 fieldToJs (field, value) =
128 do jsValue <- generateJsExpr value
129 return (Var.safe field, jsValue)
130 in
131 do jsRecord <- generateJsExpr record
132 jsFields <- mapM fieldToJs fields
133 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
135 Record fields ->
136 let
137 toField (field, value) =
138 do jsValue <- generateJsExpr value
139 return (Var.safe field ==> jsValue)
140 in
141 do jsFields <- mapM toField fields
142 jsExpr $ ObjectLit () jsFields
144 Binop op leftExpr rightExpr ->
145 binop op leftExpr rightExpr
147 Function args body ->
148 generateFunction args body
150 Call func args ->
151 let
152 arity = length args
153 aN = "A" ++ show arity
154 in
155 do jsFunc <- generateJsExpr func
156 jsArgs <- mapM generateJsExpr args
157 jsExpr $
158 if 2 <= arity && arity <= 9 then
159 ref aN `call` (jsFunc:jsArgs)
160 else
161 foldl1 (<|) (jsFunc:jsArgs)
163 TailCall name argNames args ->
164 let
165 reassign name tempName =
166 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
167 in
168 do args' <- mapM generateJsExpr args
169 tempNames <- mapM (\_ -> Var.fresh) args
170 jsBlock $
171 VarDeclStmt () (zipWith varDecl tempNames args')
172 : zipWith reassign argNames tempNames
173 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
175 Let defs body ->
176 do stmts <- mapM generateDef defs
177 code <- generateCode body
178 jsBlock (concat stmts ++ toStatementList code)
180 If branches finally ->
181 generateIf branches finally
183 Case exprName decider jumps ->
184 JsBlock <$> generateCase exprName decider jumps
186 ExplicitList elements ->
187 do jsElements <- mapM generateJsExpr elements
188 jsExpr $ BuiltIn.list jsElements
190 Data tag members ->
191 let
192 ctor =
193 "ctor" ==> StringLit () tag
195 toEntry entry n =
196 ("_" ++ show n) ==> entry
197 in
198 do jsMembers <- mapM generateJsExpr members
199 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
201 DataAccess dataExpr index ->
202 do jsDataExpr <- generateJsExpr dataExpr
203 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
205 Cmd moduleName ->
206 jsExpr $ BuiltIn.effect moduleName
208 Sub moduleName ->
209 jsExpr $ BuiltIn.effect moduleName
211 ForeignCmd name tipe ->
212 jsExpr $ BuiltIn.foreignCmd name (Foreign.encode tipe)
214 ForeignSub name tipe ->
215 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
216 jsExpr $ BuiltIn.foreignSub name jsDecoder
218 Program kind body ->
219 case kind of
220 Expr.VDom ->
221 generateCode (Data "vdom" [body])
223 Expr.NoFlags ->
224 generateCode (Data "no-flags" [body])
226 Expr.Flags tipe ->
227 generateCode (Data "flags" [Foreign.decode tipe, body])
229 GLShader _uid src _tipe ->
230 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
232 Crash home region maybeBranchProblem ->
233 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
234 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
238-- FUNCTIONS
241generateFunction :: [String] -> Opt.Expr -> State Int Code
242generateFunction args body =
243 do code <- generateCode body
244 jsExpr (generateFunctionWithArity args code)
247generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
248generateTailFunction name args body =
249 do code <- generateCode body
250 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
251 LabelledStmt ()
252 (Id () (Var.safe name))
253 (WhileStmt () (BoolLit () True) (toStatement code))
256generateFunctionWithArity :: [String] -> Code -> Expression ()
257generateFunctionWithArity rawArgs code =
258 let
259 args = map Var.safe rawArgs
260 arity = length args
261 in
262 if 2 <= arity && arity <= 9 then
263 let
264 fN = "F" ++ show arity
265 in
266 ref fN <| function args (toStatementList code)
267 else
268 let
269 (lastArg:otherArgs) = reverse args
270 innerBody = function [lastArg] (toStatementList code)
271 in
272 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
276-- GENERATE IFS
279generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
280generateIf givenBranches givenFinally =
281 let
282 (branches, finally) =
283 crushIfs givenBranches givenFinally
285 convertBranch (condition, expr) =
286 (,) <$> generateJsExpr condition <*> generateCode expr
288 ifExpression (condition, branch) otherwise =
289 CondExpr () condition branch otherwise
291 ifStatement (condition, branch) otherwise =
292 IfStmt () condition branch otherwise
293 in
294 do jsBranches <- mapM convertBranch branches
295 jsFinally <- generateCode finally
297 if any isBlock (jsFinally : map snd jsBranches)
298 then
299 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
300 else
301 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
304crushIfs
305 :: [(Opt.Expr, Opt.Expr)]
306 -> Opt.Expr
307 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
308crushIfs branches finally =
309 crushIfsHelp [] branches finally
312crushIfsHelp
313 :: [(Opt.Expr, Opt.Expr)]
314 -> [(Opt.Expr, Opt.Expr)]
315 -> Opt.Expr
316 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
317crushIfsHelp visitedBranches unvisitedBranches finally =
318 case unvisitedBranches of
319 [] ->
320 case finally of
321 If subBranches subFinally ->
322 crushIfsHelp visitedBranches subBranches subFinally
324 _ ->
325 (reverse visitedBranches, finally)
327 (Literal (L.Boolean True), branch) : _ ->
328 crushIfsHelp visitedBranches [] branch
330 visiting : unvisited ->
331 crushIfsHelp (visiting : visitedBranches) unvisited finally
335-- CASE EXPRESSIONS
338generateCase
339 :: String
340 -> Opt.Decider Opt.Choice
341 -> [(Int, Opt.Expr)]
342 -> State Int [Statement ()]
343generateCase exprName decider jumps =
344 do labelRoot <- Var.fresh
345 decider <- generateDecider exprName labelRoot decider
346 foldM (goto labelRoot) decider jumps
350-- handle any jumps
353goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
354goto labelRoot deciderStmts (target, branch) =
355 let
356 labeledDeciderStmt =
357 LabelledStmt ()
358 (toLabel labelRoot target)
359 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
360 in
361 do code <- generateCode branch
362 return (labeledDeciderStmt : toStatementList code)
365toLabel :: String -> Int -> Id ()
366toLabel root target =
367 Id () (root ++ "_" ++ show target)
371-- turn deciders into ifs and switches
374generateDecider
375 :: String
376 -> String
377 -> Opt.Decider Opt.Choice
378 -> State Int [Statement ()]
379generateDecider exprName labelRoot decisionTree =
380 case decisionTree of
381 Opt.Leaf (Opt.Inline branch) ->
382 toStatementList <$> generateCode branch
384 Opt.Leaf (Opt.Jump target) ->
385 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
387 Opt.Chain testChain success failure ->
388 let
389 makeTest (path, test) =
390 do testExpr <- pathToTestableExpr exprName path test
391 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
392 in
393 do testExprs <- mapM makeTest testChain
394 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
395 thenBranch <- generateDecider exprName labelRoot success
396 elseBranch <- generateDecider exprName labelRoot failure
397 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
399 Opt.FanOut path edges fallback ->
400 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
401 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
402 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
403 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
406edgeToCaseClause
407 :: String
408 -> String
409 -> (DT.Test, Opt.Decider Opt.Choice)
410 -> State Int (CaseClause ())
411edgeToCaseClause exprName labelRoot (test, subTree) =
412 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
415testToExpr :: DT.Test -> Expression ()
416testToExpr test =
417 case test of
418 DT.Constructor (Var.Canonical _ tag) ->
419 StringLit () tag
421 DT.Literal (L.Chr char) ->
422 StringLit () [char]
424 DT.Literal lit ->
425 Literal.literal lit
429-- work with paths
432pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
433pathToTestableExpr root path exampleTest =
434 do accessExpr <- generateJsExpr (pathToExpr root path)
435 case exampleTest of
436 DT.Constructor _ ->
437 return (DotRef () accessExpr (Id () "ctor"))
439 DT.Literal (L.Chr _) ->
440 return (DotRef () accessExpr (Id () "valueOf") `call` [])
442 DT.Literal _ ->
443 return accessExpr
446pathToExpr :: String -> DT.Path -> Opt.Expr
447pathToExpr root fullPath =
448 go (Opt.Var (Var.local root)) fullPath
449 where
450 go expr path =
451 case path of
452 DT.Position index subpath ->
453 go (Opt.DataAccess expr index) subpath
455 DT.Field field subpath ->
456 go (Opt.Access expr field) subpath
458 DT.Empty ->
459 expr
461 DT.Alias ->
462 expr
466-- BINARY OPERATORS
469binop
470 :: Var.Canonical
471 -> Opt.Expr
472 -> Opt.Expr
473 -> State Int Code
474binop func left right =
475 do jsLeft <- generateJsExpr left
476 jsRight <- generateJsExpr right
477 jsExpr (makeExpr func jsLeft jsRight)
481-- BINARY OPERATOR HELPERS
484makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
485makeExpr qualifiedOp@(Var.Canonical home op) =
486 let
487 simpleMake left right =
488 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
489 in
490 if home == Var.Module (ModuleName.inCore ["Basics"]) then
491 Map.findWithDefault simpleMake op basicOps
492 else
493 simpleMake
496basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
497basicOps =
498 Map.fromList (infixOps ++ specialOps)
501infixOps :: [(String, Expression () -> Expression () -> Expression ())]
502infixOps =
503 let
504 infixOp str op =
505 (str, InfixExpr () op)
506 in
507 [ infixOp "+" OpAdd
508 , infixOp "-" OpSub
509 , infixOp "*" OpMul
510 , infixOp "/" OpDiv
511 , infixOp "&&" OpLAnd
512 , infixOp "||" OpLOr
513 ]
516specialOps :: [(String, Expression () -> Expression () -> Expression ())]
517specialOps =
518 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
519 , (,) "==" $ \a b -> BuiltIn.eq a b
520 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
521 , (,) "<" $ cmp OpLT 0
522 , (,) ">" $ cmp OpGT 0
523 , (,) "<=" $ cmp OpLT 1
524 , (,) ">=" $ cmp OpGT (-1)
525 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
526 ]
529cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
530cmp op n a b =
531 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)