git.iko.soy/elk
on d163289 help sign in
elk/src/Generate/JavaScript/Expression.hs
480 lines 14 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.Optimized as Opt
10import qualified AST.Literal as L
11import qualified AST.Module.Name as ModuleName
12import qualified AST.Variable as Var
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.JavaScript.BuiltIn as BuiltIn
15import qualified Generate.JavaScript.Literal as Literal
16import qualified Generate.JavaScript.Variable as Var
17import qualified Optimize.DecisionTree as DT
20-- CODE CHUNKS
22data Code
23 = JsExpr (Expression ())
24 | JsBlock [Statement ()]
27jsExpr :: Expression () -> State Int Code
28jsExpr exp =
29 return (JsExpr exp)
32jsBlock :: [Statement ()] -> State Int Code
33jsBlock exp =
34 return (JsBlock exp)
37isBlock :: Code -> Bool
38isBlock code =
39 case code of
40 JsBlock _ -> True
41 JsExpr _ -> False
44toStatementList :: Code -> [Statement ()]
45toStatementList code =
46 case code of
47 JsExpr expr ->
48 [ ReturnStmt () (Just expr) ]
50 JsBlock stmts ->
51 stmts
54toStatement :: Code -> Statement ()
55toStatement code =
56 case code of
57 JsExpr expr ->
58 ReturnStmt () (Just expr)
60 JsBlock [stmt] ->
61 stmt
63 JsBlock stmts ->
64 BlockStmt () stmts
67toExpr :: Code -> Expression ()
68toExpr code =
69 case code of
70 JsExpr expr ->
71 expr
73 JsBlock stmts ->
74 function [] stmts `call` []
77-- DEFINITIONS
79generateDef :: Opt.Def -> State Int (Statement ())
80generateDef def =
81 do (home, name, jsBody) <-
82 case def of
83 Opt.TailDef (Opt.Facts home _) name argNames body ->
84 (,,) home name <$> generateTailFunction name argNames body
86 Opt.Def (Opt.Facts home _) name body ->
87 (,,) home name <$> generateJsExpr body
89 return (Var.define name jsBody)
92-- EXPRESSIONS
94generateJsExpr :: Opt.Expr -> State Int (Expression ())
95generateJsExpr optExpr =
96 toExpr <$> generateCode optExpr
99generateCode :: Opt.Expr -> State Int Code
100generateCode expr =
101 case expr of
102 Var var ->
103 jsExpr $ Var.canonical var
105 Literal lit ->
106 jsExpr (Literal.literal lit)
108 Range lo hi ->
109 do lo' <- generateJsExpr lo
110 hi' <- generateJsExpr hi
111 jsExpr $ BuiltIn.range lo' hi'
113 Access record field ->
114 do record' <- generateJsExpr record
115 jsExpr $ DotRef () record' (var (Var.safe field))
117 Update record fields ->
118 let
119 fieldToJs (field, value) =
120 do jsValue <- generateJsExpr value
121 return (Var.safe field, jsValue)
122 in
123 do jsRecord <- generateJsExpr record
124 jsFields <- mapM fieldToJs fields
125 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
127 Record fields ->
128 let
129 toField (field, value) =
130 do jsValue <- generateJsExpr value
131 return (prop (Var.safe field), jsValue)
132 in
133 do jsFields <- mapM toField fields
134 jsExpr $ ObjectLit () jsFields
136 Binop op leftExpr rightExpr ->
137 binop op leftExpr rightExpr
139 Function args body ->
140 generateFunction args body
142 Call func args ->
143 let
144 arity = length args
145 aN = "A" ++ show arity
146 in
147 do jsFunc <- generateJsExpr func
148 jsArgs <- mapM generateJsExpr args
149 jsExpr $
150 if 2 <= arity && arity <= 9 then
151 ref aN `call` (jsFunc:jsArgs)
152 else
153 foldl1 (<|) (jsFunc:jsArgs)
155 TailCall name argNames args ->
156 let
157 reassign name tempName =
158 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
159 in
160 do args' <- mapM generateJsExpr args
161 tempNames <- mapM (\_ -> Var.fresh) args
162 jsBlock $
163 VarDeclStmt () (zipWith varDecl tempNames args')
164 : zipWith reassign argNames tempNames
165 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
167 Let defs body ->
168 do stmts <- mapM generateDef defs
169 code <- generateCode body
170 jsBlock (stmts ++ toStatementList code)
172 If branches finally ->
173 generateIf branches finally
175 Case exprName decider jumps ->
176 JsBlock <$> generateCase exprName decider jumps
178 ExplicitList elements ->
179 do jsElements <- mapM generateJsExpr elements
180 jsExpr $ BuiltIn.list jsElements
182 Data tag members ->
183 do jsMembers <- mapM generateJsExpr members
184 jsExpr $ ObjectLit () (ctor : fields jsMembers)
185 where
186 ctor = (prop "ctor", StringLit () tag)
187 fields =
188 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
190 DataAccess dataExpr index ->
191 do jsDataExpr <- generateJsExpr dataExpr
192 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
194 GLShader _uid src _tipe ->
195 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
197 Crash home region maybeBranchProblem ->
198 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
199 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
202-- FUNCTIONS
204generateFunction :: [String] -> Opt.Expr -> State Int Code
205generateFunction args body =
206 do code <- generateCode body
207 jsExpr (generateFunctionWithArity args code)
210generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
211generateTailFunction name args body =
212 do code <- generateCode body
213 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
214 LabelledStmt ()
215 (Id () (Var.safe name))
216 (WhileStmt () (BoolLit () True) (toStatement code))
219generateFunctionWithArity :: [String] -> Code -> Expression ()
220generateFunctionWithArity rawArgs code =
221 let
222 args = map Var.safe rawArgs
223 arity = length args
224 in
225 if 2 <= arity && arity <= 9 then
226 let
227 fN = "F" ++ show arity
228 in
229 ref fN <| function args (toStatementList code)
230 else
231 let
232 (lastArg:otherArgs) = reverse args
233 innerBody = function [lastArg] (toStatementList code)
234 in
235 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
238-- GENERATE IFS
240generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
241generateIf givenBranches givenFinally =
242 let
243 (branches, finally) =
244 crushIfs givenBranches givenFinally
246 convertBranch (condition, expr) =
247 (,) <$> generateJsExpr condition <*> generateCode expr
249 ifExpression (condition, branch) otherwise =
250 CondExpr () condition branch otherwise
252 ifStatement (condition, branch) otherwise =
253 IfStmt () condition branch otherwise
254 in
255 do jsBranches <- mapM convertBranch branches
256 jsFinally <- generateCode finally
258 if any isBlock (jsFinally : map snd jsBranches)
259 then
260 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
261 else
262 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
265crushIfs
266 :: [(Opt.Expr, Opt.Expr)]
267 -> Opt.Expr
268 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
269crushIfs branches finally =
270 crushIfsHelp [] branches finally
273crushIfsHelp
274 :: [(Opt.Expr, Opt.Expr)]
275 -> [(Opt.Expr, Opt.Expr)]
276 -> Opt.Expr
277 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
278crushIfsHelp visitedBranches unvisitedBranches finally =
279 case unvisitedBranches of
280 [] ->
281 case finally of
282 If subBranches subFinally ->
283 crushIfsHelp visitedBranches subBranches subFinally
285 _ ->
286 (reverse visitedBranches, finally)
288 (Literal (L.Boolean True), branch) : _ ->
289 crushIfsHelp visitedBranches [] branch
291 visiting : unvisited ->
292 crushIfsHelp (visiting : visitedBranches) unvisited finally
295-- CASE EXPRESSIONS
297generateCase
298 :: String
299 -> Opt.Decider Opt.Choice
300 -> [(Int, Opt.Expr)]
301 -> State Int [Statement ()]
302generateCase exprName decider jumps =
303 do labelRoot <- Var.fresh
304 decider <- generateDecider exprName labelRoot decider
305 foldM (goto labelRoot) decider jumps
308-- handle any jumps
310goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
311goto labelRoot deciderStmts (target, branch) =
312 let
313 labeledDeciderStmt =
314 LabelledStmt ()
315 (toLabel labelRoot target)
316 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
317 in
318 do code <- generateCode branch
319 return (labeledDeciderStmt : toStatementList code)
322toLabel :: String -> Int -> Id ()
323toLabel root target =
324 Id () (root ++ "_" ++ show target)
327-- turn deciders into ifs and switches
329generateDecider
330 :: String
331 -> String
332 -> Opt.Decider Opt.Choice
333 -> State Int [Statement ()]
334generateDecider exprName labelRoot decisionTree =
335 case decisionTree of
336 Opt.Leaf (Opt.Inline branch) ->
337 toStatementList <$> generateCode branch
339 Opt.Leaf (Opt.Jump target) ->
340 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
342 Opt.Chain testChain success failure ->
343 let
344 makeTest (path, test) =
345 do testExpr <- pathToTestableExpr exprName path test
346 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
347 in
348 do testExprs <- mapM makeTest testChain
349 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
350 thenBranch <- generateDecider exprName labelRoot success
351 elseBranch <- generateDecider exprName labelRoot failure
352 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
354 Opt.FanOut path edges fallback ->
355 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
356 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
357 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
358 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
361edgeToCaseClause
362 :: String
363 -> String
364 -> (DT.Test, Opt.Decider Opt.Choice)
365 -> State Int (CaseClause ())
366edgeToCaseClause exprName labelRoot (test, subTree) =
367 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
370testToExpr :: DT.Test -> Expression ()
371testToExpr test =
372 case test of
373 DT.Constructor (Var.Canonical _ tag) ->
374 StringLit () tag
376 DT.Literal (L.Chr char) ->
377 StringLit () [char]
379 DT.Literal lit ->
380 Literal.literal lit
383-- work with paths
385pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
386pathToTestableExpr root path exampleTest =
387 do accessExpr <- generateJsExpr (pathToExpr root path)
388 case exampleTest of
389 DT.Constructor _ ->
390 return (DotRef () accessExpr (Id () "ctor"))
392 DT.Literal (L.Chr _) ->
393 return (DotRef () accessExpr (Id () "valueOf") `call` [])
395 DT.Literal _ ->
396 return accessExpr
399pathToExpr :: String -> DT.Path -> Opt.Expr
400pathToExpr root fullPath =
401 go (Opt.Var (Var.local root)) fullPath
402 where
403 go expr path =
404 case path of
405 DT.Position index subpath ->
406 go (Opt.DataAccess expr index) subpath
408 DT.Field field subpath ->
409 go (Opt.Access expr field) subpath
411 DT.Empty ->
412 expr
414 DT.Alias ->
415 expr
418-- BINARY OPERATORS
420binop
421 :: Var.Canonical
422 -> Opt.Expr
423 -> Opt.Expr
424 -> State Int Code
425binop func left right =
426 do jsLeft <- generateJsExpr left
427 jsRight <- generateJsExpr right
428 jsExpr (makeExpr func jsLeft jsRight)
431-- BINARY OPERATOR HELPERS
433makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
434makeExpr qualifiedOp@(Var.Canonical home op) =
435 let
436 simpleMake left right =
437 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
438 in
439 if home == Var.Module (ModuleName.inCore ["Basics"]) then
440 Map.findWithDefault simpleMake op basicOps
441 else
442 simpleMake
445basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
446basicOps =
447 Map.fromList (infixOps ++ specialOps)
450infixOps :: [(String, Expression () -> Expression () -> Expression ())]
451infixOps =
452 let
453 infixOp str op =
454 (str, InfixExpr () op)
455 in
456 [ infixOp "+" OpAdd
457 , infixOp "-" OpSub
458 , infixOp "*" OpMul
459 , infixOp "/" OpDiv
460 , infixOp "&&" OpLAnd
461 , infixOp "||" OpLOr
462 ]
465specialOps :: [(String, Expression () -> Expression () -> Expression ())]
466specialOps =
467 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
468 , (,) "==" $ \a b -> BuiltIn.eq a b
469 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
470 , (,) "<" $ cmp OpLT 0
471 , (,) ">" $ cmp OpGT 0
472 , (,) "<=" $ cmp OpLT 1
473 , (,) ">=" $ cmp OpGT (-1)
474 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
475 ]
478cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
479cmp op n a b =
480 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)