git.iko.soy/elk
on 2297bbf help sign in
elk/src/Generate/JavaScript.hs
507 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 definitions =
28 let
29 stmts =
30 State.evalState (mapM generateDef definitions) 0
31 in
32 PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""
35-- CODE CHUNKS
37data Code
38 = JsExpr (Expression ())
39 | JsBlock [Statement ()]
42jsExpr :: Expression () -> State Int Code
43jsExpr exp =
44 return (JsExpr exp)
47jsBlock :: [Statement ()] -> State Int Code
48jsBlock exp =
49 return (JsBlock exp)
52isBlock :: Code -> Bool
53isBlock code =
54 case code of
55 JsBlock _ -> True
56 JsExpr _ -> False
59toStatementList :: Code -> [Statement ()]
60toStatementList code =
61 case code of
62 JsExpr expr ->
63 [ ret expr ]
64 JsBlock stmts ->
65 stmts
68toStatement :: Code -> Statement ()
69toStatement code =
70 case code of
71 JsExpr expr ->
72 ret expr
73 JsBlock [stmt] ->
74 stmt
75 JsBlock stmts ->
76 BlockStmt () stmts
79toExpr :: Code -> Expression ()
80toExpr code =
81 case code of
82 JsExpr expr ->
83 expr
85 JsBlock stmts ->
86 function [] stmts `call` []
89-- DEFINITIONS
91generateDef :: Opt.Def -> State Int (Statement ())
92generateDef def =
93 do (home, name, jsBody) <-
94 case def of
95 Opt.TailDef (Opt.Facts home _) name argNames body ->
96 (,,) home name <$> generateTailFunction name argNames body
98 Opt.Def (Opt.Facts home _) name body ->
99 (,,) home name <$> generateJsExpr body
101 return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])
104-- EXPRESSIONS
106generateJsExpr :: Opt.Expr -> State Int (Expression ())
107generateJsExpr optExpr =
108 toExpr <$> generateCode optExpr
111generateCode :: Opt.Expr -> State Int Code
112generateCode expr =
113 case expr of
114 Var var ->
115 jsExpr $ Var.canonical var
117 Literal lit ->
118 jsExpr (Literal.literal lit)
120 Range lo hi ->
121 do lo' <- generateJsExpr lo
122 hi' <- generateJsExpr hi
123 jsExpr $ BuiltIn.range lo' hi'
125 Access record field ->
126 do record' <- generateJsExpr record
127 jsExpr $ DotRef () record' (var (Var.safe field))
129 Update record fields ->
130 let
131 fieldToJs (field, value) =
132 do jsValue <- generateJsExpr value
133 return (Var.safe field, jsValue)
134 in
135 do jsRecord <- generateJsExpr record
136 jsFields <- mapM fieldToJs fields
137 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
139 Record fields ->
140 do fields' <-
141 forM fields $ \(field, e) ->
142 (,) (Var.safe field) <$> generateJsExpr e
144 let fieldMap =
145 List.foldl' combine Map.empty fields'
147 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
148 where
149 combine record (field, value) =
150 Map.insertWith (++) field [value] record
152 hidden fs =
153 ObjectLit () . map (prop *** ArrayLit ()) $
154 Map.toList (Map.filter (not . null) (Map.map tail fs))
156 visible fs =
157 map (first prop) (Map.toList (Map.map head fs))
159 Binop op leftExpr rightExpr ->
160 binop op leftExpr rightExpr
162 Function args body ->
163 generateFunction args body
165 Call func args ->
166 let
167 arity = length args
168 aN = "A" ++ show arity
169 in
170 do jsFunc <- generateJsExpr func
171 jsArgs <- mapM generateJsExpr args
172 jsExpr $
173 if 2 <= arity && arity <= 9 then
174 ref aN `call` (jsFunc:jsArgs)
175 else
176 foldl1 (<|) (jsFunc:jsArgs)
178 TailCall name argNames args ->
179 let
180 reassign name tempName =
181 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
182 in
183 do args' <- mapM generateJsExpr args
184 tempNames <- mapM (\_ -> Var.fresh) args
185 jsBlock $
186 VarDeclStmt () (zipWith varDecl tempNames args')
187 : zipWith reassign argNames tempNames
188 ++ [ContinueStmt () (Just (Id () name))]
190 Let defs body ->
191 do stmts <- mapM generateDef defs
192 code <- generateCode body
193 jsBlock (stmts ++ toStatementList code)
195 If branches finally ->
196 generateIf branches finally
198 Case root decisionTree branches ->
199 JsBlock <$> generateCase root decisionTree branches
201 ExplicitList elements ->
202 do jsElements <- mapM generateJsExpr elements
203 jsExpr $ BuiltIn.list jsElements
205 Data tag members ->
206 do jsMembers <- mapM generateJsExpr members
207 jsExpr $ ObjectLit () (ctor : fields jsMembers)
208 where
209 ctor = (prop "ctor", string tag)
210 fields =
211 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
213 DataAccess dataExpr index ->
214 do jsDataExpr <- generateJsExpr dataExpr
215 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
217 GLShader _uid src _tipe ->
218 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
220 Port impl ->
221 case impl of
222 Expr.In name portType ->
223 jsExpr (Port.inbound name portType)
225 Expr.Out name expr portType ->
226 do expr' <- generateJsExpr expr
227 jsExpr (Port.outbound name expr' portType)
229 Expr.Task name expr portType ->
230 do expr' <- generateJsExpr expr
231 jsExpr (Port.task name expr' portType)
233 Crash region maybeCaseCrashValue ->
234 jsExpr $ BuiltIn.crash region maybeCaseCrashValue
237-- FUNCTIONS
239generateFunction :: [String] -> Opt.Expr -> State Int Code
240generateFunction args body =
241 do code <- generateCode body
242 jsExpr (generateFunctionWithArity args code)
245generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
246generateTailFunction name args body =
247 do code <- generateCode body
248 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
249 LabelledStmt ()
250 (Id () name)
251 (WhileStmt () (BoolLit () True) (toStatement code))
254generateFunctionWithArity :: [String] -> Code -> Expression ()
255generateFunctionWithArity args code =
256 let
257 arity = length args
258 in
259 if 2 <= arity && arity <= 9 then
260 let
261 fN = "F" ++ show arity
262 in
263 ref fN <| function args (toStatementList code)
264 else
265 let
266 (lastArg:otherArgs) = reverse args
267 innerBody = function [lastArg] (toStatementList code)
268 in
269 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
272-- GENERATE IFS
274generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
275generateIf givenBranches givenFinally =
276 let
277 (branches, finally) =
278 crushIfs givenBranches givenFinally
280 convertBranch (condition, expr) =
281 (,) <$> generateJsExpr condition <*> generateCode expr
283 ifExpression (condition, branch) otherwise =
284 CondExpr () condition branch otherwise
286 ifStatement (condition, branch) otherwise =
287 IfStmt () condition branch otherwise
288 in
289 do jsBranches <- mapM convertBranch branches
290 jsFinally <- generateCode finally
292 if any isBlock (jsFinally : map snd jsBranches)
293 then
294 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
295 else
296 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
299crushIfs
300 :: [(Opt.Expr, Opt.Expr)]
301 -> Opt.Expr
302 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
303crushIfs branches finally =
304 crushIfsHelp [] branches finally
307crushIfsHelp
308 :: [(Opt.Expr, Opt.Expr)]
309 -> [(Opt.Expr, Opt.Expr)]
310 -> Opt.Expr
311 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
312crushIfsHelp visitedBranches unvisitedBranches finally =
313 case unvisitedBranches of
314 [] ->
315 case finally of
316 If subBranches subFinally ->
317 crushIfsHelp visitedBranches subBranches subFinally
319 _ ->
320 (reverse visitedBranches, finally)
322 (Literal (L.Boolean True), branch) : _ ->
323 crushIfsHelp visitedBranches [] branch
325 visiting : unvisited ->
326 crushIfsHelp (visiting : visitedBranches) unvisited finally
329-- CASE EXPRESSIONS
331generateCase
332 :: String
333 -> DT.DecisionTree Opt.Jump
334 -> [(Int, Opt.Branch)]
335 -> State Int [Statement ()]
336generateCase root decisionTree jumpBranches =
337 do decider <- generateDecisionTree root decisionTree
338 foldM (goto root) decider jumpBranches
341goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
342goto root decider (target, branch) =
343 let
344 deciderStmt =
345 LabelledStmt ()
346 (targetLabel root target)
347 (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
348 in
349 do stmts <- generateBranch root branch
350 return (deciderStmt : stmts)
353targetLabel :: String -> Int -> Id ()
354targetLabel root target =
355 Id () (root ++ "_" ++ show target)
358generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
359generateDecisionTree root decisionTree =
360 case decisionTree of
361 DT.Match (Opt.Inline branch) ->
362 generateBranch root branch
364 DT.Match (Opt.Jump target) ->
365 return [ BreakStmt () (Just (targetLabel root target)) ]
367 DT.Decision testPath edges fallback ->
368 do accessExpr <- generateJsExpr (pathToExpr root testPath)
370 let testExpr =
371 case fst (head edges) of
372 DT.Constructor _ ->
373 DotRef () accessExpr (Id () "ctor")
375 DT.Literal _ ->
376 accessExpr
378 caseClauses <- mapM (edgeToCaseClause root) edges
379 caseDefault <- fallbackToDefault root fallback
381 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
384edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
385edgeToCaseClause root (test, subTree) =
386 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
389testToExpr :: DT.Test -> Expression ()
390testToExpr test =
391 case test of
392 DT.Constructor (Var.Canonical _ tag) ->
393 StringLit () tag
395 DT.Literal (L.Chr char) ->
396 StringLit () [char]
398 DT.Literal lit ->
399 Literal.literal lit
402fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
403fallbackToDefault root fallback =
404 case fallback of
405 Nothing ->
406 return []
408 Just subTree ->
409 do stmts <- generateDecisionTree root subTree
410 return [ CaseDefault () stmts ]
413generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
414generateBranch root (Opt.Branch substitutions expr) =
415 do subts <- mapM (loadPath root) substitutions
416 code <- generateCode expr
417 return (subts ++ toStatementList code)
420loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
421loadPath root (name, path) =
422 do jsAccessExpr <- generateJsExpr (pathToExpr root path)
423 return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
426pathToExpr :: String -> DT.Path -> Opt.Expr
427pathToExpr root fullPath =
428 go (Opt.Var (Var.local root)) fullPath
429 where
430 go expr path =
431 case path of
432 DT.Position index subpath ->
433 go (Opt.DataAccess expr index) subpath
435 DT.Field field subpath ->
436 go (Opt.Access expr field) subpath
438 DT.Empty ->
439 expr
441 DT.Alias ->
442 expr
445-- BINARY OPERATORS
447binop
448 :: Var.Canonical
449 -> Opt.Expr
450 -> Opt.Expr
451 -> State Int Code
452binop func left right =
453 do jsLeft <- generateJsExpr left
454 jsRight <- generateJsExpr right
455 jsExpr (makeExpr func jsLeft jsRight)
458-- BINARY OPERATOR HELPERS
460makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
461makeExpr qualifiedOp@(Var.Canonical home op) =
462 let
463 simpleMake left right =
464 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
465 in
466 if home == Var.Module (ModuleName.inCore ["Basics"]) then
467 Map.findWithDefault simpleMake op basicOps
468 else
469 simpleMake
472basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
473basicOps =
474 Map.fromList (infixOps ++ specialOps)
477infixOps :: [(String, Expression () -> Expression () -> Expression ())]
478infixOps =
479 let
480 infixOp str op =
481 (str, InfixExpr () op)
482 in
483 [ infixOp "+" OpAdd
484 , infixOp "-" OpSub
485 , infixOp "*" OpMul
486 , infixOp "/" OpDiv
487 , infixOp "&&" OpLAnd
488 , infixOp "||" OpLOr
489 ]
492specialOps :: [(String, Expression () -> Expression () -> Expression ())]
493specialOps =
494 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
495 , (,) "==" $ \a b -> BuiltIn.eq a b
496 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
497 , (,) "<" $ cmp OpLT 0
498 , (,) ">" $ cmp OpGT 0
499 , (,) "<=" $ cmp OpLT 1
500 , (,) ">=" $ cmp OpGT (-1)
501 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
502 ]
505cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
506cmp op n a b =
507 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)