git.iko.soy/elk
on 3008387 help sign in
elk/src/Generate/JavaScript.hs
514 lines 15 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 edges fallback ->
375 do accessExpr <- generateJsExpr (pathToExpr root testPath)
377 let testExpr =
378 case fst (head edges) of
379 DT.Constructor _ ->
380 DotRef () accessExpr (Id () "ctor")
382 DT.Literal _ ->
383 accessExpr
385 caseClauses <- mapM (edgeToCaseClause root) edges
386 caseDefault <- fallbackToDefault root fallback
388 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
391edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
392edgeToCaseClause root (test, subTree) =
393 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
396testToExpr :: DT.Test -> Expression ()
397testToExpr test =
398 case test of
399 DT.Constructor (Var.Canonical _ tag) ->
400 StringLit () tag
402 DT.Literal (L.Chr char) ->
403 StringLit () [char]
405 DT.Literal lit ->
406 Literal.literal lit
409fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
410fallbackToDefault root fallback =
411 case fallback of
412 Nothing ->
413 return []
415 Just subTree ->
416 do stmts <- generateDecisionTree root subTree
417 return [ CaseDefault () stmts ]
420generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
421generateBranch root (Opt.Branch substitutions expr) =
422 do subts <- mapM (loadPath root) substitutions
423 code <- generateCode expr
424 return (subts ++ toStatementList code)
427loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
428loadPath root (name, path) =
429 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
430 return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
433pathToExpr :: String -> DT.Path -> Opt.Expr
434pathToExpr root fullPath =
435 go (Opt.Var (Var.local root)) fullPath
436 where
437 go expr path =
438 case path of
439 DT.Position index subpath ->
440 go (Opt.DataAccess expr index) subpath
442 DT.Field field subpath ->
443 go (Opt.Access expr field) subpath
445 DT.Empty ->
446 expr
448 DT.Alias ->
449 expr
452-- BINARY OPERATORS
454binop
455 :: Var.Canonical
456 -> Opt.Expr
457 -> Opt.Expr
458 -> State Int Code
459binop func left right =
460 do jsLeft <- generateJsExpr left
461 jsRight <- generateJsExpr right
462 jsExpr (makeExpr func jsLeft jsRight)
465-- BINARY OPERATOR HELPERS
467makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
468makeExpr qualifiedOp@(Var.Canonical home op) =
469 let
470 simpleMake left right =
471 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
472 in
473 if home == Var.Module (ModuleName.inCore ["Basics"]) then
474 Map.findWithDefault simpleMake op basicOps
475 else
476 simpleMake
479basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
480basicOps =
481 Map.fromList (infixOps ++ specialOps)
484infixOps :: [(String, Expression () -> Expression () -> Expression ())]
485infixOps =
486 let
487 infixOp str op =
488 (str, InfixExpr () op)
489 in
490 [ infixOp "+" OpAdd
491 , infixOp "-" OpSub
492 , infixOp "*" OpMul
493 , infixOp "/" OpDiv
494 , infixOp "&&" OpLAnd
495 , infixOp "||" OpLOr
496 ]
499specialOps :: [(String, Expression () -> Expression () -> Expression ())]
500specialOps =
501 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
502 , (,) "==" $ \a b -> BuiltIn.eq a b
503 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
504 , (,) "<" $ cmp OpLT 0
505 , (,) ">" $ cmp OpGT 0
506 , (,) "<=" $ cmp OpLT 1
507 , (,) ">=" $ cmp OpGT (-1)
508 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
509 ]
512cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
513cmp op n a b =
514 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)