git.iko.soy/elk
on 2d29699 help sign in
elk/src/Generate/JavaScript.hs
530 lines 14 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 AST.Literal
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.Cases as PM
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
84 JsBlock stmts ->
85 function [] stmts `call` []
88-- TAIL CALL CONTEXT
90type TailCallContext =
91 Maybe (String, [String], Label)
94type Label =
95 Id ()
98-- EXPRESSIONS
100toJsExpr :: Opt.Expr -> State Int (Expression ())
101toJsExpr =
102 exprToJsExpr Nothing
105toCode :: Opt.Expr -> State Int Code
106toCode =
107 exprToCode Nothing
110exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
111exprToJsExpr tcc canonicalExpr =
112 toExpr <$> exprToCode tcc canonicalExpr
115exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
116exprToCode tcc expr =
117 case expr of
118 Var var ->
119 jsExpr $ Var.canonical var
121 Literal lit ->
122 jsExpr (Literal.literal lit)
124 Range lo hi ->
125 do lo' <- toJsExpr lo
126 hi' <- toJsExpr hi
127 jsExpr $ BuiltIn.range lo' hi'
129 Access record field ->
130 do record' <- toJsExpr record
131 jsExpr $ DotRef () record' (var (Var.safe field))
133 Update record fields ->
134 let
135 fieldToJs (field, value) =
136 do jsValue <- toJsExpr value
137 return (Var.safe field, jsValue)
138 in
139 do jsRecord <- toJsExpr record
140 jsFields <- mapM fieldToJs fields
141 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
143 Record fields ->
144 do fields' <-
145 forM fields $ \(field, e) ->
146 (,) (Var.safe field) <$> toJsExpr e
148 let fieldMap =
149 List.foldl' combine Map.empty fields'
151 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
152 where
153 combine record (field, value) =
154 Map.insertWith (++) field [value] record
156 hidden fs =
157 ObjectLit () . map (prop *** ArrayLit ()) $
158 Map.toList (Map.filter (not . null) (Map.map tail fs))
160 visible fs =
161 map (first prop) (Map.toList (Map.map head fs))
163 Binop op leftExpr rightExpr ->
164 binop op leftExpr rightExpr
166 Function args body ->
167 generateFunction args body
169 Call func args ->
170 let
171 arity = length args
172 aN = "A" ++ show arity
173 in
174 do jsFunc <- toJsExpr func
175 jsArgs <- mapM toJsExpr args
176 jsExpr $
177 if 2 <= arity && arity <= 9 then
178 ref aN `call` (jsFunc:jsArgs)
179 else
180 foldl1 (<|) (jsFunc:jsArgs)
182 TailCall name argNames args ->
183 let
184 reassign name tempName =
185 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
186 in
187 do args' <- mapM toJsExpr args
188 tempNames <- mapM (\_ -> Var.fresh) args
189 jsBlock $
190 VarDeclStmt () (zipWith varDecl tempNames args')
191 : zipWith reassign argNames tempNames
192 ++ [ContinueStmt () (Just (Id () name))]
194 Let defs body ->
195 generateLet tcc defs body
197 If branches finally ->
198 generateIf tcc branches finally
200 Case expr decisionTree branches ->
201 generateCase tcc expr decisionTree branches
203 ExplicitList elements ->
204 do jsElements <- mapM toJsExpr elements
205 jsExpr $ BuiltIn.list jsElements
207 Data tag members ->
208 do jsMembers <- mapM toJsExpr members
209 jsExpr $ ObjectLit () (ctor : fields jsMembers)
210 where
211 ctor = (prop "ctor", string tag)
212 fields =
213 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
215 DataAccess dataExpr index ->
216 do jsDataExpr <- toJsExpr dataExpr
217 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
219 GLShader _uid src _tipe ->
220 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]
222 Port impl ->
223 case impl of
224 Expr.In name portType ->
225 jsExpr (Port.inbound name portType)
227 Expr.Out name expr portType ->
228 do expr' <- toJsExpr expr
229 jsExpr (Port.outbound name expr' portType)
231 Expr.Task name expr portType ->
232 do expr' <- toJsExpr expr
233 jsExpr (Port.task name expr' portType)
235 Crash ->
236 error "TODO"
239-- FUNCTIONS
241generateFunction :: [String] -> Opt.Expr -> State Int Code
242generateFunction args body =
243 do code <- exprToCode Nothing body
244 jsExpr (generateFunctionWithArity args code)
247generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
248generateTailFunction name args body =
249 do code <- exprToCode Nothing body
250 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
251 LabelledStmt ()
252 (Id () name)
253 (WhileStmt () (BoolLit () True) (toStatement code))
256generateFunctionWithArity :: [String] -> Code -> Expression ()
257generateFunctionWithArity args code =
258 let
259 arity = length args
260 in
261 if 2 <= arity && arity <= 9 then
262 let
263 fN = "F" ++ show arity
264 in
265 ref fN <| function args (toStatementList code)
266 else
267 let
268 (lastArg:otherArgs) = reverse args
269 innerBody = function [lastArg] (toStatementList code)
270 in
271 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
274-- LET EXPRESSIONS
276generateLet
277 :: TailCallContext
278 -> [Opt.Def]
279 -> Opt.Expr
280 -> State Int Code
281generateLet tcc defs body =
282 do stmts <- mapM generateDef defs
283 code <- exprToCode tcc body
284 jsBlock (stmts ++ toStatementList code)
287-- GENERATE IFS
289generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
290generateIf tcc givenBranches givenFinally =
291 let
292 (branches, finally) =
293 crushIfs givenBranches givenFinally
295 convertBranch (condition, expr) =
296 (,) <$> toJsExpr condition <*> exprToCode tcc expr
298 ifExpression (condition, branch) otherwise =
299 CondExpr () condition branch otherwise
301 ifStatement (condition, branch) otherwise =
302 IfStmt () condition branch otherwise
303 in
304 do jsBranches <- mapM convertBranch branches
305 jsFinally <- exprToCode tcc finally
307 if any isBlock (jsFinally : map snd jsBranches)
308 then
309 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
310 else
311 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
314crushIfs
315 :: [(Opt.Expr, Opt.Expr)]
316 -> Opt.Expr
317 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
318crushIfs branches finally =
319 crushIfsHelp [] branches finally
322crushIfsHelp
323 :: [(Opt.Expr, Opt.Expr)]
324 -> [(Opt.Expr, Opt.Expr)]
325 -> Opt.Expr
326 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
327crushIfsHelp visitedBranches unvisitedBranches finally =
328 case unvisitedBranches of
329 [] ->
330 case finally of
331 If subBranches subFinally ->
332 crushIfsHelp visitedBranches subBranches subFinally
334 _ ->
335 (reverse visitedBranches, finally)
337 (Literal (Boolean True), branch) : _ ->
338 crushIfsHelp visitedBranches [] branch
340 visiting : unvisited ->
341 crushIfsHelp (visiting : visitedBranches) unvisited finally
345-- DEFINITIONS
347generateDef :: Opt.Def -> State Int (Statement ())
348generateDef def =
349 do (home, name, jsBody) <-
350 case def of
351 Opt.TailDef (Opt.Facts home _) name argNames body ->
352 (,,) home name <$> generateTailFunction name argNames body
354 Opt.Def (Opt.Facts home _) name body ->
355 (,,) home name <$> toJsExpr body
357 return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])
360-- CASE EXPRESSIONS
362generateCase
363 :: TailCallContext
364 -> Opt.Expr
365 -> PM.DecisionTree Int
366 -> Map.Map Int Opt.Expr
367 -> State Int Code
368generateCase tcc expr decisionTree branches =
369 error "TODO" tcc expr decisionTree branches
372-- BINARY OPERATORS
374binop
375 :: Var.Canonical
376 -> Opt.Expr
377 -> Opt.Expr
378 -> State Int Code
379binop func left right
380 | func == Var.Canonical Var.BuiltIn "::" =
381 toCode (Data "::" [left,right])
383 | func == forwardCompose =
384 compose (collectLeftAssoc forwardCompose left right)
386 | func == backwardCompose =
387 compose (collectRightAssoc backwardCompose left right)
389 | func == forwardApply =
390 pipe (collectLeftAssoc forwardApply left right)
392 | func == backwardApply =
393 pipe (collectRightAssoc backwardApply left right)
395 | otherwise =
396 do jsLeft <- toJsExpr left
397 jsRight <- toJsExpr right
398 jsExpr (makeExpr func jsLeft jsRight)
401-- CONTROL FLOW OPERATOR HELPERS
403apply :: Expression () -> Expression () -> Expression ()
404apply arg func =
405 func <| arg
408compose :: [Opt.Expr] -> State Int Code
409compose functions =
410 do jsFunctions <- mapM toJsExpr functions
411 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
414pipe :: [Opt.Expr] -> State Int Code
415pipe expressions =
416 do (value:functions) <- mapM toJsExpr expressions
417 jsExpr $ List.foldl' apply value functions
420forwardCompose :: Var.Canonical
421forwardCompose =
422 inBasics ">>"
425backwardCompose :: Var.Canonical
426backwardCompose =
427 inBasics "<<"
430forwardApply :: Var.Canonical
431forwardApply =
432 inBasics "|>"
435backwardApply :: Var.Canonical
436backwardApply =
437 inBasics "<|"
440inBasics :: String -> Var.Canonical
441inBasics name =
442 Var.inCore ["Basics"] name
445-- BINARY OPERATOR HELPERS
447makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
448makeExpr qualifiedOp@(Var.Canonical home op) =
449 let
450 simpleMake left right =
451 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
452 in
453 if home == Var.Module (ModuleName.inCore ["Basics"]) then
454 Map.findWithDefault simpleMake op basicOps
455 else
456 simpleMake
459basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
460basicOps =
461 Map.fromList (infixOps ++ specialOps)
464infixOps :: [(String, Expression () -> Expression () -> Expression ())]
465infixOps =
466 let
467 infixOp str op =
468 (str, InfixExpr () op)
469 in
470 [ infixOp "+" OpAdd
471 , infixOp "-" OpSub
472 , infixOp "*" OpMul
473 , infixOp "/" OpDiv
474 , infixOp "&&" OpLAnd
475 , infixOp "||" OpLOr
476 ]
479specialOps :: [(String, Expression () -> Expression () -> Expression ())]
480specialOps =
481 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
482 , (,) "|>" $ flip (<|)
483 , (,) "==" $ \a b -> BuiltIn.eq a b
484 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
485 , (,) "<" $ cmp OpLT 0
486 , (,) ">" $ cmp OpGT 0
487 , (,) "<=" $ cmp OpLT 1
488 , (,) ">=" $ cmp OpGT (-1)
489 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
490 ]
493cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
494cmp op n a b =
495 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
498-- BINARY OPERATOR COLLECTORS
500-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
501collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
502collectRightAssoc desiredOp left right =
503 collectRightAssocHelp desiredOp [left] right
506collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
507collectRightAssocHelp desiredOp exprList expr =
508 case expr of
509 Binop op left right | op == desiredOp ->
510 collectRightAssocHelp desiredOp (left : exprList) right
512 _ ->
513 expr : exprList
516-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
517collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
518collectLeftAssoc desiredOp left right =
519 collectLeftAssocHelp desiredOp [right] left
522collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
523collectLeftAssocHelp desiredOp exprList expr =
524 case expr of
525 Binop op left right | op == desiredOp ->
526 collectLeftAssocHelp desiredOp (right : exprList) left
528 _ ->
529 expr : exprList