git.iko.soy/elk
on 159db7c help sign in
elk/src/Generate/JavaScript.hs
653 lines 18 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 qualified Data.Maybe as Maybe
9import Language.ECMAScript3.PrettyPrint as ES
10import Language.ECMAScript3.Syntax
11import qualified Text.PrettyPrint.Leijen as PP
13import AST.Expression.General as Expr
14import qualified AST.Expression.Optimized as Opt
15import qualified AST.Helpers as Help
16import AST.Literal
17import qualified AST.Module as Module
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Pattern as P
20import qualified AST.Variable as Var
21import Generate.JavaScript.Helpers as Help
22import qualified Generate.JavaScript.BuiltIn as BuiltIn
23import qualified Generate.JavaScript.Crash as Crash
24import qualified Generate.JavaScript.Literal as Literal
25import qualified Generate.JavaScript.Port as Port
26import qualified Generate.JavaScript.Variable as Var
27import qualified Optimize.Cases as Case
28import qualified Reporting.Annotation as A
29import qualified Reporting.Crash as Crash
32generate :: Module.Optimized -> String
33generate module_ =
34 let
35 (definitions, _) =
36 flattenLets [] (Module.program (Module.body module_))
38 stmts =
39 concat (State.evalState (mapM defToStatements definitions) 0)
40 in
41 PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""
44-- CODE CHUNKS
46data Code
47 = JsExpr (Expression ())
48 | JsBlock [Statement ()]
51jsExpr :: Expression () -> State Int Code
52jsExpr exp =
53 return (JsExpr exp)
56jsBlock :: [Statement ()] -> State Int Code
57jsBlock exp =
58 return (JsBlock exp)
61isBlock :: Code -> Bool
62isBlock code =
63 case code of
64 JsBlock _ -> True
65 JsExpr _ -> False
68toStatementList :: Code -> [Statement ()]
69toStatementList code =
70 case code of
71 JsExpr expr ->
72 [ ret expr ]
73 JsBlock stmts ->
74 stmts
77toStatement :: Code -> Statement ()
78toStatement code =
79 case code of
80 JsExpr expr ->
81 ret expr
82 JsBlock [stmt] ->
83 stmt
84 JsBlock stmts ->
85 BlockStmt () stmts
88toExpr :: Code -> Expression ()
89toExpr code =
90 case code of
91 JsExpr expr ->
92 expr
93 JsBlock stmts ->
94 function [] stmts `call` []
97-- TAIL CALL CONTEXT
99type TailCallContext =
100 Maybe (String, [String], Label)
103type Label =
104 Id ()
107-- EXPRESSIONS
109toJsExpr :: Opt.Expr -> State Int (Expression ())
110toJsExpr =
111 exprToJsExpr Nothing
114toCode :: Opt.Expr -> State Int Code
115toCode =
116 exprToCode Nothing
119exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
120exprToJsExpr tcc canonicalExpr =
121 toExpr <$> exprToCode tcc canonicalExpr
124exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
125exprToCode tcc annotatedExpr@(A.A _ expr) =
126 case expr of
127 Var var ->
128 jsExpr $ Var.canonical var
130 Literal lit ->
131 jsExpr (Literal.literal lit)
133 Range lo hi ->
134 do lo' <- toJsExpr lo
135 hi' <- toJsExpr hi
136 jsExpr $ BuiltIn.range lo' hi'
138 Access record field ->
139 do record' <- toJsExpr record
140 jsExpr $ DotRef () record' (var (Var.safe field))
142 Update record fields ->
143 let
144 fieldToJs (field, value) =
145 do jsValue <- toJsExpr value
146 return (Var.safe field, jsValue)
147 in
148 do jsRecord <- toJsExpr record
149 jsFields <- mapM fieldToJs fields
150 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
152 Record fields ->
153 do fields' <-
154 forM fields $ \(field, e) ->
155 (,) (Var.safe field) <$> toJsExpr e
157 let fieldMap =
158 List.foldl' combine Map.empty fields'
160 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
161 where
162 combine record (field, value) =
163 Map.insertWith (++) field [value] record
165 hidden fs =
166 ObjectLit () . map (prop *** ArrayLit ()) $
167 Map.toList (Map.filter (not . null) (Map.map tail fs))
169 visible fs =
170 map (first prop) (Map.toList (Map.map head fs))
172 Binop op leftExpr rightExpr ->
173 binop op leftExpr rightExpr
175 Lambda _ _ ->
176 generateFunction (Expr.collectLambdas annotatedExpr)
178 App _ _ ->
179 generateApplication tcc annotatedExpr
181 Let defs body ->
182 generateLet tcc defs body
184 If branches finally ->
185 generateIf tcc branches finally
187 Case expr branches ->
188 generateCase tcc expr branches
190 ExplicitList elements ->
191 do jsElements <- mapM toJsExpr elements
192 jsExpr $ BuiltIn.list jsElements
194 Data tag members ->
195 do jsMembers <- mapM toJsExpr members
196 jsExpr $ ObjectLit () (ctor : fields jsMembers)
197 where
198 ctor = (prop "ctor", string tag)
199 fields =
200 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
202 GLShader _uid src _tipe ->
203 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]
205 Port impl ->
206 case impl of
207 In name portType ->
208 jsExpr (Port.inbound name portType)
210 Out name expr portType ->
211 do expr' <- toJsExpr expr
212 jsExpr (Port.outbound name expr' portType)
214 Task name expr portType ->
215 do expr' <- toJsExpr expr
216 jsExpr (Port.task name expr' portType)
218 Crash details ->
219 jsExpr $ Crash.crash details
222-- FUNCTIONS
224generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
225generateFunction (args, initialBody) =
226 do (argVars, patternDefs) <- destructuredArgs args
227 code <- generateLet Nothing patternDefs initialBody
228 jsExpr (generateFunctionWithArity argVars code)
231generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
232generateTailFunction name (args, initialBody) =
233 do (argVars, patternDefs) <- destructuredArgs args
234 label <- Id () <$> Var.fresh
235 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
236 let whileLoop =
237 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
238 return (generateFunctionWithArity argVars whileLoop)
241generateFunctionWithArity :: [String] -> Code -> Expression ()
242generateFunctionWithArity args code =
243 let
244 arity = length args
245 in
246 if 2 <= arity && arity <= 9 then
247 let
248 fN = "F" ++ show arity
249 in
250 ref fN <| function args (toStatementList code)
251 else
252 let
253 (lastArg:otherArgs) = reverse args
254 innerBody = function [lastArg] (toStatementList code)
255 in
256 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
259destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
260destructuredArgs args =
261 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
262 return (argVars, Maybe.catMaybes maybePatternDefs)
265destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
266destructPattern pattern@(A.A ann pat) =
267 case pat of
268 P.Var x ->
269 return (Var.safe x, Nothing)
271 _ ->
272 do arg <- Var.fresh
273 return
274 ( arg
275 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
276 )
279-- APPLICATIONS
281generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
282generateApplication tcc expr =
283 let
284 (func:args) =
285 Expr.collectApps expr
287 arity =
288 length args
290 reassign name tempName =
291 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
293 aN =
294 "A" ++ show arity
295 in
296 case isTailCall tcc func arity of
297 Just (argNames, label) ->
298 do args' <- mapM toJsExpr args
299 tempNames <- mapM (\_ -> Var.fresh) args
300 jsBlock $
301 VarDeclStmt () (zipWith varDecl tempNames args')
302 : zipWith reassign argNames tempNames
303 ++ [ContinueStmt () (Just label)]
305 _ ->
306 do func' <- toJsExpr func
307 args' <- mapM toJsExpr args
308 jsExpr $
309 if 2 <= arity && arity <= 9 then
310 ref aN `call` (func':args')
311 else
312 foldl1 (<|) (func':args')
315isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
316isTailCall tcc (A.A _ func) arity =
317 case (func, tcc) of
318 (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
319 if name == tcName && length tcArgs == arity then
320 Just (tcArgs, tcLabel)
321 else
322 Nothing
324 (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
325 if name == tcName && length tcArgs == arity then
326 Just (tcArgs, tcLabel)
327 else
328 Nothing
330 _ ->
331 Nothing
334-- LET EXPRESSIONS
336generateLet
337 :: TailCallContext
338 -> [Opt.Def]
339 -> Opt.Expr
340 -> State Int Code
341generateLet tcc givenDefs givenBody =
342 do let (defs, body) = flattenLets givenDefs givenBody
343 stmts <- concat <$> mapM defToStatements defs
344 code <- exprToCode tcc body
345 jsBlock (stmts ++ toStatementList code)
348flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
349flattenLets defs lexpr@(A.A _ expr) =
350 case expr of
351 Let ds body -> flattenLets (defs ++ ds) body
352 _ -> (defs, lexpr)
355-- GENERATE IFS
357generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
358generateIf tcc givenBranches givenFinally =
359 let
360 (branches, finally) =
361 crushIfs givenBranches givenFinally
363 convertBranch (condition, expr) =
364 (,) <$> toJsExpr condition <*> exprToCode tcc expr
366 ifExpression (condition, branch) otherwise =
367 CondExpr () condition branch otherwise
369 ifStatement (condition, branch) otherwise =
370 IfStmt () condition branch otherwise
371 in
372 do jsBranches <- mapM convertBranch branches
373 jsFinally <- exprToCode tcc finally
375 if any isBlock (jsFinally : map snd jsBranches)
376 then
377 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
378 else
379 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
382crushIfs
383 :: [(Opt.Expr, Opt.Expr)]
384 -> Opt.Expr
385 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
386crushIfs branches finally =
387 crushIfsHelp [] branches finally
390crushIfsHelp
391 :: [(Opt.Expr, Opt.Expr)]
392 -> [(Opt.Expr, Opt.Expr)]
393 -> Opt.Expr
394 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
395crushIfsHelp visitedBranches unvisitedBranches finally =
396 case unvisitedBranches of
397 [] ->
398 case finally of
399 A.A _ (If subBranches subFinally) ->
400 crushIfsHelp visitedBranches subBranches subFinally
402 _ ->
403 (reverse visitedBranches, finally)
405 (A.A _ (Literal (Boolean True)), branch) : _ ->
406 crushIfsHelp visitedBranches [] branch
408 visiting : unvisited ->
409 crushIfsHelp (visiting : visitedBranches) unvisited finally
413-- DEFINITIONS
415defToStatements :: Opt.Def -> State Int [Statement ()]
416defToStatements (Opt.Definition facts pattern expr) =
417 case Opt.tailRecursionDetails facts of
418 Just name ->
419 do func <- generateTailFunction name (Expr.collectLambdas expr)
420 return [ VarDeclStmt () [ varDecl name func ] ]
422 Nothing ->
423 defToStatementsHelp facts pattern =<< toJsExpr expr
426defToStatementsHelp
427 :: Opt.Facts
428 -> P.Optimized
429 -> Expression ()
430 -> State Int [Statement ()]
431defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
432 let
433 define x =
434 varDecl x jsExpr
435 in
436 case pattern of
437 P.Var x ->
438 if Help.isOp x then
439 let
440 op = LBracket () (ref "_op") (string x)
441 in
442 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
443 else
444 return [ VarDeclStmt () [ define (Var.safe x) ] ]
446 P.Record fields ->
447 let
448 setField name =
449 varDecl name (obj ["$",name])
450 in
451 return [ VarDeclStmt () (define "$" : map setField fields) ]
453 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
454 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
455 where
456 vars = getVars patterns
457 getVars patterns =
458 case patterns of
459 A.A _ (P.Var x) : rest ->
460 (Var.safe x :) `fmap` getVars rest
461 [] ->
462 Just []
463 _ ->
464 Nothing
466 decl x n = varDecl x (obj ["$","_" ++ show n])
467 setup vars
468 | Help.isTuple name = define "$" : vars
469 | otherwise = define "_raw" : safeAssign : vars
471 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
472 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
473 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
475 _ ->
476 do defs' <- concat <$> mapM toDef vars
477 return (VarDeclStmt () [define "_"] : defs')
478 where
479 vars = P.boundVarList annPattern
480 mkVar = A.A () . localVar
481 toDef y =
482 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
483 pat = A.A () (P.Var y)
484 in
485 defToStatements (Opt.Definition facts pat expr)
488-- CASE EXPRESSIONS
490generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
491generateCase tcc expr branches =
492 error "TODO" tcc expr branches
495-- BINARY OPERATORS
497binop
498 :: Var.Canonical
499 -> Opt.Expr
500 -> Opt.Expr
501 -> State Int Code
502binop func left right
503 | func == Var.Canonical Var.BuiltIn "::" =
504 toCode (A.A () (Data "::" [left,right]))
506 | func == forwardCompose =
507 compose (collectLeftAssoc forwardCompose left right)
509 | func == backwardCompose =
510 compose (collectRightAssoc backwardCompose left right)
512 | func == forwardApply =
513 pipe (collectLeftAssoc forwardApply left right)
515 | func == backwardApply =
516 pipe (collectRightAssoc backwardApply left right)
518 | otherwise =
519 do jsLeft <- toJsExpr left
520 jsRight <- toJsExpr right
521 jsExpr (makeExpr func jsLeft jsRight)
524-- CONTROL FLOW OPERATOR HELPERS
526apply :: Expression () -> Expression () -> Expression ()
527apply arg func =
528 func <| arg
531compose :: [Opt.Expr] -> State Int Code
532compose functions =
533 do jsFunctions <- mapM toJsExpr functions
534 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
537pipe :: [Opt.Expr] -> State Int Code
538pipe expressions =
539 do (value:functions) <- mapM toJsExpr expressions
540 jsExpr $ List.foldl' apply value functions
543forwardCompose :: Var.Canonical
544forwardCompose =
545 inBasics ">>"
548backwardCompose :: Var.Canonical
549backwardCompose =
550 inBasics "<<"
553forwardApply :: Var.Canonical
554forwardApply =
555 inBasics "|>"
558backwardApply :: Var.Canonical
559backwardApply =
560 inBasics "<|"
563inBasics :: String -> Var.Canonical
564inBasics name =
565 Var.inCore ["Basics"] name
568-- BINARY OPERATOR HELPERS
570makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
571makeExpr qualifiedOp@(Var.Canonical home op) =
572 let
573 simpleMake left right =
574 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
575 in
576 if home == Var.Module (ModuleName.inCore ["Basics"]) then
577 Map.findWithDefault simpleMake op basicOps
578 else
579 simpleMake
582basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
583basicOps =
584 Map.fromList (infixOps ++ specialOps)
587infixOps :: [(String, Expression () -> Expression () -> Expression ())]
588infixOps =
589 let
590 infixOp str op =
591 (str, InfixExpr () op)
592 in
593 [ infixOp "+" OpAdd
594 , infixOp "-" OpSub
595 , infixOp "*" OpMul
596 , infixOp "/" OpDiv
597 , infixOp "&&" OpLAnd
598 , infixOp "||" OpLOr
599 ]
602specialOps :: [(String, Expression () -> Expression () -> Expression ())]
603specialOps =
604 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
605 , (,) "|>" $ flip (<|)
606 , (,) "==" $ \a b -> BuiltIn.eq a b
607 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
608 , (,) "<" $ cmp OpLT 0
609 , (,) ">" $ cmp OpGT 0
610 , (,) "<=" $ cmp OpLT 1
611 , (,) ">=" $ cmp OpGT (-1)
612 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
613 ]
616cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
617cmp op n a b =
618 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
621-- BINARY OPERATOR COLLECTORS
623-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
624collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
625collectRightAssoc desiredOp left right =
626 collectRightAssocHelp desiredOp [left] right
629collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
630collectRightAssocHelp desiredOp exprList expr =
631 case expr of
632 A.A _ (Binop op left right) | op == desiredOp ->
633 collectRightAssocHelp desiredOp (left : exprList) right
635 _ ->
636 expr : exprList
639-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
640collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
641collectLeftAssoc desiredOp left right =
642 collectLeftAssocHelp desiredOp [right] left
645collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
646collectLeftAssocHelp desiredOp exprList expr =
647 case expr of
648 A.A _ (Binop op left right) | op == desiredOp ->
649 collectLeftAssocHelp desiredOp (right : exprList) left
651 _ ->
652 expr : exprList