git.iko.soy/elk
on 2f77374 help sign in
elk/src/Generate/JavaScript.hs
547 lines 16 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Applicative ((<$>),(<*>))
4import Control.Arrow (first, second, (***))
5import Control.Monad.State as State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import Language.ECMAScript3.PrettyPrint as ES
9import Language.ECMAScript3.Syntax
10import qualified Text.PrettyPrint.Leijen as PP
12import qualified AST.Expression.General as Expr
13import AST.Expression.Optimized as Opt
14import qualified AST.Literal as L
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Variable as Var
18import Generate.JavaScript.Helpers as Help
19import qualified Generate.JavaScript.BuiltIn as BuiltIn
20import qualified Generate.JavaScript.Literal as Literal
21import qualified Generate.JavaScript.Port as Port
22import qualified Generate.JavaScript.Variable as Var
23import qualified Optimize.Patterns.DecisionTree as DT
26generate :: Module.Optimized -> String
27generate module_ =
28 let
29 definitions =
30 Module.program (Module.body module_)
32 setup =
33 Var.define (Just (Module.name module_)) "_op" (ObjectLit () [])
35 stmts =
36 State.evalState (mapM generateDef definitions) 0
37 in
38 PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint (setup:stmts))) ""
41-- CODE CHUNKS
43data Code
44 = JsExpr (Expression ())
45 | JsBlock [Statement ()]
48jsExpr :: Expression () -> State Int Code
49jsExpr exp =
50 return (JsExpr exp)
53jsBlock :: [Statement ()] -> State Int Code
54jsBlock exp =
55 return (JsBlock exp)
58isBlock :: Code -> Bool
59isBlock code =
60 case code of
61 JsBlock _ -> True
62 JsExpr _ -> False
65toStatementList :: Code -> [Statement ()]
66toStatementList code =
67 case code of
68 JsExpr expr ->
69 [ ret expr ]
70 JsBlock stmts ->
71 stmts
74toStatement :: Code -> Statement ()
75toStatement code =
76 case code of
77 JsExpr expr ->
78 ret expr
79 JsBlock [stmt] ->
80 stmt
81 JsBlock stmts ->
82 BlockStmt () stmts
85toExpr :: Code -> Expression ()
86toExpr code =
87 case code of
88 JsExpr expr ->
89 expr
91 JsBlock stmts ->
92 function [] stmts `call` []
95-- DEFINITIONS
97generateDef :: Opt.Def -> State Int (Statement ())
98generateDef def =
99 do (home, name, jsBody) <-
100 case def of
101 Opt.TailDef (Opt.Facts home _) name argNames body ->
102 (,,) home name <$> generateTailFunction name argNames body
104 Opt.Def (Opt.Facts home _) name body ->
105 (,,) home name <$> generateJsExpr body
107 return (Var.define home name jsBody)
110-- EXPRESSIONS
112generateJsExpr :: Opt.Expr -> State Int (Expression ())
113generateJsExpr optExpr =
114 toExpr <$> generateCode optExpr
117generateCode :: Opt.Expr -> State Int Code
118generateCode expr =
119 case expr of
120 Var var ->
121 jsExpr $ Var.canonical var
123 Literal lit ->
124 jsExpr (Literal.literal lit)
126 Range lo hi ->
127 do lo' <- generateJsExpr lo
128 hi' <- generateJsExpr hi
129 jsExpr $ BuiltIn.range lo' hi'
131 Access record field ->
132 do record' <- generateJsExpr record
133 jsExpr $ DotRef () record' (var (Var.safe field))
135 Update record fields ->
136 let
137 fieldToJs (field, value) =
138 do jsValue <- generateJsExpr value
139 return (Var.safe field, jsValue)
140 in
141 do jsRecord <- generateJsExpr record
142 jsFields <- mapM fieldToJs fields
143 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
145 Record fields ->
146 do fields' <-
147 forM fields $ \(field, e) ->
148 (,) (Var.safe field) <$> generateJsExpr e
150 let fieldMap =
151 List.foldl' combine Map.empty fields'
153 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
154 where
155 combine record (field, value) =
156 Map.insertWith (++) field [value] record
158 hidden fs =
159 ObjectLit () . map (prop *** ArrayLit ()) $
160 Map.toList (Map.filter (not . null) (Map.map tail fs))
162 visible fs =
163 map (first prop) (Map.toList (Map.map head fs))
165 Binop op leftExpr rightExpr ->
166 binop op leftExpr rightExpr
168 Function args body ->
169 generateFunction args body
171 Call func args ->
172 let
173 arity = length args
174 aN = "A" ++ show arity
175 in
176 do jsFunc <- generateJsExpr func
177 jsArgs <- mapM generateJsExpr args
178 jsExpr $
179 if 2 <= arity && arity <= 9 then
180 ref aN `call` (jsFunc:jsArgs)
181 else
182 foldl1 (<|) (jsFunc:jsArgs)
184 TailCall name argNames args ->
185 let
186 reassign name tempName =
187 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
188 in
189 do args' <- mapM generateJsExpr args
190 tempNames <- mapM (\_ -> Var.fresh) args
191 jsBlock $
192 VarDeclStmt () (zipWith varDecl tempNames args')
193 : zipWith reassign argNames tempNames
194 ++ [ContinueStmt () (Just (Id () name))]
196 Let defs body ->
197 do stmts <- mapM generateDef defs
198 code <- generateCode body
199 jsBlock (stmts ++ toStatementList code)
201 If branches finally ->
202 generateIf branches finally
204 Case root decisionTree branches ->
205 JsBlock <$> generateCase root decisionTree branches
207 ExplicitList elements ->
208 do jsElements <- mapM generateJsExpr elements
209 jsExpr $ BuiltIn.list jsElements
211 Data tag members ->
212 do jsMembers <- mapM generateJsExpr members
213 jsExpr $ ObjectLit () (ctor : fields jsMembers)
214 where
215 ctor = (prop "ctor", string tag)
216 fields =
217 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
219 DataAccess dataExpr index ->
220 do jsDataExpr <- generateJsExpr dataExpr
221 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
223 GLShader _uid src _tipe ->
224 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
226 Port impl ->
227 case impl of
228 Expr.In name portType ->
229 jsExpr (Port.inbound name portType)
231 Expr.Out name expr portType ->
232 do expr' <- generateJsExpr expr
233 jsExpr (Port.outbound name expr' portType)
235 Expr.Task name expr portType ->
236 do expr' <- generateJsExpr expr
237 jsExpr (Port.task name expr' portType)
239 Crash region maybeCaseCrashValue ->
240 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
243-- FUNCTIONS
245generateFunction :: [String] -> Opt.Expr -> State Int Code
246generateFunction args body =
247 do code <- generateCode body
248 jsExpr (generateFunctionWithArity args code)
251generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
252generateTailFunction name args body =
253 do code <- generateCode body
254 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
255 LabelledStmt ()
256 (Id () name)
257 (WhileStmt () (BoolLit () True) (toStatement code))
260generateFunctionWithArity :: [String] -> Code -> Expression ()
261generateFunctionWithArity rawArgs code =
262 let
263 args = map Var.safe rawArgs
264 arity = length args
265 in
266 if 2 <= arity && arity <= 9 then
267 let
268 fN = "F" ++ show arity
269 in
270 ref fN <| function args (toStatementList code)
271 else
272 let
273 (lastArg:otherArgs) = reverse args
274 innerBody = function [lastArg] (toStatementList code)
275 in
276 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
279-- GENERATE IFS
281generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
282generateIf givenBranches givenFinally =
283 let
284 (branches, finally) =
285 crushIfs givenBranches givenFinally
287 convertBranch (condition, expr) =
288 (,) <$> generateJsExpr condition <*> generateCode expr
290 ifExpression (condition, branch) otherwise =
291 CondExpr () condition branch otherwise
293 ifStatement (condition, branch) otherwise =
294 IfStmt () condition branch otherwise
295 in
296 do jsBranches <- mapM convertBranch branches
297 jsFinally <- generateCode finally
299 if any isBlock (jsFinally : map snd jsBranches)
300 then
301 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
302 else
303 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
306crushIfs
307 :: [(Opt.Expr, Opt.Expr)]
308 -> Opt.Expr
309 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
310crushIfs branches finally =
311 crushIfsHelp [] branches finally
314crushIfsHelp
315 :: [(Opt.Expr, Opt.Expr)]
316 -> [(Opt.Expr, Opt.Expr)]
317 -> Opt.Expr
318 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
319crushIfsHelp visitedBranches unvisitedBranches finally =
320 case unvisitedBranches of
321 [] ->
322 case finally of
323 If subBranches subFinally ->
324 crushIfsHelp visitedBranches subBranches subFinally
326 _ ->
327 (reverse visitedBranches, finally)
329 (Literal (L.Boolean True), branch) : _ ->
330 crushIfsHelp visitedBranches [] branch
332 visiting : unvisited ->
333 crushIfsHelp (visiting : visitedBranches) unvisited finally
336-- CASE EXPRESSIONS
338generateCase
339 :: String
340 -> DT.DecisionTree Opt.Jump
341 -> [(Int, Opt.Branch)]
342 -> State Int [Statement ()]
343generateCase root decisionTree jumpBranches =
344 do decider <- generateDecisionTree root decisionTree
345 foldM (goto root) decider jumpBranches
348goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
349goto root decider (target, branch) =
350 let
351 deciderStmt =
352 LabelledStmt ()
353 (targetLabel root target)
354 (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
355 in
356 do stmts <- generateBranch root branch
357 return (deciderStmt : stmts)
360targetLabel :: String -> Int -> Id ()
361targetLabel root target =
362 Id () (root ++ "_" ++ show target)
365generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
366generateDecisionTree root decisionTree =
367 case decisionTree of
368 DT.Match (Opt.Inline branch) ->
369 generateBranch root branch
371 DT.Match (Opt.Jump target) ->
372 return [ BreakStmt () (Just (targetLabel root target)) ]
374 DT.Decision testPath [(test, subTree)] (Just fallback) ->
375 let
376 (tests, deepestSubTree) =
377 collapseTests [(testPath, test)] fallback subTree
379 makeTest (path, test) =
380 do testExpr <- pathToTestableExpr root path test
381 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
382 in
383 do testExprs <- mapM makeTest tests
384 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
385 thenBranch <- generateDecisionTree root deepestSubTree
386 elseBranch <- generateDecisionTree root fallback
387 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
389 DT.Decision testPath edges fallback ->
390 do testExpr <- pathToTestableExpr root testPath (fst (head edges))
391 caseClauses <- mapM (edgeToCaseClause root) edges
392 caseDefault <- fallbackToDefault root fallback
393 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
396collapseTests
397 :: [(DT.Path, DT.Test)]
398 -> DT.DecisionTree Opt.Jump
399 -> DT.DecisionTree Opt.Jump
400 -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
401collapseTests tests outerFallback decisionTree =
402 case decisionTree of
403 DT.Decision testPath [(test, subTree)] (Just fallback)
404 | fallback == outerFallback ->
405 collapseTests ((testPath, test) : tests) outerFallback subTree
407 _ ->
408 (tests, decisionTree)
411edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
412edgeToCaseClause root (test, subTree) =
413 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
416pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
417pathToTestableExpr root path exampleTest =
418 do accessExpr <- generateJsExpr (pathToExpr root path)
419 case exampleTest of
420 DT.Constructor _ ->
421 return (DotRef () accessExpr (Id () "ctor"))
423 DT.Literal _ ->
424 return accessExpr
427testToExpr :: DT.Test -> Expression ()
428testToExpr test =
429 case test of
430 DT.Constructor (Var.Canonical _ tag) ->
431 StringLit () tag
433 DT.Literal (L.Chr char) ->
434 StringLit () [char]
436 DT.Literal lit ->
437 Literal.literal lit
440fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
441fallbackToDefault root fallback =
442 case fallback of
443 Nothing ->
444 return []
446 Just subTree ->
447 do stmts <- generateDecisionTree root subTree
448 return [ CaseDefault () stmts ]
451generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
452generateBranch root (Opt.Branch substitutions expr) =
453 do substs <- mapM (loadPath root) substitutions
454 let substStmts =
455 if null substs then [] else [ VarDeclStmt () substs ]
456 code <- generateCode expr
457 return (substStmts ++ toStatementList code)
460loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
461loadPath root (name, path) =
462 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
463 return $ varDecl (Var.safe name) jsAccessExpr
466pathToExpr :: String -> DT.Path -> Opt.Expr
467pathToExpr root fullPath =
468 go (Opt.Var (Var.local root)) fullPath
469 where
470 go expr path =
471 case path of
472 DT.Position index subpath ->
473 go (Opt.DataAccess expr index) subpath
475 DT.Field field subpath ->
476 go (Opt.Access expr field) subpath
478 DT.Empty ->
479 expr
481 DT.Alias ->
482 expr
485-- BINARY OPERATORS
487binop
488 :: Var.Canonical
489 -> Opt.Expr
490 -> Opt.Expr
491 -> State Int Code
492binop func left right =
493 do jsLeft <- generateJsExpr left
494 jsRight <- generateJsExpr right
495 jsExpr (makeExpr func jsLeft jsRight)
498-- BINARY OPERATOR HELPERS
500makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
501makeExpr qualifiedOp@(Var.Canonical home op) =
502 let
503 simpleMake left right =
504 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
505 in
506 if home == Var.Module (ModuleName.inCore ["Basics"]) then
507 Map.findWithDefault simpleMake op basicOps
508 else
509 simpleMake
512basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
513basicOps =
514 Map.fromList (infixOps ++ specialOps)
517infixOps :: [(String, Expression () -> Expression () -> Expression ())]
518infixOps =
519 let
520 infixOp str op =
521 (str, InfixExpr () op)
522 in
523 [ infixOp "+" OpAdd
524 , infixOp "-" OpSub
525 , infixOp "*" OpMul
526 , infixOp "/" OpDiv
527 , infixOp "&&" OpLAnd
528 , infixOp "||" OpLOr
529 ]
532specialOps :: [(String, Expression () -> Expression () -> Expression ())]
533specialOps =
534 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
535 , (,) "==" $ \a b -> BuiltIn.eq a b
536 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
537 , (,) "<" $ cmp OpLT 0
538 , (,) ">" $ cmp OpGT 0
539 , (,) "<=" $ cmp OpLT 1
540 , (,) ">=" $ cmp OpGT (-1)
541 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
542 ]
545cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
546cmp op n a b =
547 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)