git.iko.soy/elk
on 353930a help sign in
elk/src/Generate/JavaScript/Expression.hs
495 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 qualified AST.Expression.General as Expr
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.Literal as Literal
17import qualified Generate.JavaScript.Port as Port
18import qualified Generate.JavaScript.Variable as Var
19import qualified Optimize.DecisionTree as DT
22-- CODE CHUNKS
24data Code
25 = JsExpr (Expression ())
26 | JsBlock [Statement ()]
29jsExpr :: Expression () -> State Int Code
30jsExpr exp =
31 return (JsExpr exp)
34jsBlock :: [Statement ()] -> State Int Code
35jsBlock exp =
36 return (JsBlock exp)
39isBlock :: Code -> Bool
40isBlock code =
41 case code of
42 JsBlock _ -> True
43 JsExpr _ -> False
46toStatementList :: Code -> [Statement ()]
47toStatementList code =
48 case code of
49 JsExpr expr ->
50 [ ReturnStmt () (Just expr) ]
52 JsBlock stmts ->
53 stmts
56toStatement :: Code -> Statement ()
57toStatement code =
58 case code of
59 JsExpr expr ->
60 ReturnStmt () (Just expr)
62 JsBlock [stmt] ->
63 stmt
65 JsBlock stmts ->
66 BlockStmt () stmts
69toExpr :: Code -> Expression ()
70toExpr code =
71 case code of
72 JsExpr expr ->
73 expr
75 JsBlock stmts ->
76 function [] stmts `call` []
79-- DEFINITIONS
81generateDef :: Opt.Def -> State Int (Statement ())
82generateDef def =
83 do (home, name, jsBody) <-
84 case def of
85 Opt.TailDef (Opt.Facts home _) name argNames body ->
86 (,,) home name <$> generateTailFunction name argNames body
88 Opt.Def (Opt.Facts home _) name body ->
89 (,,) home name <$> generateJsExpr body
91 return (Var.define name jsBody)
94-- EXPRESSIONS
96generateJsExpr :: Opt.Expr -> State Int (Expression ())
97generateJsExpr optExpr =
98 toExpr <$> generateCode optExpr
101generateCode :: Opt.Expr -> State Int Code
102generateCode expr =
103 case expr of
104 Var var ->
105 jsExpr $ Var.canonical var
107 Literal lit ->
108 jsExpr (Literal.literal lit)
110 Range lo hi ->
111 do lo' <- generateJsExpr lo
112 hi' <- generateJsExpr hi
113 jsExpr $ BuiltIn.range lo' hi'
115 Access record field ->
116 do record' <- generateJsExpr record
117 jsExpr $ DotRef () record' (var (Var.safe field))
119 Update record fields ->
120 let
121 fieldToJs (field, value) =
122 do jsValue <- generateJsExpr value
123 return (Var.safe field, jsValue)
124 in
125 do jsRecord <- generateJsExpr record
126 jsFields <- mapM fieldToJs fields
127 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
129 Record fields ->
130 let
131 toField (field, value) =
132 do jsValue <- generateJsExpr value
133 return (prop (Var.safe field), jsValue)
134 in
135 do jsFields <- mapM toField fields
136 jsExpr $ ObjectLit () jsFields
138 Binop op leftExpr rightExpr ->
139 binop op leftExpr rightExpr
141 Function args body ->
142 generateFunction args body
144 Call func args ->
145 let
146 arity = length args
147 aN = "A" ++ show arity
148 in
149 do jsFunc <- generateJsExpr func
150 jsArgs <- mapM generateJsExpr args
151 jsExpr $
152 if 2 <= arity && arity <= 9 then
153 ref aN `call` (jsFunc:jsArgs)
154 else
155 foldl1 (<|) (jsFunc:jsArgs)
157 TailCall name argNames args ->
158 let
159 reassign name tempName =
160 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
161 in
162 do args' <- mapM generateJsExpr args
163 tempNames <- mapM (\_ -> Var.fresh) args
164 jsBlock $
165 VarDeclStmt () (zipWith varDecl tempNames args')
166 : zipWith reassign argNames tempNames
167 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
169 Let defs body ->
170 do stmts <- mapM generateDef defs
171 code <- generateCode body
172 jsBlock (stmts ++ toStatementList code)
174 If branches finally ->
175 generateIf branches finally
177 Case exprName decider jumps ->
178 JsBlock <$> generateCase exprName decider jumps
180 ExplicitList elements ->
181 do jsElements <- mapM generateJsExpr elements
182 jsExpr $ BuiltIn.list jsElements
184 Data tag members ->
185 do jsMembers <- mapM generateJsExpr members
186 jsExpr $ ObjectLit () (ctor : fields jsMembers)
187 where
188 ctor = (prop "ctor", StringLit () tag)
189 fields =
190 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
192 DataAccess dataExpr index ->
193 do jsDataExpr <- generateJsExpr dataExpr
194 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
196 GLShader _uid src _tipe ->
197 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
199 Port impl ->
200 case impl of
201 Expr.In name portType ->
202 jsExpr (Port.inbound name portType)
204 Expr.Out name expr portType ->
205 do expr' <- generateJsExpr expr
206 jsExpr (Port.outbound name expr' portType)
208 Expr.Task name expr portType ->
209 do expr' <- generateJsExpr expr
210 jsExpr (Port.task name expr' portType)
212 Crash home region maybeBranchProblem ->
213 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
214 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
217-- FUNCTIONS
219generateFunction :: [String] -> Opt.Expr -> State Int Code
220generateFunction args body =
221 do code <- generateCode body
222 jsExpr (generateFunctionWithArity args code)
225generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
226generateTailFunction name args body =
227 do code <- generateCode body
228 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
229 LabelledStmt ()
230 (Id () (Var.safe name))
231 (WhileStmt () (BoolLit () True) (toStatement code))
234generateFunctionWithArity :: [String] -> Code -> Expression ()
235generateFunctionWithArity rawArgs code =
236 let
237 args = map Var.safe rawArgs
238 arity = length args
239 in
240 if 2 <= arity && arity <= 9 then
241 let
242 fN = "F" ++ show arity
243 in
244 ref fN <| function args (toStatementList code)
245 else
246 let
247 (lastArg:otherArgs) = reverse args
248 innerBody = function [lastArg] (toStatementList code)
249 in
250 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
253-- GENERATE IFS
255generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
256generateIf givenBranches givenFinally =
257 let
258 (branches, finally) =
259 crushIfs givenBranches givenFinally
261 convertBranch (condition, expr) =
262 (,) <$> generateJsExpr condition <*> generateCode expr
264 ifExpression (condition, branch) otherwise =
265 CondExpr () condition branch otherwise
267 ifStatement (condition, branch) otherwise =
268 IfStmt () condition branch otherwise
269 in
270 do jsBranches <- mapM convertBranch branches
271 jsFinally <- generateCode finally
273 if any isBlock (jsFinally : map snd jsBranches)
274 then
275 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
276 else
277 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
280crushIfs
281 :: [(Opt.Expr, Opt.Expr)]
282 -> Opt.Expr
283 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
284crushIfs branches finally =
285 crushIfsHelp [] branches finally
288crushIfsHelp
289 :: [(Opt.Expr, Opt.Expr)]
290 -> [(Opt.Expr, Opt.Expr)]
291 -> Opt.Expr
292 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
293crushIfsHelp visitedBranches unvisitedBranches finally =
294 case unvisitedBranches of
295 [] ->
296 case finally of
297 If subBranches subFinally ->
298 crushIfsHelp visitedBranches subBranches subFinally
300 _ ->
301 (reverse visitedBranches, finally)
303 (Literal (L.Boolean True), branch) : _ ->
304 crushIfsHelp visitedBranches [] branch
306 visiting : unvisited ->
307 crushIfsHelp (visiting : visitedBranches) unvisited finally
310-- CASE EXPRESSIONS
312generateCase
313 :: String
314 -> Opt.Decider Opt.Choice
315 -> [(Int, Opt.Expr)]
316 -> State Int [Statement ()]
317generateCase exprName decider jumps =
318 do labelRoot <- Var.fresh
319 decider <- generateDecider exprName labelRoot decider
320 foldM (goto labelRoot) decider jumps
323-- handle any jumps
325goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
326goto labelRoot deciderStmts (target, branch) =
327 let
328 labeledDeciderStmt =
329 LabelledStmt ()
330 (toLabel labelRoot target)
331 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
332 in
333 do code <- generateCode branch
334 return (labeledDeciderStmt : toStatementList code)
337toLabel :: String -> Int -> Id ()
338toLabel root target =
339 Id () (root ++ "_" ++ show target)
342-- turn deciders into ifs and switches
344generateDecider
345 :: String
346 -> String
347 -> Opt.Decider Opt.Choice
348 -> State Int [Statement ()]
349generateDecider exprName labelRoot decisionTree =
350 case decisionTree of
351 Opt.Leaf (Opt.Inline branch) ->
352 toStatementList <$> generateCode branch
354 Opt.Leaf (Opt.Jump target) ->
355 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
357 Opt.Chain testChain success failure ->
358 let
359 makeTest (path, test) =
360 do testExpr <- pathToTestableExpr exprName path test
361 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
362 in
363 do testExprs <- mapM makeTest testChain
364 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
365 thenBranch <- generateDecider exprName labelRoot success
366 elseBranch <- generateDecider exprName labelRoot failure
367 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
369 Opt.FanOut path edges fallback ->
370 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
371 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
372 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
373 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
376edgeToCaseClause
377 :: String
378 -> String
379 -> (DT.Test, Opt.Decider Opt.Choice)
380 -> State Int (CaseClause ())
381edgeToCaseClause exprName labelRoot (test, subTree) =
382 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
385testToExpr :: DT.Test -> Expression ()
386testToExpr test =
387 case test of
388 DT.Constructor (Var.Canonical _ tag) ->
389 StringLit () tag
391 DT.Literal (L.Chr char) ->
392 StringLit () [char]
394 DT.Literal lit ->
395 Literal.literal lit
398-- work with paths
400pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
401pathToTestableExpr root path exampleTest =
402 do accessExpr <- generateJsExpr (pathToExpr root path)
403 case exampleTest of
404 DT.Constructor _ ->
405 return (DotRef () accessExpr (Id () "ctor"))
407 DT.Literal (L.Chr _) ->
408 return (DotRef () accessExpr (Id () "valueOf") `call` [])
410 DT.Literal _ ->
411 return accessExpr
414pathToExpr :: String -> DT.Path -> Opt.Expr
415pathToExpr root fullPath =
416 go (Opt.Var (Var.local root)) fullPath
417 where
418 go expr path =
419 case path of
420 DT.Position index subpath ->
421 go (Opt.DataAccess expr index) subpath
423 DT.Field field subpath ->
424 go (Opt.Access expr field) subpath
426 DT.Empty ->
427 expr
429 DT.Alias ->
430 expr
433-- BINARY OPERATORS
435binop
436 :: Var.Canonical
437 -> Opt.Expr
438 -> Opt.Expr
439 -> State Int Code
440binop func left right =
441 do jsLeft <- generateJsExpr left
442 jsRight <- generateJsExpr right
443 jsExpr (makeExpr func jsLeft jsRight)
446-- BINARY OPERATOR HELPERS
448makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
449makeExpr qualifiedOp@(Var.Canonical home op) =
450 let
451 simpleMake left right =
452 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
453 in
454 if home == Var.Module (ModuleName.inCore ["Basics"]) then
455 Map.findWithDefault simpleMake op basicOps
456 else
457 simpleMake
460basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
461basicOps =
462 Map.fromList (infixOps ++ specialOps)
465infixOps :: [(String, Expression () -> Expression () -> Expression ())]
466infixOps =
467 let
468 infixOp str op =
469 (str, InfixExpr () op)
470 in
471 [ infixOp "+" OpAdd
472 , infixOp "-" OpSub
473 , infixOp "*" OpMul
474 , infixOp "/" OpDiv
475 , infixOp "&&" OpLAnd
476 , infixOp "||" OpLOr
477 ]
480specialOps :: [(String, Expression () -> Expression () -> Expression ())]
481specialOps =
482 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
483 , (,) "==" $ \a b -> BuiltIn.eq a b
484 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
485 , (,) "<" $ cmp OpLT 0
486 , (,) ">" $ cmp OpGT 0
487 , (,) "<=" $ cmp OpLT 1
488 , (,) ">=" $ cmp OpGT (-1)
489 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
490 ]
493cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
494cmp op n a b =
495 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)