git.iko.soy/elk
on 144a15a help sign in
elk/src/Generate/JavaScript.hs
510 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 stmts =
33 State.evalState (mapM generateDef definitions) 0
34 in
35 PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""
38-- CODE CHUNKS
40data Code
41 = JsExpr (Expression ())
42 | JsBlock [Statement ()]
45jsExpr :: Expression () -> State Int Code
46jsExpr exp =
47 return (JsExpr exp)
50jsBlock :: [Statement ()] -> State Int Code
51jsBlock exp =
52 return (JsBlock exp)
55isBlock :: Code -> Bool
56isBlock code =
57 case code of
58 JsBlock _ -> True
59 JsExpr _ -> False
62toStatementList :: Code -> [Statement ()]
63toStatementList code =
64 case code of
65 JsExpr expr ->
66 [ ret expr ]
67 JsBlock stmts ->
68 stmts
71toStatement :: Code -> Statement ()
72toStatement code =
73 case code of
74 JsExpr expr ->
75 ret expr
76 JsBlock [stmt] ->
77 stmt
78 JsBlock stmts ->
79 BlockStmt () stmts
82toExpr :: Code -> Expression ()
83toExpr code =
84 case code of
85 JsExpr expr ->
86 expr
88 JsBlock stmts ->
89 function [] stmts `call` []
92-- DEFINITIONS
94generateDef :: Opt.Def -> State Int (Statement ())
95generateDef def =
96 do (home, name, jsBody) <-
97 case def of
98 Opt.TailDef (Opt.Facts home _) name argNames body ->
99 (,,) home name <$> generateTailFunction name argNames body
101 Opt.Def (Opt.Facts home _) name body ->
102 (,,) home name <$> generateJsExpr body
104 return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])
107-- EXPRESSIONS
109generateJsExpr :: Opt.Expr -> State Int (Expression ())
110generateJsExpr optExpr =
111 toExpr <$> generateCode optExpr
114generateCode :: Opt.Expr -> State Int Code
115generateCode expr =
116 case expr of
117 Var var ->
118 jsExpr $ Var.canonical var
120 Literal lit ->
121 jsExpr (Literal.literal lit)
123 Range lo hi ->
124 do lo' <- generateJsExpr lo
125 hi' <- generateJsExpr hi
126 jsExpr $ BuiltIn.range lo' hi'
128 Access record field ->
129 do record' <- generateJsExpr record
130 jsExpr $ DotRef () record' (var (Var.safe field))
132 Update record fields ->
133 let
134 fieldToJs (field, value) =
135 do jsValue <- generateJsExpr value
136 return (Var.safe field, jsValue)
137 in
138 do jsRecord <- generateJsExpr record
139 jsFields <- mapM fieldToJs fields
140 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
142 Record fields ->
143 do fields' <-
144 forM fields $ \(field, e) ->
145 (,) (Var.safe field) <$> generateJsExpr e
147 let fieldMap =
148 List.foldl' combine Map.empty fields'
150 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
151 where
152 combine record (field, value) =
153 Map.insertWith (++) field [value] record
155 hidden fs =
156 ObjectLit () . map (prop *** ArrayLit ()) $
157 Map.toList (Map.filter (not . null) (Map.map tail fs))
159 visible fs =
160 map (first prop) (Map.toList (Map.map head fs))
162 Binop op leftExpr rightExpr ->
163 binop op leftExpr rightExpr
165 Function args body ->
166 generateFunction args body
168 Call func args ->
169 let
170 arity = length args
171 aN = "A" ++ show arity
172 in
173 do jsFunc <- generateJsExpr func
174 jsArgs <- mapM generateJsExpr args
175 jsExpr $
176 if 2 <= arity && arity <= 9 then
177 ref aN `call` (jsFunc:jsArgs)
178 else
179 foldl1 (<|) (jsFunc:jsArgs)
181 TailCall name argNames args ->
182 let
183 reassign name tempName =
184 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
185 in
186 do args' <- mapM generateJsExpr args
187 tempNames <- mapM (\_ -> Var.fresh) args
188 jsBlock $
189 VarDeclStmt () (zipWith varDecl tempNames args')
190 : zipWith reassign argNames tempNames
191 ++ [ContinueStmt () (Just (Id () name))]
193 Let defs body ->
194 do stmts <- mapM generateDef defs
195 code <- generateCode body
196 jsBlock (stmts ++ toStatementList code)
198 If branches finally ->
199 generateIf branches finally
201 Case root decisionTree branches ->
202 JsBlock <$> generateCase root decisionTree branches
204 ExplicitList elements ->
205 do jsElements <- mapM generateJsExpr elements
206 jsExpr $ BuiltIn.list jsElements
208 Data tag members ->
209 do jsMembers <- mapM generateJsExpr members
210 jsExpr $ ObjectLit () (ctor : fields jsMembers)
211 where
212 ctor = (prop "ctor", string tag)
213 fields =
214 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
216 DataAccess dataExpr index ->
217 do jsDataExpr <- generateJsExpr dataExpr
218 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
220 GLShader _uid src _tipe ->
221 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
223 Port impl ->
224 case impl of
225 Expr.In name portType ->
226 jsExpr (Port.inbound name portType)
228 Expr.Out name expr portType ->
229 do expr' <- generateJsExpr expr
230 jsExpr (Port.outbound name expr' portType)
232 Expr.Task name expr portType ->
233 do expr' <- generateJsExpr expr
234 jsExpr (Port.task name expr' portType)
236 Crash region maybeCaseCrashValue ->
237 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
240-- FUNCTIONS
242generateFunction :: [String] -> Opt.Expr -> State Int Code
243generateFunction args body =
244 do code <- generateCode body
245 jsExpr (generateFunctionWithArity args code)
248generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
249generateTailFunction name args body =
250 do code <- generateCode body
251 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
252 LabelledStmt ()
253 (Id () name)
254 (WhileStmt () (BoolLit () True) (toStatement code))
257generateFunctionWithArity :: [String] -> Code -> Expression ()
258generateFunctionWithArity args code =
259 let
260 arity = length args
261 in
262 if 2 <= arity && arity <= 9 then
263 let
264 fN = "F" ++ show arity
265 in
266 ref fN <| function args (toStatementList code)
267 else
268 let
269 (lastArg:otherArgs) = reverse args
270 innerBody = function [lastArg] (toStatementList code)
271 in
272 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
275-- GENERATE IFS
277generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
278generateIf givenBranches givenFinally =
279 let
280 (branches, finally) =
281 crushIfs givenBranches givenFinally
283 convertBranch (condition, expr) =
284 (,) <$> generateJsExpr condition <*> generateCode expr
286 ifExpression (condition, branch) otherwise =
287 CondExpr () condition branch otherwise
289 ifStatement (condition, branch) otherwise =
290 IfStmt () condition branch otherwise
291 in
292 do jsBranches <- mapM convertBranch branches
293 jsFinally <- generateCode finally
295 if any isBlock (jsFinally : map snd jsBranches)
296 then
297 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
298 else
299 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
302crushIfs
303 :: [(Opt.Expr, Opt.Expr)]
304 -> Opt.Expr
305 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
306crushIfs branches finally =
307 crushIfsHelp [] branches finally
310crushIfsHelp
311 :: [(Opt.Expr, Opt.Expr)]
312 -> [(Opt.Expr, Opt.Expr)]
313 -> Opt.Expr
314 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
315crushIfsHelp visitedBranches unvisitedBranches finally =
316 case unvisitedBranches of
317 [] ->
318 case finally of
319 If subBranches subFinally ->
320 crushIfsHelp visitedBranches subBranches subFinally
322 _ ->
323 (reverse visitedBranches, finally)
325 (Literal (L.Boolean True), branch) : _ ->
326 crushIfsHelp visitedBranches [] branch
328 visiting : unvisited ->
329 crushIfsHelp (visiting : visitedBranches) unvisited finally
332-- CASE EXPRESSIONS
334generateCase
335 :: String
336 -> DT.DecisionTree Opt.Jump
337 -> [(Int, Opt.Branch)]
338 -> State Int [Statement ()]
339generateCase root decisionTree jumpBranches =
340 do decider <- generateDecisionTree root decisionTree
341 foldM (goto root) decider jumpBranches
344goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
345goto root decider (target, branch) =
346 let
347 deciderStmt =
348 LabelledStmt ()
349 (targetLabel root target)
350 (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
351 in
352 do stmts <- generateBranch root branch
353 return (deciderStmt : stmts)
356targetLabel :: String -> Int -> Id ()
357targetLabel root target =
358 Id () (root ++ "_" ++ show target)
361generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
362generateDecisionTree root decisionTree =
363 case decisionTree of
364 DT.Match (Opt.Inline branch) ->
365 generateBranch root branch
367 DT.Match (Opt.Jump target) ->
368 return [ BreakStmt () (Just (targetLabel root target)) ]
370 DT.Decision testPath edges fallback ->
371 do accessExpr <- generateJsExpr (pathToExpr root testPath)
373 let testExpr =
374 case fst (head edges) of
375 DT.Constructor _ ->
376 DotRef () accessExpr (Id () "ctor")
378 DT.Literal _ ->
379 accessExpr
381 caseClauses <- mapM (edgeToCaseClause root) edges
382 caseDefault <- fallbackToDefault root fallback
384 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
387edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
388edgeToCaseClause root (test, subTree) =
389 CaseClause () (testToExpr test) <$> generateDecisionTree root 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
405fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
406fallbackToDefault root fallback =
407 case fallback of
408 Nothing ->
409 return []
411 Just subTree ->
412 do stmts <- generateDecisionTree root subTree
413 return [ CaseDefault () stmts ]
416generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
417generateBranch root (Opt.Branch substitutions expr) =
418 do subts <- mapM (loadPath root) substitutions
419 code <- generateCode expr
420 return (subts ++ toStatementList code)
423loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
424loadPath root (name, path) =
425 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
426 return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
429pathToExpr :: String -> DT.Path -> Opt.Expr
430pathToExpr root fullPath =
431 go (Opt.Var (Var.local root)) fullPath
432 where
433 go expr path =
434 case path of
435 DT.Position index subpath ->
436 go (Opt.DataAccess expr index) subpath
438 DT.Field field subpath ->
439 go (Opt.Access expr field) subpath
441 DT.Empty ->
442 expr
444 DT.Alias ->
445 expr
448-- BINARY OPERATORS
450binop
451 :: Var.Canonical
452 -> Opt.Expr
453 -> Opt.Expr
454 -> State Int Code
455binop func left right =
456 do jsLeft <- generateJsExpr left
457 jsRight <- generateJsExpr right
458 jsExpr (makeExpr func jsLeft jsRight)
461-- BINARY OPERATOR HELPERS
463makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
464makeExpr qualifiedOp@(Var.Canonical home op) =
465 let
466 simpleMake left right =
467 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
468 in
469 if home == Var.Module (ModuleName.inCore ["Basics"]) then
470 Map.findWithDefault simpleMake op basicOps
471 else
472 simpleMake
475basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
476basicOps =
477 Map.fromList (infixOps ++ specialOps)
480infixOps :: [(String, Expression () -> Expression () -> Expression ())]
481infixOps =
482 let
483 infixOp str op =
484 (str, InfixExpr () op)
485 in
486 [ infixOp "+" OpAdd
487 , infixOp "-" OpSub
488 , infixOp "*" OpMul
489 , infixOp "/" OpDiv
490 , infixOp "&&" OpLAnd
491 , infixOp "||" OpLOr
492 ]
495specialOps :: [(String, Expression () -> Expression () -> Expression ())]
496specialOps =
497 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
498 , (,) "==" $ \a b -> BuiltIn.eq a b
499 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
500 , (,) "<" $ cmp OpLT 0
501 , (,) ">" $ cmp OpGT 0
502 , (,) "<=" $ cmp OpLT 1
503 , (,) ">=" $ cmp OpGT (-1)
504 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
505 ]
508cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
509cmp op n a b =
510 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)