git.iko.soy/elk
on e35986b help sign in
elk/src/Generate/JavaScript.hs
779 lines 22 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 qualified Data.Set as Set
10import Language.ECMAScript3.PrettyPrint
11import Language.ECMAScript3.Syntax
13import AST.Module
14import AST.Expression.General as Expr
15import qualified AST.Expression.Optimized as Opt
16import qualified AST.Helpers as Help
17import AST.Literal
18import qualified AST.Module as Module
19import qualified AST.Pattern as P
20import qualified AST.Variable as Var
21import Elm.Utils ((|>))
22import Generate.JavaScript.Helpers as Help
23import qualified Generate.Cases as Case
24import qualified Generate.JavaScript.Crash as Crash
25import qualified Generate.JavaScript.Port as Port
26import qualified Generate.JavaScript.Variable as Var
27import qualified Reporting.Annotation as A
28import qualified Reporting.Crash as Crash
31internalImports :: Module.Name -> [VarDecl ()]
32internalImports name =
33 [ varDecl "_N" (obj ["Elm","Native"])
34 , include "_U" "Utils"
35 , include "_L" "List"
36 , varDecl Crash.localModuleName (string (Module.nameToString name))
37 ]
38 where
39 include :: String -> String -> VarDecl ()
40 include alias modul =
41 varDecl alias (Help.make ["_N", modul])
44_Utils :: String -> Expression ()
45_Utils x =
46 obj ["_U", x]
49_List :: String -> Expression ()
50_List x =
51 obj ["_L", x]
54literal :: Literal -> Expression ()
55literal lit =
56 case lit of
57 Chr c -> _Utils "chr" <| string [c]
58 Str s -> string s
59 IntNum n -> IntLit () n
60 FloatNum n -> NumLit () n
61 Boolean b -> BoolLit () b
64-- CODE CHUNKS
66data Code
67 = JsExpr (Expression ())
68 | JsBlock [Statement ()]
71jsExpr :: Expression () -> State Int Code
72jsExpr exp =
73 return (JsExpr exp)
76jsBlock :: [Statement ()] -> State Int Code
77jsBlock exp =
78 return (JsBlock exp)
81isBlock :: Code -> Bool
82isBlock code =
83 case code of
84 JsBlock _ -> True
85 JsExpr _ -> False
88toStatementList :: Code -> [Statement ()]
89toStatementList code =
90 case code of
91 JsExpr expr ->
92 [ ret expr ]
93 JsBlock stmts ->
94 stmts
97toStatement :: Code -> Statement ()
98toStatement code =
99 case code of
100 JsExpr expr ->
101 ret expr
102 JsBlock [stmt] ->
103 stmt
104 JsBlock stmts ->
105 BlockStmt () stmts
108toExpr :: Code -> Expression ()
109toExpr code =
110 case code of
111 JsExpr expr ->
112 expr
113 JsBlock stmts ->
114 function [] stmts `call` []
117-- EXPRESSIONS
119exprToJsExpr :: Opt.Expr -> State Int (Expression ())
120exprToJsExpr canonicalExpr =
121 toExpr <$> exprToCode canonicalExpr
124exprToCode :: Opt.Expr -> State Int Code
125exprToCode annotatedExpr@(A.A _ expr) =
126 case expr of
127 Var var ->
128 jsExpr $ Var.canonical var
130 Literal lit ->
131 jsExpr $ literal lit
133 Range lo hi ->
134 do lo' <- exprToJsExpr lo
135 hi' <- exprToJsExpr hi
136 jsExpr $ _List "range" `call` [lo',hi']
138 Access record field ->
139 do record' <- exprToJsExpr record
140 jsExpr $ DotRef () record' (var (Var.varName field))
142 Remove record field ->
143 do record' <- exprToJsExpr record
144 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
146 Insert record field value ->
147 do value' <- exprToJsExpr value
148 record' <- exprToJsExpr record
149 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
151 Modify record fields ->
152 do record' <- exprToJsExpr record
153 fields' <-
154 forM fields $ \(field, value) ->
155 do value' <- exprToJsExpr value
156 return $ ArrayLit () [ string (Var.varName field), value' ]
158 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
160 Record fields ->
161 do fields' <-
162 forM fields $ \(field, e) ->
163 (,) (Var.varName field) <$> exprToJsExpr e
165 let fieldMap =
166 List.foldl' combine Map.empty fields'
168 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
169 where
170 combine record (field, value) =
171 Map.insertWith (++) field [value] record
173 hidden fs =
174 ObjectLit () . map (prop *** ArrayLit ()) $
175 Map.toList (Map.filter (not . null) (Map.map tail fs))
177 visible fs =
178 map (first prop) (Map.toList (Map.map head fs))
180 Binop op leftExpr rightExpr ->
181 binop op leftExpr rightExpr
183 Lambda _ _ ->
184 generateFunction (Expr.collectLambdas annotatedExpr)
186 App funcExpr argExpr ->
187 do func' <- exprToJsExpr func
188 args' <- mapM exprToJsExpr args
189 jsExpr $
190 case args' of
191 [arg] -> func' <| arg
192 _ | length args' <= 9 -> ref aN `call` (func':args')
193 | otherwise -> foldl1 (<|) (func':args')
194 where
195 aN = "A" ++ show (length args)
196 (func, args) = getArgs funcExpr [argExpr]
197 getArgs func args =
198 case func of
199 (A.A _ (App f arg)) -> getArgs f (arg : args)
200 _ -> (func, args)
202 Let defs body ->
203 generateLet defs body
205 MultiIf branches finally ->
206 generateIf branches finally
208 Case expr branches ->
209 generateCase expr branches
211 ExplicitList elements ->
212 do jsElements <- mapM exprToJsExpr elements
213 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
215 Data tag members ->
216 do jsMembers <- mapM exprToJsExpr members
217 jsExpr $ ObjectLit () (ctor : fields jsMembers)
218 where
219 ctor = (prop "ctor", string tag)
220 fields =
221 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
223 GLShader _uid src _tipe ->
224 jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
226 Port impl ->
227 case impl of
228 In name portType ->
229 jsExpr (Port.inbound name portType)
231 Out name expr portType ->
232 do expr' <- exprToJsExpr expr
233 jsExpr (Port.outbound name expr' portType)
235 Task name expr portType ->
236 do expr' <- exprToJsExpr expr
237 jsExpr (Port.task name expr' portType)
239 Crash details ->
240 jsExpr $ Crash.crash details
243-- FUNCTIONS
245generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
246generateFunction (args, initialBody) =
247 do (argVars, patternDefs) <- destructuredArgs args
248 code <- generateLet patternDefs initialBody
249 jsExpr (generateFunctionWithArity argVars code)
252generateFunctionWithArity :: [String] -> Code -> Expression ()
253generateFunctionWithArity args code =
254 let
255 arity = length args
256 in
257 if 2 <= arity && arity <= 9 then
258 let
259 fN = "F" ++ show arity
260 in
261 ref fN <| function args (toStatementList code)
262 else
263 let
264 (lastArg:otherArgs) = reverse args
265 innerBody = function [lastArg] (toStatementList code)
266 in
267 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
270destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
271destructuredArgs args =
272 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
273 return (argVars, Maybe.catMaybes maybePatternDefs)
276destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
277destructPattern pattern@(A.A ann pat) =
278 case pat of
279 P.Var x ->
280 return (Var.varName x, Nothing)
282 _ ->
283 do arg <- Case.newVar
284 return
285 ( arg
286 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
287 )
290-- LET EXPRESSIONS
292generateLet
293 :: [Opt.Def]
294 -> Opt.Expr
295 -> State Int Code
296generateLet givenDefs givenBody =
297 do let (defs, body) = flattenLets givenDefs givenBody
298 case defs of
299 [] ->
300 exprToCode body
302 _ ->
303 do stmts <- concat <$> mapM defToStatements defs
304 code <- exprToCode body
305 jsBlock (stmts ++ toStatementList code)
308-- GENERATE IFS
310generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
311generateIf givenBranches givenFinally =
312 let
313 (branches, finally) =
314 crushIfs givenBranches givenFinally
316 convertBranch (condition, expr) =
317 (,) <$> exprToJsExpr condition <*> exprToCode expr
319 ifExpression (condition, branch) otherwise =
320 CondExpr () condition branch otherwise
322 ifStatement (condition, branch) otherwise =
323 IfStmt () condition branch otherwise
324 in
325 do jsBranches <- mapM convertBranch branches
326 jsFinally <- exprToCode finally
328 if any isBlock (jsFinally : map snd jsBranches)
329 then
330 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
331 else
332 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
335crushIfs
336 :: [(Opt.Expr, Opt.Expr)]
337 -> Opt.Expr
338 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
339crushIfs branches finally =
340 crushIfsHelp [] branches finally
343crushIfsHelp
344 :: [(Opt.Expr, Opt.Expr)]
345 -> [(Opt.Expr, Opt.Expr)]
346 -> Opt.Expr
347 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
348crushIfsHelp visitedBranches unvisitedBranches finally =
349 case unvisitedBranches of
350 [] ->
351 case finally of
352 A.A _ (MultiIf subBranches subFinally) ->
353 crushIfsHelp visitedBranches subBranches subFinally
355 _ ->
356 (reverse visitedBranches, finally)
358 (A.A _ (Literal (Boolean True)), branch) : _ ->
359 crushIfsHelp visitedBranches [] branch
361 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
362 crushIfsHelp visitedBranches [] branch
364 visiting : unvisited ->
365 crushIfsHelp (visiting : visitedBranches) unvisited finally
369-- DEFINITIONS
371defToStatements :: Opt.Def -> State Int [Statement ()]
372defToStatements (Opt.Definition facts pattern expr) =
373 case Opt.tailRecursionDetails facts of
374 Just (name, arity) ->
375 error "TODO" name arity
377 Nothing ->
378 defToStatementsHelp facts pattern =<< exprToJsExpr expr
381defToStatementsHelp
382 :: Opt.Facts
383 -> P.Optimized
384 -> Expression ()
385 -> State Int [Statement ()]
386defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
387 let
388 define x =
389 varDecl x jsExpr
390 in
391 case pattern of
392 P.Var x ->
393 if Help.isOp x then
394 let
395 op = LBracket () (ref "_op") (string x)
396 in
397 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
398 else
399 return [ VarDeclStmt () [ define (Var.varName x) ] ]
401 P.Record fields ->
402 let
403 setField name =
404 varDecl name (obj ["$",name])
405 in
406 return [ VarDeclStmt () (define "$" : map setField fields) ]
408 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
409 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
410 where
411 vars = getVars patterns
412 getVars patterns =
413 case patterns of
414 A.A _ (P.Var x) : rest ->
415 (Var.varName x :) `fmap` getVars rest
416 [] ->
417 Just []
418 _ ->
419 Nothing
421 decl x n = varDecl x (obj ["$","_" ++ show n])
422 setup vars
423 | Help.isTuple name = define "$" : vars
424 | otherwise = define "_raw" : safeAssign : vars
426 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
427 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
428 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
430 _ ->
431 do defs' <- concat <$> mapM toDef vars
432 return (VarDeclStmt () [define "_"] : defs')
433 where
434 vars = P.boundVarList annPattern
435 mkVar = A.A () . localVar
436 toDef y =
437 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
438 pat = A.A () (P.Var y)
439 in
440 defToStatements (Opt.Definition facts pat expr)
443-- CASE EXPRESSIONS
445generateCase :: Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
446generateCase expr branches =
447 do (tempVar, initialMatch) <-
448 Case.toMatch branches
450 (revisedMatch, stmt) <-
451 case expr of
452 A.A _ (Var (Var.Canonical Var.Local x)) ->
453 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
454 _ ->
455 do expr' <- exprToJsExpr expr
456 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
458 match' <- match revisedMatch
460 jsBlock (stmt ++ match')
463match :: Case.Match -> State Int [Statement ()]
464match mtch =
465 case mtch of
466 Case.Match name clauses mtch' ->
467 do (isChars, clauses') <- unzip <$> mapM (clause name) clauses
468 mtch'' <- match mtch'
469 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
470 where
471 isLiteral p =
472 case p of
473 Case.Clause (Right _) _ _ ->
474 True
475 _ ->
476 False
478 access name =
479 if any isLiteral clauses then
480 obj [name]
481 else
482 obj (Help.splitDots name ++ ["ctor"])
484 format isChars expr =
485 if or isChars then
486 InfixExpr () OpAdd expr (string "")
487 else
488 expr
490 Case.Fail ->
491 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
493 Case.Break ->
494 return [BreakStmt () Nothing]
496 Case.Other expr ->
497 toStatementList <$> exprToCode expr
499 Case.Seq ms ->
500 concat <$> mapM match (dropEnd [] ms)
501 where
502 dropEnd acc [] = acc
503 dropEnd acc (m:ms) =
504 case m of
505 Case.Other _ -> acc ++ [m]
506 _ -> dropEnd (acc ++ [m]) ms
509clause :: String -> Case.Clause -> State Int (Bool, CaseClause ())
510clause variable (Case.Clause value vars mtch) =
511 (,) isChar . CaseClause () pattern <$> match (Case.matchSubst (zip vars vars') mtch)
512 where
513 vars' =
514 map (\n -> variable ++ "._" ++ show n) [0..]
516 (isChar, pattern) =
517 case value of
518 Right (Chr c) -> (True, string [c])
519 _ ->
520 (,) False $
521 case value of
522 Right (Boolean b) -> BoolLit () b
523 Right lit -> literal lit
524 Left (Var.Canonical _ name) ->
525 string name
528flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
529flattenLets defs lexpr@(A.A _ expr) =
530 case expr of
531 Let ds body -> flattenLets (defs ++ ds) body
532 _ -> (defs, lexpr)
535generate :: Module.Optimized -> String
536generate modul =
537 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
538 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
539 where
540 names :: [String]
541 names = Module.names modul
543 thisModule :: Expression ()
544 thisModule = obj (localRuntime : names ++ ["values"])
546 programStmts :: [Statement ()]
547 programStmts =
548 concat
549 [ [ ExprStmt () (string "use strict") ]
550 , setup localRuntime (names ++ ["values"])
551 , [ IfSingleStmt () thisModule (ret thisModule) ]
552 , [ VarDeclStmt () localVars ]
553 , body
554 , [ jsExports ]
555 , [ ret thisModule ]
556 ]
558 localVars :: [VarDecl ()]
559 localVars =
560 varDecl "_op" (ObjectLit () [])
561 : internalImports (Module.names modul)
562 ++ explicitImports
563 where
564 explicitImports :: [VarDecl ()]
565 explicitImports =
566 Module.imports modul
567 |> Set.fromList
568 |> Set.toList
569 |> map jsImport
571 jsImport :: Module.Name -> VarDecl ()
572 jsImport name =
573 varDecl (Var.moduleName name) $
574 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
576 body :: [Statement ()]
577 body =
578 concat (evalState defs 0)
579 where
580 defs =
581 Module.program (Module.body modul)
582 |> flattenLets []
583 |> fst
584 |> mapM defToStatements
586 setup namespace path =
587 map create paths
588 where
589 create name =
590 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
591 paths =
592 namespace : path
593 |> List.inits
594 |> init
595 |> drop 2
597 jsExports =
598 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
599 where
600 exs = map entry $ "_op" : concatMap extract (exports modul)
601 entry x = (prop x, ref x)
602 extract value =
603 case value of
604 Var.Alias _ -> []
606 Var.Value x
607 | Help.isOp x -> []
608 | otherwise -> [Var.varName x]
610 Var.Union _ (Var.Listing ctors _) ->
611 map Var.varName ctors
613 assign path expr =
614 case path of
615 [x] -> VarDeclStmt () [ varDecl x expr ]
616 _ ->
617 ExprStmt () $
618 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
621-- BINARY OPERATORS
623binop
624 :: Var.Canonical
625 -> Opt.Expr
626 -> Opt.Expr
627 -> State Int Code
628binop func left right
629 | func == Var.Canonical Var.BuiltIn "::" =
630 exprToCode (A.A () (Data "::" [left,right]))
632 | func == forwardCompose =
633 compose (collectLeftAssoc forwardCompose left right)
635 | func == backwardCompose =
636 compose (collectRightAssoc backwardCompose left right)
638 | func == forwardApply =
639 pipe (collectLeftAssoc forwardApply left right)
641 | func == backwardApply =
642 pipe (collectRightAssoc backwardApply left right)
644 | otherwise =
645 do jsLeft <- exprToJsExpr left
646 jsRight <- exprToJsExpr right
647 jsExpr (makeExpr func jsLeft jsRight)
650-- CONTROL FLOW OPERATOR HELPERS
652apply :: Expression () -> Expression () -> Expression ()
653apply arg func =
654 func <| arg
657compose :: [Opt.Expr] -> State Int Code
658compose functions =
659 do jsFunctions <- mapM exprToJsExpr functions
660 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
663pipe :: [Opt.Expr] -> State Int Code
664pipe expressions =
665 do (value:functions) <- mapM exprToJsExpr expressions
666 jsExpr $ List.foldl' apply value functions
669forwardCompose :: Var.Canonical
670forwardCompose =
671 inBasics ">>"
674backwardCompose :: Var.Canonical
675backwardCompose =
676 inBasics "<<"
679forwardApply :: Var.Canonical
680forwardApply =
681 inBasics "|>"
684backwardApply :: Var.Canonical
685backwardApply =
686 inBasics "<|"
689inBasics :: String -> Var.Canonical
690inBasics name =
691 Var.Canonical (Var.Module ["Basics"]) name
694-- BINARY OPERATOR HELPERS
696makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
697makeExpr qualifiedOp@(Var.Canonical home op) =
698 let
699 simpleMake left right =
700 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
701 in
702 if home == Var.Module ["Basics"] then
703 Map.findWithDefault simpleMake op basicOps
704 else
705 simpleMake
708basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
709basicOps =
710 Map.fromList (infixOps ++ specialOps)
713infixOps :: [(String, Expression () -> Expression () -> Expression ())]
714infixOps =
715 let
716 infixOp str op =
717 (str, InfixExpr () op)
718 in
719 [ infixOp "+" OpAdd
720 , infixOp "-" OpSub
721 , infixOp "*" OpMul
722 , infixOp "/" OpDiv
723 , infixOp "&&" OpLAnd
724 , infixOp "||" OpLOr
725 ]
728specialOps :: [(String, Expression () -> Expression () -> Expression ())]
729specialOps =
730 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
731 , (,) "|>" $ flip (<|)
732 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
733 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
734 , (,) "<" $ cmp OpLT 0
735 , (,) ">" $ cmp OpGT 0
736 , (,) "<=" $ cmp OpLT 1
737 , (,) ">=" $ cmp OpGT (-1)
738 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
739 ]
742cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
743cmp op n a b =
744 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
747-- BINARY OPERATOR COLLECTORS
749-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
750collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
751collectRightAssoc desiredOp left right =
752 collectRightAssocHelp desiredOp [left] right
755collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
756collectRightAssocHelp desiredOp exprList expr =
757 case expr of
758 A.A _ (Binop op left right) | op == desiredOp ->
759 collectRightAssocHelp desiredOp (left : exprList) right
761 _ ->
762 expr : exprList
765-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
766collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
767collectLeftAssoc desiredOp left right =
768 collectLeftAssocHelp desiredOp [right] left
771collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
772collectLeftAssocHelp desiredOp exprList expr =
773 case expr of
774 A.A _ (Binop op left right) | op == desiredOp ->
775 collectLeftAssocHelp desiredOp (right : exprList) left
777 _ ->
778 expr : exprList