git.iko.soy/elk
on 317d3b8 help sign in
elk/src/Generate/JavaScript/Expression.hs
491 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.Patterns.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 () 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 region maybeCaseCrashValue ->
213 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
216-- FUNCTIONS
218generateFunction :: [String] -> Opt.Expr -> State Int Code
219generateFunction args body =
220 do code <- generateCode body
221 jsExpr (generateFunctionWithArity args code)
224generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
225generateTailFunction name args body =
226 do code <- generateCode body
227 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
228 LabelledStmt ()
229 (Id () name)
230 (WhileStmt () (BoolLit () True) (toStatement code))
233generateFunctionWithArity :: [String] -> Code -> Expression ()
234generateFunctionWithArity rawArgs code =
235 let
236 args = map Var.safe rawArgs
237 arity = length args
238 in
239 if 2 <= arity && arity <= 9 then
240 let
241 fN = "F" ++ show arity
242 in
243 ref fN <| function args (toStatementList code)
244 else
245 let
246 (lastArg:otherArgs) = reverse args
247 innerBody = function [lastArg] (toStatementList code)
248 in
249 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
252-- GENERATE IFS
254generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
255generateIf givenBranches givenFinally =
256 let
257 (branches, finally) =
258 crushIfs givenBranches givenFinally
260 convertBranch (condition, expr) =
261 (,) <$> generateJsExpr condition <*> generateCode expr
263 ifExpression (condition, branch) otherwise =
264 CondExpr () condition branch otherwise
266 ifStatement (condition, branch) otherwise =
267 IfStmt () condition branch otherwise
268 in
269 do jsBranches <- mapM convertBranch branches
270 jsFinally <- generateCode finally
272 if any isBlock (jsFinally : map snd jsBranches)
273 then
274 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
275 else
276 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
279crushIfs
280 :: [(Opt.Expr, Opt.Expr)]
281 -> Opt.Expr
282 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
283crushIfs branches finally =
284 crushIfsHelp [] branches finally
287crushIfsHelp
288 :: [(Opt.Expr, Opt.Expr)]
289 -> [(Opt.Expr, Opt.Expr)]
290 -> Opt.Expr
291 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
292crushIfsHelp visitedBranches unvisitedBranches finally =
293 case unvisitedBranches of
294 [] ->
295 case finally of
296 If subBranches subFinally ->
297 crushIfsHelp visitedBranches subBranches subFinally
299 _ ->
300 (reverse visitedBranches, finally)
302 (Literal (L.Boolean True), branch) : _ ->
303 crushIfsHelp visitedBranches [] branch
305 visiting : unvisited ->
306 crushIfsHelp (visiting : visitedBranches) unvisited finally
309-- CASE EXPRESSIONS
311generateCase
312 :: String
313 -> Opt.Decider Opt.Choice
314 -> [(Int, Opt.Expr)]
315 -> State Int [Statement ()]
316generateCase exprName decider jumps =
317 do labelRoot <- Var.fresh
318 decider <- generateDecider exprName labelRoot decider
319 foldM (goto labelRoot) decider jumps
322-- handle any jumps
324goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
325goto labelRoot deciderStmts (target, branch) =
326 let
327 labeledDeciderStmt =
328 LabelledStmt ()
329 (toLabel labelRoot target)
330 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
331 in
332 do code <- generateCode branch
333 return (labeledDeciderStmt : toStatementList code)
336toLabel :: String -> Int -> Id ()
337toLabel root target =
338 Id () (root ++ "_" ++ show target)
341-- turn deciders into ifs and switches
343generateDecider
344 :: String
345 -> String
346 -> Opt.Decider Opt.Choice
347 -> State Int [Statement ()]
348generateDecider exprName labelRoot decisionTree =
349 case decisionTree of
350 Opt.Leaf (Opt.Inline branch) ->
351 toStatementList <$> generateCode branch
353 Opt.Leaf (Opt.Jump target) ->
354 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
356 Opt.Chain testChain success failure ->
357 let
358 makeTest (path, test) =
359 do testExpr <- pathToTestableExpr exprName path test
360 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
361 in
362 do testExprs <- mapM makeTest testChain
363 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
364 thenBranch <- generateDecider exprName labelRoot success
365 elseBranch <- generateDecider exprName labelRoot failure
366 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
368 Opt.FanOut path edges fallback ->
369 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
370 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
371 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
372 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
375edgeToCaseClause
376 :: String
377 -> String
378 -> (DT.Test, Opt.Decider Opt.Choice)
379 -> State Int (CaseClause ())
380edgeToCaseClause exprName labelRoot (test, subTree) =
381 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
384testToExpr :: DT.Test -> Expression ()
385testToExpr test =
386 case test of
387 DT.Constructor (Var.Canonical _ tag) ->
388 StringLit () tag
390 DT.Literal (L.Chr char) ->
391 StringLit () [char]
393 DT.Literal lit ->
394 Literal.literal lit
397-- work with paths
399pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
400pathToTestableExpr root path exampleTest =
401 do accessExpr <- generateJsExpr (pathToExpr root path)
402 case exampleTest of
403 DT.Constructor _ ->
404 return (DotRef () accessExpr (Id () "ctor"))
406 DT.Literal _ ->
407 return accessExpr
410pathToExpr :: String -> DT.Path -> Opt.Expr
411pathToExpr root fullPath =
412 go (Opt.Var (Var.local root)) fullPath
413 where
414 go expr path =
415 case path of
416 DT.Position index subpath ->
417 go (Opt.DataAccess expr index) subpath
419 DT.Field field subpath ->
420 go (Opt.Access expr field) subpath
422 DT.Empty ->
423 expr
425 DT.Alias ->
426 expr
429-- BINARY OPERATORS
431binop
432 :: Var.Canonical
433 -> Opt.Expr
434 -> Opt.Expr
435 -> State Int Code
436binop func left right =
437 do jsLeft <- generateJsExpr left
438 jsRight <- generateJsExpr right
439 jsExpr (makeExpr func jsLeft jsRight)
442-- BINARY OPERATOR HELPERS
444makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
445makeExpr qualifiedOp@(Var.Canonical home op) =
446 let
447 simpleMake left right =
448 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
449 in
450 if home == Var.Module (ModuleName.inCore ["Basics"]) then
451 Map.findWithDefault simpleMake op basicOps
452 else
453 simpleMake
456basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
457basicOps =
458 Map.fromList (infixOps ++ specialOps)
461infixOps :: [(String, Expression () -> Expression () -> Expression ())]
462infixOps =
463 let
464 infixOp str op =
465 (str, InfixExpr () op)
466 in
467 [ infixOp "+" OpAdd
468 , infixOp "-" OpSub
469 , infixOp "*" OpMul
470 , infixOp "/" OpDiv
471 , infixOp "&&" OpLAnd
472 , infixOp "||" OpLOr
473 ]
476specialOps :: [(String, Expression () -> Expression () -> Expression ())]
477specialOps =
478 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
479 , (,) "==" $ \a b -> BuiltIn.eq a b
480 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
481 , (,) "<" $ cmp OpLT 0
482 , (,) ">" $ cmp OpGT 0
483 , (,) "<=" $ cmp OpLT 1
484 , (,) ">=" $ cmp OpGT (-1)
485 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
486 ]
489cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
490cmp op n a b =
491 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)