git.iko.soy/elk
on fac1c25 help sign in
elk/src/Generate/JavaScript.hs
727 lines 20 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Applicative ((<$>),(<*>))
4import Control.Arrow (first, second, (***))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import Language.ECMAScript3.Syntax
11import AST.Expression.General as Expr
12import qualified AST.Expression.Optimized as Opt
13import qualified AST.Helpers as Help
14import AST.Literal
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Pattern as P
18import qualified AST.Variable as Var
19import Generate.JavaScript.Helpers as Help
20import qualified Generate.JavaScript.BuiltIn as BuiltIn
21import qualified Generate.JavaScript.Crash as Crash
22import qualified Generate.JavaScript.Literal as Literal
23import qualified Generate.JavaScript.Port as Port
24import qualified Generate.JavaScript.Variable as Var
25import qualified Optimize.Cases as Case
26import qualified Reporting.Annotation as A
27import qualified Reporting.Crash as Crash
30generate :: Module.Optimized -> String
31generate modul =
32 error "TODO" modul exprToCode
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 annotatedExpr@(A.A _ 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 Lambda _ _ ->
167 generateFunction (Expr.collectLambdas annotatedExpr)
169 App _ _ ->
170 generateApplication tcc annotatedExpr
172 Let defs body ->
173 generateLet tcc defs body
175 If branches finally ->
176 generateIf tcc branches finally
178 Case expr branches ->
179 generateCase tcc expr branches
181 ExplicitList elements ->
182 do jsElements <- mapM toJsExpr elements
183 jsExpr $ BuiltIn.list jsElements
185 Data tag members ->
186 do jsMembers <- mapM toJsExpr members
187 jsExpr $ ObjectLit () (ctor : fields jsMembers)
188 where
189 ctor = (prop "ctor", string tag)
190 fields =
191 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
193 GLShader _uid src _tipe ->
194 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]
196 Port impl ->
197 case impl of
198 In name portType ->
199 jsExpr (Port.inbound name portType)
201 Out name expr portType ->
202 do expr' <- toJsExpr expr
203 jsExpr (Port.outbound name expr' portType)
205 Task name expr portType ->
206 do expr' <- toJsExpr expr
207 jsExpr (Port.task name expr' portType)
209 Crash details ->
210 jsExpr $ Crash.crash details
213-- FUNCTIONS
215generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
216generateFunction (args, initialBody) =
217 do (argVars, patternDefs) <- destructuredArgs args
218 code <- generateLet Nothing patternDefs initialBody
219 jsExpr (generateFunctionWithArity argVars code)
222generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
223generateTailFunction name (args, initialBody) =
224 do (argVars, patternDefs) <- destructuredArgs args
225 label <- Id () <$> Case.newVar
226 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
227 let whileLoop =
228 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
229 return (generateFunctionWithArity argVars whileLoop)
232generateFunctionWithArity :: [String] -> Code -> Expression ()
233generateFunctionWithArity args code =
234 let
235 arity = length args
236 in
237 if 2 <= arity && arity <= 9 then
238 let
239 fN = "F" ++ show arity
240 in
241 ref fN <| function args (toStatementList code)
242 else
243 let
244 (lastArg:otherArgs) = reverse args
245 innerBody = function [lastArg] (toStatementList code)
246 in
247 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
250destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
251destructuredArgs args =
252 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
253 return (argVars, Maybe.catMaybes maybePatternDefs)
256destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
257destructPattern pattern@(A.A ann pat) =
258 case pat of
259 P.Var x ->
260 return (Var.safe x, Nothing)
262 _ ->
263 do arg <- Case.newVar
264 return
265 ( arg
266 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
267 )
270-- APPLICATIONS
272generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
273generateApplication tcc expr =
274 let
275 (func:args) =
276 Expr.collectApps expr
278 arity =
279 length args
281 reassign name tempName =
282 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
284 aN =
285 "A" ++ show arity
286 in
287 case isTailCall tcc func arity of
288 Just (argNames, label) ->
289 do args' <- mapM toJsExpr args
290 tempNames <- mapM (\_ -> Case.newVar) args
291 jsBlock $
292 VarDeclStmt () (zipWith varDecl tempNames args')
293 : zipWith reassign argNames tempNames
294 ++ [ContinueStmt () (Just label)]
296 _ ->
297 do func' <- toJsExpr func
298 args' <- mapM toJsExpr args
299 jsExpr $
300 if 2 <= arity && arity <= 9 then
301 ref aN `call` (func':args')
302 else
303 foldl1 (<|) (func':args')
306isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
307isTailCall tcc (A.A _ func) arity =
308 case (func, tcc) of
309 (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
310 if name == tcName && length tcArgs == arity then
311 Just (tcArgs, tcLabel)
312 else
313 Nothing
315 (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
316 if name == tcName && length tcArgs == arity then
317 Just (tcArgs, tcLabel)
318 else
319 Nothing
321 _ ->
322 Nothing
325-- LET EXPRESSIONS
327generateLet
328 :: TailCallContext
329 -> [Opt.Def]
330 -> Opt.Expr
331 -> State Int Code
332generateLet tcc givenDefs givenBody =
333 do let (defs, body) = flattenLets givenDefs givenBody
334 stmts <- concat <$> mapM defToStatements defs
335 code <- exprToCode tcc body
336 jsBlock (stmts ++ toStatementList code)
339-- GENERATE IFS
341generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
342generateIf tcc givenBranches givenFinally =
343 let
344 (branches, finally) =
345 crushIfs givenBranches givenFinally
347 convertBranch (condition, expr) =
348 (,) <$> toJsExpr condition <*> exprToCode tcc expr
350 ifExpression (condition, branch) otherwise =
351 CondExpr () condition branch otherwise
353 ifStatement (condition, branch) otherwise =
354 IfStmt () condition branch otherwise
355 in
356 do jsBranches <- mapM convertBranch branches
357 jsFinally <- exprToCode tcc finally
359 if any isBlock (jsFinally : map snd jsBranches)
360 then
361 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
362 else
363 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
366crushIfs
367 :: [(Opt.Expr, Opt.Expr)]
368 -> Opt.Expr
369 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
370crushIfs branches finally =
371 crushIfsHelp [] branches finally
374crushIfsHelp
375 :: [(Opt.Expr, Opt.Expr)]
376 -> [(Opt.Expr, Opt.Expr)]
377 -> Opt.Expr
378 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
379crushIfsHelp visitedBranches unvisitedBranches finally =
380 case unvisitedBranches of
381 [] ->
382 case finally of
383 A.A _ (If subBranches subFinally) ->
384 crushIfsHelp visitedBranches subBranches subFinally
386 _ ->
387 (reverse visitedBranches, finally)
389 (A.A _ (Literal (Boolean True)), branch) : _ ->
390 crushIfsHelp visitedBranches [] branch
392 visiting : unvisited ->
393 crushIfsHelp (visiting : visitedBranches) unvisited finally
397-- DEFINITIONS
399defToStatements :: Opt.Def -> State Int [Statement ()]
400defToStatements (Opt.Definition facts pattern expr) =
401 case Opt.tailRecursionDetails facts of
402 Just name ->
403 do func <- generateTailFunction name (Expr.collectLambdas expr)
404 return [ VarDeclStmt () [ varDecl name func ] ]
406 Nothing ->
407 defToStatementsHelp facts pattern =<< toJsExpr expr
410defToStatementsHelp
411 :: Opt.Facts
412 -> P.Optimized
413 -> Expression ()
414 -> State Int [Statement ()]
415defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
416 let
417 define x =
418 varDecl x jsExpr
419 in
420 case pattern of
421 P.Var x ->
422 if Help.isOp x then
423 let
424 op = LBracket () (ref "_op") (string x)
425 in
426 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
427 else
428 return [ VarDeclStmt () [ define (Var.safe x) ] ]
430 P.Record fields ->
431 let
432 setField name =
433 varDecl name (obj ["$",name])
434 in
435 return [ VarDeclStmt () (define "$" : map setField fields) ]
437 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
438 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
439 where
440 vars = getVars patterns
441 getVars patterns =
442 case patterns of
443 A.A _ (P.Var x) : rest ->
444 (Var.safe x :) `fmap` getVars rest
445 [] ->
446 Just []
447 _ ->
448 Nothing
450 decl x n = varDecl x (obj ["$","_" ++ show n])
451 setup vars
452 | Help.isTuple name = define "$" : vars
453 | otherwise = define "_raw" : safeAssign : vars
455 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
456 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
457 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
459 _ ->
460 do defs' <- concat <$> mapM toDef vars
461 return (VarDeclStmt () [define "_"] : defs')
462 where
463 vars = P.boundVarList annPattern
464 mkVar = A.A () . localVar
465 toDef y =
466 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
467 pat = A.A () (P.Var y)
468 in
469 defToStatements (Opt.Definition facts pat expr)
472-- CASE EXPRESSIONS
474generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
475generateCase tcc expr branches =
476 do (tempVar, initialMatch) <-
477 Case.toMatch branches
479 (revisedMatch, stmt) <-
480 case expr of
481 A.A _ (Var (Var.Canonical Var.Local x)) ->
482 return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
484 A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
485 return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
487 _ ->
488 do expr' <- toJsExpr expr
489 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
491 match' <- match tcc revisedMatch
493 jsBlock (stmt ++ match')
496match :: TailCallContext -> Case.Match -> State Int [Statement ()]
497match tcc mtch =
498 case mtch of
499 Case.Match name clauses mtch' ->
500 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
501 mtch'' <- match tcc mtch'
502 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
503 where
504 isLiteral p =
505 case p of
506 Case.Clause (Right _) _ _ ->
507 True
508 _ ->
509 False
511 access name =
512 if any isLiteral clauses then
513 obj [name]
514 else
515 obj (Help.splitDots name ++ ["ctor"])
517 format isChars expr =
518 if or isChars then
519 InfixExpr () OpAdd expr (string "")
520 else
521 expr
523 Case.Fail ->
524 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
526 Case.Break ->
527 return [BreakStmt () Nothing]
529 Case.Other expr ->
530 toStatementList <$> exprToCode tcc expr
532 Case.Seq ms ->
533 concat <$> mapM (match tcc) (dropEnd [] ms)
534 where
535 dropEnd acc [] = acc
536 dropEnd acc (m:ms) =
537 case m of
538 Case.Other _ -> acc ++ [m]
539 _ -> dropEnd (acc ++ [m]) ms
542clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
543clause tcc variable (Case.Clause value vars mtch) =
544 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
545 return ((,) isChar (CaseClause () pattern statemens))
546 where
547 vars' =
548 map (\n -> variable ++ "._" ++ show n) [0..]
550 (isChar, pattern) =
551 case value of
552 Right (Chr c) -> (True, string [c])
553 _ ->
554 (,) False $
555 case value of
556 Right (Boolean b) -> BoolLit () b
557 Right lit -> Literal.literal lit
558 Left (Var.Canonical _ name) ->
559 string name
562flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
563flattenLets defs lexpr@(A.A _ expr) =
564 case expr of
565 Let ds body -> flattenLets (defs ++ ds) body
566 _ -> (defs, lexpr)
569-- BINARY OPERATORS
571binop
572 :: Var.Canonical
573 -> Opt.Expr
574 -> Opt.Expr
575 -> State Int Code
576binop func left right
577 | func == Var.Canonical Var.BuiltIn "::" =
578 toCode (A.A () (Data "::" [left,right]))
580 | func == forwardCompose =
581 compose (collectLeftAssoc forwardCompose left right)
583 | func == backwardCompose =
584 compose (collectRightAssoc backwardCompose left right)
586 | func == forwardApply =
587 pipe (collectLeftAssoc forwardApply left right)
589 | func == backwardApply =
590 pipe (collectRightAssoc backwardApply left right)
592 | otherwise =
593 do jsLeft <- toJsExpr left
594 jsRight <- toJsExpr right
595 jsExpr (makeExpr func jsLeft jsRight)
598-- CONTROL FLOW OPERATOR HELPERS
600apply :: Expression () -> Expression () -> Expression ()
601apply arg func =
602 func <| arg
605compose :: [Opt.Expr] -> State Int Code
606compose functions =
607 do jsFunctions <- mapM toJsExpr functions
608 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
611pipe :: [Opt.Expr] -> State Int Code
612pipe expressions =
613 do (value:functions) <- mapM toJsExpr expressions
614 jsExpr $ List.foldl' apply value functions
617forwardCompose :: Var.Canonical
618forwardCompose =
619 inBasics ">>"
622backwardCompose :: Var.Canonical
623backwardCompose =
624 inBasics "<<"
627forwardApply :: Var.Canonical
628forwardApply =
629 inBasics "|>"
632backwardApply :: Var.Canonical
633backwardApply =
634 inBasics "<|"
637inBasics :: String -> Var.Canonical
638inBasics name =
639 Var.inCore ["Basics"] name
642-- BINARY OPERATOR HELPERS
644makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
645makeExpr qualifiedOp@(Var.Canonical home op) =
646 let
647 simpleMake left right =
648 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
649 in
650 if home == Var.Module (ModuleName.inCore ["Basics"]) then
651 Map.findWithDefault simpleMake op basicOps
652 else
653 simpleMake
656basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
657basicOps =
658 Map.fromList (infixOps ++ specialOps)
661infixOps :: [(String, Expression () -> Expression () -> Expression ())]
662infixOps =
663 let
664 infixOp str op =
665 (str, InfixExpr () op)
666 in
667 [ infixOp "+" OpAdd
668 , infixOp "-" OpSub
669 , infixOp "*" OpMul
670 , infixOp "/" OpDiv
671 , infixOp "&&" OpLAnd
672 , infixOp "||" OpLOr
673 ]
676specialOps :: [(String, Expression () -> Expression () -> Expression ())]
677specialOps =
678 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
679 , (,) "|>" $ flip (<|)
680 , (,) "==" $ \a b -> BuiltIn.eq a b
681 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
682 , (,) "<" $ cmp OpLT 0
683 , (,) ">" $ cmp OpGT 0
684 , (,) "<=" $ cmp OpLT 1
685 , (,) ">=" $ cmp OpGT (-1)
686 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
687 ]
690cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
691cmp op n a b =
692 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
695-- BINARY OPERATOR COLLECTORS
697-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
698collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
699collectRightAssoc desiredOp left right =
700 collectRightAssocHelp desiredOp [left] right
703collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
704collectRightAssocHelp desiredOp exprList expr =
705 case expr of
706 A.A _ (Binop op left right) | op == desiredOp ->
707 collectRightAssocHelp desiredOp (left : exprList) right
709 _ ->
710 expr : exprList
713-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
714collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
715collectLeftAssoc desiredOp left right =
716 collectLeftAssocHelp desiredOp [right] left
719collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
720collectLeftAssocHelp desiredOp exprList expr =
721 case expr of
722 A.A _ (Binop op left right) | op == desiredOp ->
723 collectLeftAssocHelp desiredOp (right : exprList) left
725 _ ->
726 expr : exprList