git.iko.soy/elk
on a44041b help sign in
elk/src/Generate/JavaScript/Expression.hs
508 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
21-- 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` []
80-- DEFINITIONS
83generateDef :: Opt.Def -> State Int [Statement ()]
84generateDef def =
85 do (home, name, jsBody) <-
86 case def of
87 Opt.TailDef (Opt.Facts home _) name argNames body ->
88 (,,) home name <$> generateTailFunction name argNames body
90 Opt.Def (Opt.Facts home _) name body ->
91 (,,) home name <$> generateJsExpr body
93 return (Var.define home name jsBody)
97-- EXPRESSIONS
100generateJsExpr :: Opt.Expr -> State Int (Expression ())
101generateJsExpr optExpr =
102 toExpr <$> generateCode optExpr
105generateCode :: Opt.Expr -> State Int Code
106generateCode expr =
107 case expr of
108 Var var ->
109 jsExpr $ Var.canonical var
111 Literal lit ->
112 jsExpr (Literal.literal lit)
114 Range lo hi ->
115 do lo' <- generateJsExpr lo
116 hi' <- generateJsExpr hi
117 jsExpr $ BuiltIn.range lo' hi'
119 Access record field ->
120 do record' <- generateJsExpr record
121 jsExpr $ DotRef () record' (var (Var.safe field))
123 Update record fields ->
124 let
125 fieldToJs (field, value) =
126 do jsValue <- generateJsExpr value
127 return (Var.safe field, jsValue)
128 in
129 do jsRecord <- generateJsExpr record
130 jsFields <- mapM fieldToJs fields
131 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
133 Record fields ->
134 let
135 toField (field, value) =
136 do jsValue <- generateJsExpr value
137 return (prop (Var.safe field), jsValue)
138 in
139 do jsFields <- mapM toField fields
140 jsExpr $ ObjectLit () jsFields
142 Binop op leftExpr rightExpr ->
143 binop op leftExpr rightExpr
145 Function args body ->
146 generateFunction args body
148 Call func args ->
149 let
150 arity = length args
151 aN = "A" ++ show arity
152 in
153 do jsFunc <- generateJsExpr func
154 jsArgs <- mapM generateJsExpr args
155 jsExpr $
156 if 2 <= arity && arity <= 9 then
157 ref aN `call` (jsFunc:jsArgs)
158 else
159 foldl1 (<|) (jsFunc:jsArgs)
161 TailCall name argNames args ->
162 let
163 reassign name tempName =
164 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
165 in
166 do args' <- mapM generateJsExpr args
167 tempNames <- mapM (\_ -> Var.fresh) args
168 jsBlock $
169 VarDeclStmt () (zipWith varDecl tempNames args')
170 : zipWith reassign argNames tempNames
171 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
173 Let defs body ->
174 do stmts <- mapM generateDef defs
175 code <- generateCode body
176 jsBlock (concat stmts ++ toStatementList code)
178 If branches finally ->
179 generateIf branches finally
181 Case exprName decider jumps ->
182 JsBlock <$> generateCase exprName decider jumps
184 ExplicitList elements ->
185 do jsElements <- mapM generateJsExpr elements
186 jsExpr $ BuiltIn.list jsElements
188 Data tag members ->
189 do jsMembers <- mapM generateJsExpr members
190 jsExpr $ ObjectLit () (ctor : fields jsMembers)
191 where
192 ctor = (prop "ctor", StringLit () tag)
193 fields =
194 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
196 DataAccess dataExpr index ->
197 do jsDataExpr <- generateJsExpr dataExpr
198 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
200 Cmd moduleName ->
201 jsExpr $ BuiltIn.cmd moduleName
203 Sub moduleName ->
204 jsExpr $ BuiltIn.sub moduleName
206 GLShader _uid src _tipe ->
207 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
209 Crash home region maybeBranchProblem ->
210 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
211 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
215-- 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 () (Var.safe 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
253-- GENERATE IFS
256generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
257generateIf givenBranches givenFinally =
258 let
259 (branches, finally) =
260 crushIfs givenBranches givenFinally
262 convertBranch (condition, expr) =
263 (,) <$> generateJsExpr condition <*> generateCode expr
265 ifExpression (condition, branch) otherwise =
266 CondExpr () condition branch otherwise
268 ifStatement (condition, branch) otherwise =
269 IfStmt () condition branch otherwise
270 in
271 do jsBranches <- mapM convertBranch branches
272 jsFinally <- generateCode finally
274 if any isBlock (jsFinally : map snd jsBranches)
275 then
276 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
277 else
278 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
281crushIfs
282 :: [(Opt.Expr, Opt.Expr)]
283 -> Opt.Expr
284 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
285crushIfs branches finally =
286 crushIfsHelp [] branches finally
289crushIfsHelp
290 :: [(Opt.Expr, Opt.Expr)]
291 -> [(Opt.Expr, Opt.Expr)]
292 -> Opt.Expr
293 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
294crushIfsHelp visitedBranches unvisitedBranches finally =
295 case unvisitedBranches of
296 [] ->
297 case finally of
298 If subBranches subFinally ->
299 crushIfsHelp visitedBranches subBranches subFinally
301 _ ->
302 (reverse visitedBranches, finally)
304 (Literal (L.Boolean True), branch) : _ ->
305 crushIfsHelp visitedBranches [] branch
307 visiting : unvisited ->
308 crushIfsHelp (visiting : visitedBranches) unvisited finally
312-- CASE EXPRESSIONS
315generateCase
316 :: String
317 -> Opt.Decider Opt.Choice
318 -> [(Int, Opt.Expr)]
319 -> State Int [Statement ()]
320generateCase exprName decider jumps =
321 do labelRoot <- Var.fresh
322 decider <- generateDecider exprName labelRoot decider
323 foldM (goto labelRoot) decider jumps
327-- handle any jumps
330goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
331goto labelRoot deciderStmts (target, branch) =
332 let
333 labeledDeciderStmt =
334 LabelledStmt ()
335 (toLabel labelRoot target)
336 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
337 in
338 do code <- generateCode branch
339 return (labeledDeciderStmt : toStatementList code)
342toLabel :: String -> Int -> Id ()
343toLabel root target =
344 Id () (root ++ "_" ++ show target)
348-- turn deciders into ifs and switches
351generateDecider
352 :: String
353 -> String
354 -> Opt.Decider Opt.Choice
355 -> State Int [Statement ()]
356generateDecider exprName labelRoot decisionTree =
357 case decisionTree of
358 Opt.Leaf (Opt.Inline branch) ->
359 toStatementList <$> generateCode branch
361 Opt.Leaf (Opt.Jump target) ->
362 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
364 Opt.Chain testChain success failure ->
365 let
366 makeTest (path, test) =
367 do testExpr <- pathToTestableExpr exprName path test
368 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
369 in
370 do testExprs <- mapM makeTest testChain
371 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
372 thenBranch <- generateDecider exprName labelRoot success
373 elseBranch <- generateDecider exprName labelRoot failure
374 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
376 Opt.FanOut path edges fallback ->
377 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
378 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
379 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
380 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
383edgeToCaseClause
384 :: String
385 -> String
386 -> (DT.Test, Opt.Decider Opt.Choice)
387 -> State Int (CaseClause ())
388edgeToCaseClause exprName labelRoot (test, subTree) =
389 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
392testToExpr :: DT.Test -> Expression ()
393testToExpr test =
394 case test of
395 DT.Constructor (Var.Canonical _ tag) ->
396 StringLit () tag
398 DT.Literal (L.Chr char) ->
399 StringLit () [char]
401 DT.Literal lit ->
402 Literal.literal lit
406-- work with paths
409pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
410pathToTestableExpr root path exampleTest =
411 do accessExpr <- generateJsExpr (pathToExpr root path)
412 case exampleTest of
413 DT.Constructor _ ->
414 return (DotRef () accessExpr (Id () "ctor"))
416 DT.Literal (L.Chr _) ->
417 return (DotRef () accessExpr (Id () "valueOf") `call` [])
419 DT.Literal _ ->
420 return accessExpr
423pathToExpr :: String -> DT.Path -> Opt.Expr
424pathToExpr root fullPath =
425 go (Opt.Var (Var.local root)) fullPath
426 where
427 go expr path =
428 case path of
429 DT.Position index subpath ->
430 go (Opt.DataAccess expr index) subpath
432 DT.Field field subpath ->
433 go (Opt.Access expr field) subpath
435 DT.Empty ->
436 expr
438 DT.Alias ->
439 expr
443-- BINARY OPERATORS
446binop
447 :: Var.Canonical
448 -> Opt.Expr
449 -> Opt.Expr
450 -> State Int Code
451binop func left right =
452 do jsLeft <- generateJsExpr left
453 jsRight <- generateJsExpr right
454 jsExpr (makeExpr func jsLeft jsRight)
458-- BINARY OPERATOR HELPERS
461makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
462makeExpr qualifiedOp@(Var.Canonical home op) =
463 let
464 simpleMake left right =
465 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
466 in
467 if home == Var.Module (ModuleName.inCore ["Basics"]) then
468 Map.findWithDefault simpleMake op basicOps
469 else
470 simpleMake
473basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
474basicOps =
475 Map.fromList (infixOps ++ specialOps)
478infixOps :: [(String, Expression () -> Expression () -> Expression ())]
479infixOps =
480 let
481 infixOp str op =
482 (str, InfixExpr () op)
483 in
484 [ infixOp "+" OpAdd
485 , infixOp "-" OpSub
486 , infixOp "*" OpMul
487 , infixOp "/" OpDiv
488 , infixOp "&&" OpLAnd
489 , infixOp "||" OpLOr
490 ]
493specialOps :: [(String, Expression () -> Expression () -> Expression ())]
494specialOps =
495 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
496 , (,) "==" $ \a b -> BuiltIn.eq a b
497 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
498 , (,) "<" $ cmp OpLT 0
499 , (,) ">" $ cmp OpGT 0
500 , (,) "<=" $ cmp OpLT 1
501 , (,) ">=" $ cmp OpGT (-1)
502 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
503 ]
506cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
507cmp op n a b =
508 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)