git.iko.soy/elk
on b9cc20e help sign in
elk/src/Generate/JavaScript.hs
402 lines 11 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
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 expr decisionTree branches ->
199 generateCase expr 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 (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 ->
234 error "TODO"
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 (Boolean True), branch) : _ ->
323 crushIfsHelp visitedBranches [] branch
325 visiting : unvisited ->
326 crushIfsHelp (visiting : visitedBranches) unvisited finally
329-- CASE EXPRESSIONS
331generateCase
332 :: Opt.Expr
333 -> PM.DecisionTree Int
334 -> Map.Map Int Opt.Expr
335 -> State Int Code
336generateCase expr decisionTree branches =
337 error "TODO" expr decisionTree branches
340-- BINARY OPERATORS
342binop
343 :: Var.Canonical
344 -> Opt.Expr
345 -> Opt.Expr
346 -> State Int Code
347binop func left right =
348 do jsLeft <- generateJsExpr left
349 jsRight <- generateJsExpr right
350 jsExpr (makeExpr func jsLeft jsRight)
353-- BINARY OPERATOR HELPERS
355makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
356makeExpr qualifiedOp@(Var.Canonical home op) =
357 let
358 simpleMake left right =
359 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
360 in
361 if home == Var.Module (ModuleName.inCore ["Basics"]) then
362 Map.findWithDefault simpleMake op basicOps
363 else
364 simpleMake
367basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
368basicOps =
369 Map.fromList (infixOps ++ specialOps)
372infixOps :: [(String, Expression () -> Expression () -> Expression ())]
373infixOps =
374 let
375 infixOp str op =
376 (str, InfixExpr () op)
377 in
378 [ infixOp "+" OpAdd
379 , infixOp "-" OpSub
380 , infixOp "*" OpMul
381 , infixOp "/" OpDiv
382 , infixOp "&&" OpLAnd
383 , infixOp "||" OpLOr
384 ]
387specialOps :: [(String, Expression () -> Expression () -> Expression ())]
388specialOps =
389 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
390 , (,) "==" $ \a b -> BuiltIn.eq a b
391 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
392 , (,) "<" $ cmp OpLT 0
393 , (,) ">" $ cmp OpGT 0
394 , (,) "<=" $ cmp OpLT 1
395 , (,) ">=" $ cmp OpGT (-1)
396 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
397 ]
400cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
401cmp op n a b =
402 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)