git.iko.soy/elk
on 6ccaf92 help sign in
elk/src/Generate/JavaScript.hs
725 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, [])
483 A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
484 return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
485 _ ->
486 do expr' <- toJsExpr expr
487 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
489 match' <- match tcc revisedMatch
491 jsBlock (stmt ++ match')
494match :: TailCallContext -> Case.Match -> State Int [Statement ()]
495match tcc mtch =
496 case mtch of
497 Case.Match name clauses mtch' ->
498 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
499 mtch'' <- match tcc mtch'
500 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
501 where
502 isLiteral p =
503 case p of
504 Case.Clause (Right _) _ _ ->
505 True
506 _ ->
507 False
509 access name =
510 if any isLiteral clauses then
511 obj [name]
512 else
513 obj (Help.splitDots name ++ ["ctor"])
515 format isChars expr =
516 if or isChars then
517 InfixExpr () OpAdd expr (string "")
518 else
519 expr
521 Case.Fail ->
522 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
524 Case.Break ->
525 return [BreakStmt () Nothing]
527 Case.Other expr ->
528 toStatementList <$> exprToCode tcc expr
530 Case.Seq ms ->
531 concat <$> mapM (match tcc) (dropEnd [] ms)
532 where
533 dropEnd acc [] = acc
534 dropEnd acc (m:ms) =
535 case m of
536 Case.Other _ -> acc ++ [m]
537 _ -> dropEnd (acc ++ [m]) ms
540clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
541clause tcc variable (Case.Clause value vars mtch) =
542 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
543 return ((,) isChar (CaseClause () pattern statemens))
544 where
545 vars' =
546 map (\n -> variable ++ "._" ++ show n) [0..]
548 (isChar, pattern) =
549 case value of
550 Right (Chr c) -> (True, string [c])
551 _ ->
552 (,) False $
553 case value of
554 Right (Boolean b) -> BoolLit () b
555 Right lit -> Literal.literal lit
556 Left (Var.Canonical _ name) ->
557 string name
560flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
561flattenLets defs lexpr@(A.A _ expr) =
562 case expr of
563 Let ds body -> flattenLets (defs ++ ds) body
564 _ -> (defs, lexpr)
567-- BINARY OPERATORS
569binop
570 :: Var.Canonical
571 -> Opt.Expr
572 -> Opt.Expr
573 -> State Int Code
574binop func left right
575 | func == Var.Canonical Var.BuiltIn "::" =
576 toCode (A.A () (Data "::" [left,right]))
578 | func == forwardCompose =
579 compose (collectLeftAssoc forwardCompose left right)
581 | func == backwardCompose =
582 compose (collectRightAssoc backwardCompose left right)
584 | func == forwardApply =
585 pipe (collectLeftAssoc forwardApply left right)
587 | func == backwardApply =
588 pipe (collectRightAssoc backwardApply left right)
590 | otherwise =
591 do jsLeft <- toJsExpr left
592 jsRight <- toJsExpr right
593 jsExpr (makeExpr func jsLeft jsRight)
596-- CONTROL FLOW OPERATOR HELPERS
598apply :: Expression () -> Expression () -> Expression ()
599apply arg func =
600 func <| arg
603compose :: [Opt.Expr] -> State Int Code
604compose functions =
605 do jsFunctions <- mapM toJsExpr functions
606 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
609pipe :: [Opt.Expr] -> State Int Code
610pipe expressions =
611 do (value:functions) <- mapM toJsExpr expressions
612 jsExpr $ List.foldl' apply value functions
615forwardCompose :: Var.Canonical
616forwardCompose =
617 inBasics ">>"
620backwardCompose :: Var.Canonical
621backwardCompose =
622 inBasics "<<"
625forwardApply :: Var.Canonical
626forwardApply =
627 inBasics "|>"
630backwardApply :: Var.Canonical
631backwardApply =
632 inBasics "<|"
635inBasics :: String -> Var.Canonical
636inBasics name =
637 Var.inCore ["Basics"] name
640-- BINARY OPERATOR HELPERS
642makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
643makeExpr qualifiedOp@(Var.Canonical home op) =
644 let
645 simpleMake left right =
646 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
647 in
648 if home == Var.Module (ModuleName.inCore ["Basics"]) then
649 Map.findWithDefault simpleMake op basicOps
650 else
651 simpleMake
654basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
655basicOps =
656 Map.fromList (infixOps ++ specialOps)
659infixOps :: [(String, Expression () -> Expression () -> Expression ())]
660infixOps =
661 let
662 infixOp str op =
663 (str, InfixExpr () op)
664 in
665 [ infixOp "+" OpAdd
666 , infixOp "-" OpSub
667 , infixOp "*" OpMul
668 , infixOp "/" OpDiv
669 , infixOp "&&" OpLAnd
670 , infixOp "||" OpLOr
671 ]
674specialOps :: [(String, Expression () -> Expression () -> Expression ())]
675specialOps =
676 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
677 , (,) "|>" $ flip (<|)
678 , (,) "==" $ \a b -> BuiltIn.eq a b
679 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
680 , (,) "<" $ cmp OpLT 0
681 , (,) ">" $ cmp OpGT 0
682 , (,) "<=" $ cmp OpLT 1
683 , (,) ">=" $ cmp OpGT (-1)
684 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
685 ]
688cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
689cmp op n a b =
690 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
693-- BINARY OPERATOR COLLECTORS
695-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
696collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
697collectRightAssoc desiredOp left right =
698 collectRightAssocHelp desiredOp [left] right
701collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
702collectRightAssocHelp desiredOp exprList expr =
703 case expr of
704 A.A _ (Binop op left right) | op == desiredOp ->
705 collectRightAssocHelp desiredOp (left : exprList) right
707 _ ->
708 expr : exprList
711-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
712collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
713collectLeftAssoc desiredOp left right =
714 collectLeftAssocHelp desiredOp [right] left
717collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
718collectLeftAssocHelp desiredOp exprList expr =
719 case expr of
720 A.A _ (Binop op left right) | op == desiredOp ->
721 collectLeftAssocHelp desiredOp (right : exprList) left
723 _ ->
724 expr : exprList