git.iko.soy/elk
on c67a181 help sign in
elk/src/Generate/JavaScript.hs
772 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.Canonical as Canonical
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
29import qualified Reporting.Region as R
32internalImports :: Module.Name -> [VarDecl ()]
33internalImports name =
34 [ varDecl "_N" (obj ["Elm","Native"])
35 , include "_U" "Utils"
36 , include "_L" "List"
37 , varDecl Crash.localModuleName (string (Module.nameToString name))
38 ]
39 where
40 include :: String -> String -> VarDecl ()
41 include alias modul =
42 varDecl alias (Help.make ["_N", modul])
45_Utils :: String -> Expression ()
46_Utils x =
47 obj ["_U", x]
50_List :: String -> Expression ()
51_List x =
52 obj ["_L", x]
55literal :: Literal -> Expression ()
56literal lit =
57 case lit of
58 Chr c -> _Utils "chr" <| string [c]
59 Str s -> string s
60 IntNum n -> IntLit () n
61 FloatNum n -> NumLit () n
62 Boolean b -> BoolLit () b
65-- CODE CHUNKS
67data Code
68 = JsExpr (Expression ())
69 | JsBlock [Statement ()]
72jsExpr :: Expression () -> State Int Code
73jsExpr exp =
74 return (JsExpr exp)
77jsBlock :: [Statement ()] -> State Int Code
78jsBlock exp =
79 return (JsBlock exp)
82isBlock :: Code -> Bool
83isBlock code =
84 case code of
85 JsBlock _ -> True
86 JsExpr _ -> False
89toStatementList :: Code -> [Statement ()]
90toStatementList code =
91 case code of
92 JsExpr expr ->
93 [ ret expr ]
94 JsBlock stmts ->
95 stmts
98toStatement :: Code -> Statement ()
99toStatement code =
100 case code of
101 JsExpr expr ->
102 ret expr
103 JsBlock [stmt] ->
104 stmt
105 JsBlock stmts ->
106 BlockStmt () stmts
109toExpr :: Code -> Expression ()
110toExpr code =
111 case code of
112 JsExpr expr ->
113 expr
114 JsBlock stmts ->
115 function [] stmts `call` []
118-- EXPRESSIONS
120exprToJsExpr :: Canonical.Expr -> State Int (Expression ())
121exprToJsExpr canonicalExpr =
122 toExpr <$> exprToCode canonicalExpr
125exprToCode :: Canonical.Expr -> State Int Code
126exprToCode annotatedExpr@(A.A region expr) =
127 case expr of
128 Var var ->
129 jsExpr $ Var.canonical var
131 Literal lit ->
132 jsExpr $ literal lit
134 Range lo hi ->
135 do lo' <- exprToJsExpr lo
136 hi' <- exprToJsExpr hi
137 jsExpr $ _List "range" `call` [lo',hi']
139 Access record field ->
140 do record' <- exprToJsExpr record
141 jsExpr $ DotRef () record' (var (Var.varName field))
143 Remove record field ->
144 do record' <- exprToJsExpr record
145 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
147 Insert record field value ->
148 do value' <- exprToJsExpr value
149 record' <- exprToJsExpr record
150 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
152 Modify record fields ->
153 do record' <- exprToJsExpr record
154 fields' <-
155 forM fields $ \(field, value) ->
156 do value' <- exprToJsExpr value
157 return $ ArrayLit () [ string (Var.varName field), value' ]
159 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
161 Record fields ->
162 do fields' <-
163 forM fields $ \(field, e) ->
164 (,) (Var.varName field) <$> exprToJsExpr e
166 let fieldMap =
167 List.foldl' combine Map.empty fields'
169 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
170 where
171 combine record (field, value) =
172 Map.insertWith (++) field [value] record
174 hidden fs =
175 ObjectLit () . map (prop *** ArrayLit ()) $
176 Map.toList (Map.filter (not . null) (Map.map tail fs))
178 visible fs =
179 map (first prop) (Map.toList (Map.map head fs))
181 Binop op leftExpr rightExpr ->
182 binop region op leftExpr rightExpr
184 Lambda _ _ ->
185 generateFunction (Expr.collectLambdas annotatedExpr)
187 App funcExpr argExpr ->
188 do func' <- exprToJsExpr func
189 args' <- mapM exprToJsExpr args
190 jsExpr $
191 case args' of
192 [arg] -> func' <| arg
193 _ | length args' <= 9 -> ref aN `call` (func':args')
194 | otherwise -> foldl1 (<|) (func':args')
195 where
196 aN = "A" ++ show (length args)
197 (func, args) = getArgs funcExpr [argExpr]
198 getArgs func args =
199 case func of
200 (A.A _ (App f arg)) -> getArgs f (arg : args)
201 _ -> (func, args)
203 Let defs body ->
204 generateLet defs body
206 MultiIf branches finally ->
207 generateIf branches finally
209 Case expr branches ->
210 generateCase region expr branches
212 ExplicitList elements ->
213 do jsElements <- mapM exprToJsExpr elements
214 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
216 Data tag members ->
217 do jsMembers <- mapM exprToJsExpr members
218 jsExpr $ ObjectLit () (ctor : fields jsMembers)
219 where
220 ctor = (prop "ctor", string tag)
221 fields =
222 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
224 GLShader _uid src _tipe ->
225 jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
227 Port impl ->
228 case impl of
229 In name portType ->
230 jsExpr (Port.inbound name portType)
232 Out name expr portType ->
233 do expr' <- exprToJsExpr expr
234 jsExpr (Port.outbound name expr' portType)
236 Task name expr portType ->
237 do expr' <- exprToJsExpr expr
238 jsExpr (Port.task name expr' portType)
240 Crash details ->
241 jsExpr $ Crash.crash region details
244-- FUNCTIONS
246generateFunction :: ([P.CanonicalPattern], Canonical.Expr) -> State Int Code
247generateFunction (args, initialBody) =
248 do (argVars, patternDefs) <- destructuredArgs args
249 code <- generateLet patternDefs initialBody
250 jsExpr (generateFunctionWithArity argVars code)
253generateFunctionWithArity :: [String] -> Code -> Expression ()
254generateFunctionWithArity args code =
255 let
256 arity = length args
257 in
258 if 2 <= arity && arity <= 9 then
259 let
260 fN = "F" ++ show arity
261 in
262 ref fN <| function args (toStatementList code)
263 else
264 let
265 (lastArg:otherArgs) = reverse args
266 innerBody = function [lastArg] (toStatementList code)
267 in
268 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
271destructuredArgs :: [P.CanonicalPattern] -> State Int ([String], [Canonical.Def])
272destructuredArgs args =
273 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
274 return (argVars, Maybe.catMaybes maybePatternDefs)
277destructPattern :: P.CanonicalPattern -> State Int (String, Maybe Canonical.Def)
278destructPattern pattern@(A.A ann pat) =
279 case pat of
280 P.Var x ->
281 return (Var.varName x, Nothing)
283 _ ->
284 do arg <- Case.newVar
285 return
286 ( arg
287 , Just $ Canonical.Definition pattern (A.A ann (localVar arg)) Nothing
288 )
291-- LET EXPRESSIONS
293generateLet
294 :: [Canonical.Def]
295 -> Canonical.Expr
296 -> State Int Code
297generateLet givenDefs givenBody =
298 do let (defs, body) = flattenLets givenDefs givenBody
299 case defs of
300 [] ->
301 exprToCode body
303 _ ->
304 do stmts <- concat <$> mapM defToStatements defs
305 code <- exprToCode body
306 jsBlock (stmts ++ toStatementList code)
309-- GENERATE IFS
311generateIf :: [(Canonical.Expr, Canonical.Expr)] -> Canonical.Expr -> State Int Code
312generateIf givenBranches givenFinally =
313 let
314 (branches, finally) =
315 crushIfs givenBranches givenFinally
317 convertBranch (condition, expr) =
318 (,) <$> exprToJsExpr condition <*> exprToCode expr
320 ifExpression (condition, branch) otherwise =
321 CondExpr () condition branch otherwise
323 ifStatement (condition, branch) otherwise =
324 IfStmt () condition branch otherwise
325 in
326 do jsBranches <- mapM convertBranch branches
327 jsFinally <- exprToCode finally
329 if any isBlock (jsFinally : map snd jsBranches)
330 then
331 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
332 else
333 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
336crushIfs
337 :: [(Canonical.Expr, Canonical.Expr)]
338 -> Canonical.Expr
339 -> ([(Canonical.Expr, Canonical.Expr)], Canonical.Expr)
340crushIfs branches finally =
341 crushIfsHelp [] branches finally
344crushIfsHelp
345 :: [(Canonical.Expr, Canonical.Expr)]
346 -> [(Canonical.Expr, Canonical.Expr)]
347 -> Canonical.Expr
348 -> ([(Canonical.Expr, Canonical.Expr)], Canonical.Expr)
349crushIfsHelp visitedBranches unvisitedBranches finally =
350 case unvisitedBranches of
351 [] ->
352 case finally of
353 A.A _ (MultiIf subBranches subFinally) ->
354 crushIfsHelp visitedBranches subBranches subFinally
356 _ ->
357 (reverse visitedBranches, finally)
359 (A.A _ (Literal (Boolean True)), branch) : _ ->
360 crushIfsHelp visitedBranches [] branch
362 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
363 crushIfsHelp visitedBranches [] branch
365 visiting : unvisited ->
366 crushIfsHelp (visiting : visitedBranches) unvisited finally
370-- DEFINITIONS
372defToStatements :: Canonical.Def -> State Int [Statement ()]
373defToStatements (Canonical.Definition pattern expr _) =
374 defToStatementsHelp pattern =<< exprToJsExpr expr
377defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]
378defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =
379 let
380 define x =
381 varDecl x jsExpr
382 in
383 case pattern of
384 P.Var x ->
385 if Help.isOp x then
386 let
387 op = LBracket () (ref "_op") (string x)
388 in
389 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
390 else
391 return [ VarDeclStmt () [ define (Var.varName x) ] ]
393 P.Record fields ->
394 let
395 setField name =
396 varDecl name (obj ["$",name])
397 in
398 return [ VarDeclStmt () (define "$" : map setField fields) ]
400 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
401 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
402 where
403 vars = getVars patterns
404 getVars patterns =
405 case patterns of
406 A.A _ (P.Var x) : rest ->
407 (Var.varName x :) `fmap` getVars rest
408 [] ->
409 Just []
410 _ ->
411 Nothing
413 decl x n = varDecl x (obj ["$","_" ++ show n])
414 setup vars
415 | Help.isTuple name = define "$" : vars
416 | otherwise = define "_raw" : safeAssign : vars
418 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
419 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
420 exception = Crash.crash patternRegion Crash.IncompletePatternMatch
422 _ ->
423 do defs' <- concat <$> mapM toDef vars
424 return (VarDeclStmt () [define "_"] : defs')
425 where
426 vars = P.boundVarList annPattern
427 mkVar = A.A patternRegion . localVar
428 toDef y =
429 let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]
430 pat = A.A patternRegion (P.Var y)
431 in
432 defToStatements (Canonical.Definition pat expr Nothing)
435-- CASE EXPRESSIONS
437generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code
438generateCase region expr branches =
439 do (tempVar, initialMatch) <-
440 Case.toMatch branches
442 (revisedMatch, stmt) <-
443 case expr of
444 A.A _ (Var (Var.Canonical Var.Local x)) ->
445 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
446 _ ->
447 do expr' <- exprToJsExpr expr
448 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
450 match' <- match region revisedMatch
452 jsBlock (stmt ++ match')
455match :: R.Region -> Case.Match -> State Int [Statement ()]
456match region mtch =
457 case mtch of
458 Case.Match name clauses mtch' ->
459 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
460 mtch'' <- match region mtch'
461 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
462 where
463 isLiteral p =
464 case p of
465 Case.Clause (Right _) _ _ ->
466 True
467 _ ->
468 False
470 access name =
471 if any isLiteral clauses then
472 obj [name]
473 else
474 obj (Help.splitDots name ++ ["ctor"])
476 format isChars expr =
477 if or isChars then
478 InfixExpr () OpAdd expr (string "")
479 else
480 expr
482 Case.Fail ->
483 return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]
485 Case.Break ->
486 return [BreakStmt () Nothing]
488 Case.Other expr ->
489 toStatementList <$> exprToCode expr
491 Case.Seq ms ->
492 concat <$> mapM (match region) (dropEnd [] ms)
493 where
494 dropEnd acc [] = acc
495 dropEnd acc (m:ms) =
496 case m of
497 Case.Other _ -> acc ++ [m]
498 _ -> dropEnd (acc ++ [m]) ms
501clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
502clause region variable (Case.Clause value vars mtch) =
503 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
504 where
505 vars' =
506 map (\n -> variable ++ "._" ++ show n) [0..]
508 (isChar, pattern) =
509 case value of
510 Right (Chr c) -> (True, string [c])
511 _ ->
512 (,) False $
513 case value of
514 Right (Boolean b) -> BoolLit () b
515 Right lit -> literal lit
516 Left (Var.Canonical _ name) ->
517 string name
520flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
521flattenLets defs lexpr@(A.A _ expr) =
522 case expr of
523 Let ds body -> flattenLets (defs ++ ds) body
524 _ -> (defs, lexpr)
527generate :: Module.CanonicalModule -> String
528generate modul =
529 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
530 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
531 where
532 names :: [String]
533 names = Module.names modul
535 thisModule :: Expression ()
536 thisModule = obj (localRuntime : names ++ ["values"])
538 programStmts :: [Statement ()]
539 programStmts =
540 concat
541 [ [ ExprStmt () (string "use strict") ]
542 , setup localRuntime (names ++ ["values"])
543 , [ IfSingleStmt () thisModule (ret thisModule) ]
544 , [ VarDeclStmt () localVars ]
545 , body
546 , [ jsExports ]
547 , [ ret thisModule ]
548 ]
550 localVars :: [VarDecl ()]
551 localVars =
552 varDecl "_op" (ObjectLit () [])
553 : internalImports (Module.names modul)
554 ++ explicitImports
555 where
556 explicitImports :: [VarDecl ()]
557 explicitImports =
558 Module.imports modul
559 |> Set.fromList
560 |> Set.toList
561 |> map jsImport
563 jsImport :: Module.Name -> VarDecl ()
564 jsImport name =
565 varDecl (Var.moduleName name) $
566 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
568 body :: [Statement ()]
569 body =
570 concat (evalState defs 0)
571 where
572 defs =
573 Module.program (Module.body modul)
574 |> flattenLets []
575 |> fst
576 |> mapM defToStatements
578 setup namespace path =
579 map create paths
580 where
581 create name =
582 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
583 paths =
584 namespace : path
585 |> List.inits
586 |> init
587 |> drop 2
589 jsExports =
590 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
591 where
592 exs = map entry $ "_op" : concatMap extract (exports modul)
593 entry x = (prop x, ref x)
594 extract value =
595 case value of
596 Var.Alias _ -> []
598 Var.Value x
599 | Help.isOp x -> []
600 | otherwise -> [Var.varName x]
602 Var.Union _ (Var.Listing ctors _) ->
603 map Var.varName ctors
605 assign path expr =
606 case path of
607 [x] -> VarDeclStmt () [ varDecl x expr ]
608 _ ->
609 ExprStmt () $
610 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
613-- BINARY OPERATORS
615binop
616 :: R.Region
617 -> Var.Canonical
618 -> Canonical.Expr
619 -> Canonical.Expr
620 -> State Int Code
621binop region func left right
622 | func == Var.Canonical Var.BuiltIn "::" =
623 exprToCode (A.A region (Data "::" [left,right]))
625 | func == forwardCompose =
626 compose (collectLeftAssoc forwardCompose left right)
628 | func == backwardCompose =
629 compose (collectRightAssoc backwardCompose left right)
631 | func == forwardApply =
632 pipe (collectLeftAssoc forwardApply left right)
634 | func == backwardApply =
635 pipe (collectRightAssoc backwardApply left right)
637 | otherwise =
638 do jsLeft <- exprToJsExpr left
639 jsRight <- exprToJsExpr right
640 jsExpr (makeExpr func jsLeft jsRight)
643-- CONTROL FLOW OPERATOR HELPERS
645apply :: Expression () -> Expression () -> Expression ()
646apply arg func =
647 func <| arg
650compose :: [Canonical.Expr] -> State Int Code
651compose functions =
652 do jsFunctions <- mapM exprToJsExpr functions
653 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
656pipe :: [Canonical.Expr] -> State Int Code
657pipe expressions =
658 do (value:functions) <- mapM exprToJsExpr expressions
659 jsExpr $ List.foldl' apply value functions
662forwardCompose :: Var.Canonical
663forwardCompose =
664 inBasics ">>"
667backwardCompose :: Var.Canonical
668backwardCompose =
669 inBasics "<<"
672forwardApply :: Var.Canonical
673forwardApply =
674 inBasics "|>"
677backwardApply :: Var.Canonical
678backwardApply =
679 inBasics "<|"
682inBasics :: String -> Var.Canonical
683inBasics name =
684 Var.Canonical (Var.Module ["Basics"]) name
687-- BINARY OPERATOR HELPERS
689makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
690makeExpr qualifiedOp@(Var.Canonical home op) =
691 let
692 simpleMake left right =
693 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
694 in
695 if home == Var.Module ["Basics"] then
696 Map.findWithDefault simpleMake op basicOps
697 else
698 simpleMake
701basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
702basicOps =
703 Map.fromList (infixOps ++ specialOps)
706infixOps :: [(String, Expression () -> Expression () -> Expression ())]
707infixOps =
708 let
709 infixOp str op =
710 (str, InfixExpr () op)
711 in
712 [ infixOp "+" OpAdd
713 , infixOp "-" OpSub
714 , infixOp "*" OpMul
715 , infixOp "/" OpDiv
716 , infixOp "&&" OpLAnd
717 , infixOp "||" OpLOr
718 ]
721specialOps :: [(String, Expression () -> Expression () -> Expression ())]
722specialOps =
723 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
724 , (,) "|>" $ flip (<|)
725 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
726 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
727 , (,) "<" $ cmp OpLT 0
728 , (,) ">" $ cmp OpGT 0
729 , (,) "<=" $ cmp OpLT 1
730 , (,) ">=" $ cmp OpGT (-1)
731 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
732 ]
735cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
736cmp op n a b =
737 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
740-- BINARY OPERATOR COLLECTORS
742-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
743collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
744collectRightAssoc desiredOp left right =
745 collectRightAssocHelp desiredOp [left] right
748collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
749collectRightAssocHelp desiredOp exprList expr =
750 case expr of
751 A.A _ (Binop op left right) | op == desiredOp ->
752 collectRightAssocHelp desiredOp (left : exprList) right
754 _ ->
755 expr : exprList
758-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
759collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
760collectLeftAssoc desiredOp left right =
761 collectLeftAssocHelp desiredOp [right] left
764collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
765collectLeftAssocHelp desiredOp exprList expr =
766 case expr of
767 A.A _ (Binop op left right) | op == desiredOp ->
768 collectLeftAssocHelp desiredOp (right : exprList) left
770 _ ->
771 expr : exprList