git.iko.soy/elk
on 99243c2 help sign in
elk/src/Generate/JavaScript.hs
744 lines 21 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.Crash as Crash
21import qualified Generate.JavaScript.Port as Port
22import qualified Generate.JavaScript.Variable as Var
23import qualified Optimize.Cases as Case
24import qualified Reporting.Annotation as A
25import qualified Reporting.Crash as Crash
28generate :: Module.Optimized -> String
29generate modul =
30 error "TODO" modul exprToCode
33-- HELPERS
35_Utils :: String -> Expression ()
36_Utils x =
37 obj ["_U", x]
40_List :: String -> Expression ()
41_List x =
42 obj ["_L", x]
45literal :: Literal -> Expression ()
46literal lit =
47 case lit of
48 Chr c -> _Utils "chr" <| string [c]
49 Str s -> string s
50 IntNum n -> IntLit () n
51 FloatNum n -> NumLit () n
52 Boolean b -> BoolLit () b
55-- CODE CHUNKS
57data Code
58 = JsExpr (Expression ())
59 | JsBlock [Statement ()]
62jsExpr :: Expression () -> State Int Code
63jsExpr exp =
64 return (JsExpr exp)
67jsBlock :: [Statement ()] -> State Int Code
68jsBlock exp =
69 return (JsBlock exp)
72isBlock :: Code -> Bool
73isBlock code =
74 case code of
75 JsBlock _ -> True
76 JsExpr _ -> False
79toStatementList :: Code -> [Statement ()]
80toStatementList code =
81 case code of
82 JsExpr expr ->
83 [ ret expr ]
84 JsBlock stmts ->
85 stmts
88toStatement :: Code -> Statement ()
89toStatement code =
90 case code of
91 JsExpr expr ->
92 ret expr
93 JsBlock [stmt] ->
94 stmt
95 JsBlock stmts ->
96 BlockStmt () stmts
99toExpr :: Code -> Expression ()
100toExpr code =
101 case code of
102 JsExpr expr ->
103 expr
104 JsBlock stmts ->
105 function [] stmts `call` []
108-- TAIL CALL CONTEXT
110type TailCallContext =
111 Maybe (String, [String], Label)
114type Label =
115 Id ()
118-- EXPRESSIONS
120toJsExpr :: Opt.Expr -> State Int (Expression ())
121toJsExpr =
122 exprToJsExpr Nothing
125toCode :: Opt.Expr -> State Int Code
126toCode =
127 exprToCode Nothing
130exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
131exprToJsExpr tcc canonicalExpr =
132 toExpr <$> exprToCode tcc canonicalExpr
135exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
136exprToCode tcc annotatedExpr@(A.A _ expr) =
137 case expr of
138 Var var ->
139 jsExpr $ Var.canonical var
141 Literal lit ->
142 jsExpr $ literal lit
144 Range lo hi ->
145 do lo' <- toJsExpr lo
146 hi' <- toJsExpr hi
147 jsExpr $ _List "range" `call` [lo',hi']
149 Access record field ->
150 do record' <- toJsExpr record
151 jsExpr $ DotRef () record' (var (Var.varName field))
153 Update record fields ->
154 do record' <- toJsExpr record
155 fields' <-
156 forM fields $ \(field, value) ->
157 do value' <- toJsExpr value
158 return $ ArrayLit () [ string (Var.varName field), value' ]
160 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
162 Record fields ->
163 do fields' <-
164 forM fields $ \(field, e) ->
165 (,) (Var.varName field) <$> toJsExpr e
167 let fieldMap =
168 List.foldl' combine Map.empty fields'
170 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
171 where
172 combine record (field, value) =
173 Map.insertWith (++) field [value] record
175 hidden fs =
176 ObjectLit () . map (prop *** ArrayLit ()) $
177 Map.toList (Map.filter (not . null) (Map.map tail fs))
179 visible fs =
180 map (first prop) (Map.toList (Map.map head fs))
182 Binop op leftExpr rightExpr ->
183 binop op leftExpr rightExpr
185 Lambda _ _ ->
186 generateFunction (Expr.collectLambdas annotatedExpr)
188 App _ _ ->
189 generateApplication tcc annotatedExpr
191 Let defs body ->
192 generateLet tcc defs body
194 If branches finally ->
195 generateIf tcc branches finally
197 Case expr branches ->
198 generateCase tcc expr branches
200 ExplicitList elements ->
201 do jsElements <- mapM toJsExpr elements
202 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
204 Data tag members ->
205 do jsMembers <- mapM toJsExpr members
206 jsExpr $ ObjectLit () (ctor : fields jsMembers)
207 where
208 ctor = (prop "ctor", string tag)
209 fields =
210 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
212 GLShader _uid src _tipe ->
213 jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
215 Port impl ->
216 case impl of
217 In name portType ->
218 jsExpr (Port.inbound name portType)
220 Out name expr portType ->
221 do expr' <- toJsExpr expr
222 jsExpr (Port.outbound name expr' portType)
224 Task name expr portType ->
225 do expr' <- toJsExpr expr
226 jsExpr (Port.task name expr' portType)
228 Crash details ->
229 jsExpr $ Crash.crash details
232-- FUNCTIONS
234generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
235generateFunction (args, initialBody) =
236 do (argVars, patternDefs) <- destructuredArgs args
237 code <- generateLet Nothing patternDefs initialBody
238 jsExpr (generateFunctionWithArity argVars code)
241generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
242generateTailFunction name (args, initialBody) =
243 do (argVars, patternDefs) <- destructuredArgs args
244 label <- Id () <$> Case.newVar
245 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
246 let whileLoop =
247 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
248 return (generateFunctionWithArity argVars whileLoop)
251generateFunctionWithArity :: [String] -> Code -> Expression ()
252generateFunctionWithArity args code =
253 let
254 arity = length args
255 in
256 if 2 <= arity && arity <= 9 then
257 let
258 fN = "F" ++ show arity
259 in
260 ref fN <| function args (toStatementList code)
261 else
262 let
263 (lastArg:otherArgs) = reverse args
264 innerBody = function [lastArg] (toStatementList code)
265 in
266 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
269destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
270destructuredArgs args =
271 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
272 return (argVars, Maybe.catMaybes maybePatternDefs)
275destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
276destructPattern pattern@(A.A ann pat) =
277 case pat of
278 P.Var x ->
279 return (Var.varName x, Nothing)
281 _ ->
282 do arg <- Case.newVar
283 return
284 ( arg
285 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
286 )
289-- APPLICATIONS
291generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
292generateApplication tcc expr =
293 let
294 (func:args) =
295 Expr.collectApps expr
297 arity =
298 length args
300 reassign name tempName =
301 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
303 aN =
304 "A" ++ show arity
305 in
306 case isTailCall tcc func arity of
307 Just (argNames, label) ->
308 do args' <- mapM toJsExpr args
309 tempNames <- mapM (\_ -> Case.newVar) args
310 jsBlock $
311 VarDeclStmt () (zipWith varDecl tempNames args')
312 : zipWith reassign argNames tempNames
313 ++ [ContinueStmt () (Just label)]
315 _ ->
316 do func' <- toJsExpr func
317 args' <- mapM toJsExpr args
318 jsExpr $
319 if 2 <= arity && arity <= 9 then
320 ref aN `call` (func':args')
321 else
322 foldl1 (<|) (func':args')
325isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
326isTailCall tcc (A.A _ func) arity =
327 case (func, tcc) of
328 (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
329 if name == tcName && length tcArgs == arity then
330 Just (tcArgs, tcLabel)
331 else
332 Nothing
334 (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
335 if name == tcName && length tcArgs == arity then
336 Just (tcArgs, tcLabel)
337 else
338 Nothing
340 _ ->
341 Nothing
344-- LET EXPRESSIONS
346generateLet
347 :: TailCallContext
348 -> [Opt.Def]
349 -> Opt.Expr
350 -> State Int Code
351generateLet tcc givenDefs givenBody =
352 do let (defs, body) = flattenLets givenDefs givenBody
353 stmts <- concat <$> mapM defToStatements defs
354 code <- exprToCode tcc body
355 jsBlock (stmts ++ toStatementList code)
358-- GENERATE IFS
360generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
361generateIf tcc givenBranches givenFinally =
362 let
363 (branches, finally) =
364 crushIfs givenBranches givenFinally
366 convertBranch (condition, expr) =
367 (,) <$> toJsExpr condition <*> exprToCode tcc expr
369 ifExpression (condition, branch) otherwise =
370 CondExpr () condition branch otherwise
372 ifStatement (condition, branch) otherwise =
373 IfStmt () condition branch otherwise
374 in
375 do jsBranches <- mapM convertBranch branches
376 jsFinally <- exprToCode tcc finally
378 if any isBlock (jsFinally : map snd jsBranches)
379 then
380 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
381 else
382 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
385crushIfs
386 :: [(Opt.Expr, Opt.Expr)]
387 -> Opt.Expr
388 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
389crushIfs branches finally =
390 crushIfsHelp [] branches finally
393crushIfsHelp
394 :: [(Opt.Expr, Opt.Expr)]
395 -> [(Opt.Expr, Opt.Expr)]
396 -> Opt.Expr
397 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
398crushIfsHelp visitedBranches unvisitedBranches finally =
399 case unvisitedBranches of
400 [] ->
401 case finally of
402 A.A _ (If subBranches subFinally) ->
403 crushIfsHelp visitedBranches subBranches subFinally
405 _ ->
406 (reverse visitedBranches, finally)
408 (A.A _ (Literal (Boolean True)), branch) : _ ->
409 crushIfsHelp visitedBranches [] branch
411 visiting : unvisited ->
412 crushIfsHelp (visiting : visitedBranches) unvisited finally
416-- DEFINITIONS
418defToStatements :: Opt.Def -> State Int [Statement ()]
419defToStatements (Opt.Definition facts pattern expr) =
420 case Opt.tailRecursionDetails facts of
421 Just name ->
422 do func <- generateTailFunction name (Expr.collectLambdas expr)
423 return [ VarDeclStmt () [ varDecl name func ] ]
425 Nothing ->
426 defToStatementsHelp facts pattern =<< toJsExpr expr
429defToStatementsHelp
430 :: Opt.Facts
431 -> P.Optimized
432 -> Expression ()
433 -> State Int [Statement ()]
434defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
435 let
436 define x =
437 varDecl x jsExpr
438 in
439 case pattern of
440 P.Var x ->
441 if Help.isOp x then
442 let
443 op = LBracket () (ref "_op") (string x)
444 in
445 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
446 else
447 return [ VarDeclStmt () [ define (Var.varName x) ] ]
449 P.Record fields ->
450 let
451 setField name =
452 varDecl name (obj ["$",name])
453 in
454 return [ VarDeclStmt () (define "$" : map setField fields) ]
456 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
457 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
458 where
459 vars = getVars patterns
460 getVars patterns =
461 case patterns of
462 A.A _ (P.Var x) : rest ->
463 (Var.varName x :) `fmap` getVars rest
464 [] ->
465 Just []
466 _ ->
467 Nothing
469 decl x n = varDecl x (obj ["$","_" ++ show n])
470 setup vars
471 | Help.isTuple name = define "$" : vars
472 | otherwise = define "_raw" : safeAssign : vars
474 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
475 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
476 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
478 _ ->
479 do defs' <- concat <$> mapM toDef vars
480 return (VarDeclStmt () [define "_"] : defs')
481 where
482 vars = P.boundVarList annPattern
483 mkVar = A.A () . localVar
484 toDef y =
485 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
486 pat = A.A () (P.Var y)
487 in
488 defToStatements (Opt.Definition facts pat expr)
491-- CASE EXPRESSIONS
493generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
494generateCase tcc expr branches =
495 do (tempVar, initialMatch) <-
496 Case.toMatch branches
498 (revisedMatch, stmt) <-
499 case expr of
500 A.A _ (Var (Var.Canonical Var.Local x)) ->
501 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
502 A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
503 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
504 _ ->
505 do expr' <- toJsExpr expr
506 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
508 match' <- match tcc revisedMatch
510 jsBlock (stmt ++ match')
513match :: TailCallContext -> Case.Match -> State Int [Statement ()]
514match tcc mtch =
515 case mtch of
516 Case.Match name clauses mtch' ->
517 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
518 mtch'' <- match tcc mtch'
519 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
520 where
521 isLiteral p =
522 case p of
523 Case.Clause (Right _) _ _ ->
524 True
525 _ ->
526 False
528 access name =
529 if any isLiteral clauses then
530 obj [name]
531 else
532 obj (Help.splitDots name ++ ["ctor"])
534 format isChars expr =
535 if or isChars then
536 InfixExpr () OpAdd expr (string "")
537 else
538 expr
540 Case.Fail ->
541 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
543 Case.Break ->
544 return [BreakStmt () Nothing]
546 Case.Other expr ->
547 toStatementList <$> exprToCode tcc expr
549 Case.Seq ms ->
550 concat <$> mapM (match tcc) (dropEnd [] ms)
551 where
552 dropEnd acc [] = acc
553 dropEnd acc (m:ms) =
554 case m of
555 Case.Other _ -> acc ++ [m]
556 _ -> dropEnd (acc ++ [m]) ms
559clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
560clause tcc variable (Case.Clause value vars mtch) =
561 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
562 return ((,) isChar (CaseClause () pattern statemens))
563 where
564 vars' =
565 map (\n -> variable ++ "._" ++ show n) [0..]
567 (isChar, pattern) =
568 case value of
569 Right (Chr c) -> (True, string [c])
570 _ ->
571 (,) False $
572 case value of
573 Right (Boolean b) -> BoolLit () b
574 Right lit -> literal lit
575 Left (Var.Canonical _ name) ->
576 string name
579flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
580flattenLets defs lexpr@(A.A _ expr) =
581 case expr of
582 Let ds body -> flattenLets (defs ++ ds) body
583 _ -> (defs, lexpr)
586-- BINARY OPERATORS
588binop
589 :: Var.Canonical
590 -> Opt.Expr
591 -> Opt.Expr
592 -> State Int Code
593binop func left right
594 | func == Var.Canonical Var.BuiltIn "::" =
595 toCode (A.A () (Data "::" [left,right]))
597 | func == forwardCompose =
598 compose (collectLeftAssoc forwardCompose left right)
600 | func == backwardCompose =
601 compose (collectRightAssoc backwardCompose left right)
603 | func == forwardApply =
604 pipe (collectLeftAssoc forwardApply left right)
606 | func == backwardApply =
607 pipe (collectRightAssoc backwardApply left right)
609 | otherwise =
610 do jsLeft <- toJsExpr left
611 jsRight <- toJsExpr right
612 jsExpr (makeExpr func jsLeft jsRight)
615-- CONTROL FLOW OPERATOR HELPERS
617apply :: Expression () -> Expression () -> Expression ()
618apply arg func =
619 func <| arg
622compose :: [Opt.Expr] -> State Int Code
623compose functions =
624 do jsFunctions <- mapM toJsExpr functions
625 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
628pipe :: [Opt.Expr] -> State Int Code
629pipe expressions =
630 do (value:functions) <- mapM toJsExpr expressions
631 jsExpr $ List.foldl' apply value functions
634forwardCompose :: Var.Canonical
635forwardCompose =
636 inBasics ">>"
639backwardCompose :: Var.Canonical
640backwardCompose =
641 inBasics "<<"
644forwardApply :: Var.Canonical
645forwardApply =
646 inBasics "|>"
649backwardApply :: Var.Canonical
650backwardApply =
651 inBasics "<|"
654inBasics :: String -> Var.Canonical
655inBasics name =
656 Var.inCore ["Basics"] name
659-- BINARY OPERATOR HELPERS
661makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
662makeExpr qualifiedOp@(Var.Canonical home op) =
663 let
664 simpleMake left right =
665 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
666 in
667 if home == Var.Module (ModuleName.inCore ["Basics"]) then
668 Map.findWithDefault simpleMake op basicOps
669 else
670 simpleMake
673basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
674basicOps =
675 Map.fromList (infixOps ++ specialOps)
678infixOps :: [(String, Expression () -> Expression () -> Expression ())]
679infixOps =
680 let
681 infixOp str op =
682 (str, InfixExpr () op)
683 in
684 [ infixOp "+" OpAdd
685 , infixOp "-" OpSub
686 , infixOp "*" OpMul
687 , infixOp "/" OpDiv
688 , infixOp "&&" OpLAnd
689 , infixOp "||" OpLOr
690 ]
693specialOps :: [(String, Expression () -> Expression () -> Expression ())]
694specialOps =
695 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
696 , (,) "|>" $ flip (<|)
697 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
698 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
699 , (,) "<" $ cmp OpLT 0
700 , (,) ">" $ cmp OpGT 0
701 , (,) "<=" $ cmp OpLT 1
702 , (,) ">=" $ cmp OpGT (-1)
703 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
704 ]
707cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
708cmp op n a b =
709 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
712-- BINARY OPERATOR COLLECTORS
714-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
715collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
716collectRightAssoc desiredOp left right =
717 collectRightAssocHelp desiredOp [left] right
720collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
721collectRightAssocHelp desiredOp exprList expr =
722 case expr of
723 A.A _ (Binop op left right) | op == desiredOp ->
724 collectRightAssocHelp desiredOp (left : exprList) right
726 _ ->
727 expr : exprList
730-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
731collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
732collectLeftAssoc desiredOp left right =
733 collectLeftAssocHelp desiredOp [right] left
736collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
737collectLeftAssocHelp desiredOp exprList expr =
738 case expr of
739 A.A _ (Binop op left right) | op == desiredOp ->
740 collectLeftAssocHelp desiredOp (right : exprList) left
742 _ ->
743 expr : exprList