git.iko.soy/elk
on 90243ae help sign in
elk/src/Generate/JavaScript.hs
751 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 combineIfs 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))
336combineIfs
337 :: [(Canonical.Expr, Canonical.Expr)]
338 -> Canonical.Expr
339 -> ([(Canonical.Expr, Canonical.Expr)], Canonical.Expr)
340combineIfs branches finally =
341 case finally of
342 A.A _ (MultiIf subBranches subFinally) ->
343 combineIfs (branches ++ subBranches) subFinally
345 _ ->
346 (branches, finally)
349-- DEFINITIONS
351defToStatements :: Canonical.Def -> State Int [Statement ()]
352defToStatements (Canonical.Definition pattern expr _) =
353 defToStatementsHelp pattern =<< exprToJsExpr expr
356defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]
357defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =
358 let
359 define x =
360 varDecl x jsExpr
361 in
362 case pattern of
363 P.Var x ->
364 if Help.isOp x then
365 let
366 op = LBracket () (ref "_op") (string x)
367 in
368 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
369 else
370 return [ VarDeclStmt () [ define (Var.varName x) ] ]
372 P.Record fields ->
373 let
374 setField name =
375 varDecl name (obj ["$",name])
376 in
377 return [ VarDeclStmt () (define "$" : map setField fields) ]
379 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
380 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
381 where
382 vars = getVars patterns
383 getVars patterns =
384 case patterns of
385 A.A _ (P.Var x) : rest ->
386 (Var.varName x :) `fmap` getVars rest
387 [] ->
388 Just []
389 _ ->
390 Nothing
392 decl x n = varDecl x (obj ["$","_" ++ show n])
393 setup vars
394 | Help.isTuple name = define "$" : vars
395 | otherwise = define "_raw" : safeAssign : vars
397 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
398 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
399 exception = Crash.crash patternRegion Crash.IncompletePatternMatch
401 _ ->
402 do defs' <- concat <$> mapM toDef vars
403 return (VarDeclStmt () [define "_"] : defs')
404 where
405 vars = P.boundVarList annPattern
406 mkVar = A.A patternRegion . localVar
407 toDef y =
408 let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]
409 pat = A.A patternRegion (P.Var y)
410 in
411 defToStatements (Canonical.Definition pat expr Nothing)
414-- CASE EXPRESSIONS
416generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code
417generateCase region expr branches =
418 do (tempVar, initialMatch) <-
419 Case.toMatch branches
421 (revisedMatch, stmt) <-
422 case expr of
423 A.A _ (Var (Var.Canonical Var.Local x)) ->
424 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
425 _ ->
426 do expr' <- exprToJsExpr expr
427 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
429 match' <- match region revisedMatch
431 jsBlock (stmt ++ match')
434match :: R.Region -> Case.Match -> State Int [Statement ()]
435match region mtch =
436 case mtch of
437 Case.Match name clauses mtch' ->
438 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
439 mtch'' <- match region mtch'
440 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
441 where
442 isLiteral p =
443 case p of
444 Case.Clause (Right _) _ _ ->
445 True
446 _ ->
447 False
449 access name =
450 if any isLiteral clauses then
451 obj [name]
452 else
453 obj (Help.splitDots name ++ ["ctor"])
455 format isChars expr =
456 if or isChars then
457 InfixExpr () OpAdd expr (string "")
458 else
459 expr
461 Case.Fail ->
462 return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]
464 Case.Break ->
465 return [BreakStmt () Nothing]
467 Case.Other expr ->
468 toStatementList <$> exprToCode expr
470 Case.Seq ms ->
471 concat <$> mapM (match region) (dropEnd [] ms)
472 where
473 dropEnd acc [] = acc
474 dropEnd acc (m:ms) =
475 case m of
476 Case.Other _ -> acc ++ [m]
477 _ -> dropEnd (acc ++ [m]) ms
480clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
481clause region variable (Case.Clause value vars mtch) =
482 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
483 where
484 vars' =
485 map (\n -> variable ++ "._" ++ show n) [0..]
487 (isChar, pattern) =
488 case value of
489 Right (Chr c) -> (True, string [c])
490 _ ->
491 (,) False $
492 case value of
493 Right (Boolean b) -> BoolLit () b
494 Right lit -> literal lit
495 Left (Var.Canonical _ name) ->
496 string name
499flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
500flattenLets defs lexpr@(A.A _ expr) =
501 case expr of
502 Let ds body -> flattenLets (defs ++ ds) body
503 _ -> (defs, lexpr)
506generate :: Module.CanonicalModule -> String
507generate modul =
508 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
509 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
510 where
511 names :: [String]
512 names = Module.names modul
514 thisModule :: Expression ()
515 thisModule = obj (localRuntime : names ++ ["values"])
517 programStmts :: [Statement ()]
518 programStmts =
519 concat
520 [ [ ExprStmt () (string "use strict") ]
521 , setup localRuntime (names ++ ["values"])
522 , [ IfSingleStmt () thisModule (ret thisModule) ]
523 , [ VarDeclStmt () localVars ]
524 , body
525 , [ jsExports ]
526 , [ ret thisModule ]
527 ]
529 localVars :: [VarDecl ()]
530 localVars =
531 varDecl "_op" (ObjectLit () [])
532 : internalImports (Module.names modul)
533 ++ explicitImports
534 where
535 explicitImports :: [VarDecl ()]
536 explicitImports =
537 Module.imports modul
538 |> Set.fromList
539 |> Set.toList
540 |> map jsImport
542 jsImport :: Module.Name -> VarDecl ()
543 jsImport name =
544 varDecl (Var.moduleName name) $
545 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
547 body :: [Statement ()]
548 body =
549 concat (evalState defs 0)
550 where
551 defs =
552 Module.program (Module.body modul)
553 |> flattenLets []
554 |> fst
555 |> mapM defToStatements
557 setup namespace path =
558 map create paths
559 where
560 create name =
561 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
562 paths =
563 namespace : path
564 |> List.inits
565 |> init
566 |> drop 2
568 jsExports =
569 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
570 where
571 exs = map entry $ "_op" : concatMap extract (exports modul)
572 entry x = (prop x, ref x)
573 extract value =
574 case value of
575 Var.Alias _ -> []
577 Var.Value x
578 | Help.isOp x -> []
579 | otherwise -> [Var.varName x]
581 Var.Union _ (Var.Listing ctors _) ->
582 map Var.varName ctors
584 assign path expr =
585 case path of
586 [x] -> VarDeclStmt () [ varDecl x expr ]
587 _ ->
588 ExprStmt () $
589 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
592-- BINARY OPERATORS
594binop
595 :: R.Region
596 -> Var.Canonical
597 -> Canonical.Expr
598 -> Canonical.Expr
599 -> State Int Code
600binop region func left right
601 | func == Var.Canonical Var.BuiltIn "::" =
602 exprToCode (A.A region (Data "::" [left,right]))
604 | func == forwardCompose =
605 compose (collectLeftAssoc forwardCompose left right)
607 | func == backwardCompose =
608 compose (collectRightAssoc backwardCompose left right)
610 | func == forwardApply =
611 pipe (collectLeftAssoc forwardApply left right)
613 | func == backwardApply =
614 pipe (collectRightAssoc backwardApply left right)
616 | otherwise =
617 do jsLeft <- exprToJsExpr left
618 jsRight <- exprToJsExpr right
619 jsExpr (makeExpr func jsLeft jsRight)
622-- CONTROL FLOW OPERATOR HELPERS
624apply :: Expression () -> Expression () -> Expression ()
625apply arg func =
626 func <| arg
629compose :: [Canonical.Expr] -> State Int Code
630compose functions =
631 do jsFunctions <- mapM exprToJsExpr functions
632 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
635pipe :: [Canonical.Expr] -> State Int Code
636pipe expressions =
637 do (value:functions) <- mapM exprToJsExpr expressions
638 jsExpr $ List.foldl' apply value functions
641forwardCompose :: Var.Canonical
642forwardCompose =
643 inBasics ">>"
646backwardCompose :: Var.Canonical
647backwardCompose =
648 inBasics "<<"
651forwardApply :: Var.Canonical
652forwardApply =
653 inBasics "|>"
656backwardApply :: Var.Canonical
657backwardApply =
658 inBasics "<|"
661inBasics :: String -> Var.Canonical
662inBasics name =
663 Var.Canonical (Var.Module ["Basics"]) name
666-- BINARY OPERATOR HELPERS
668makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
669makeExpr qualifiedOp@(Var.Canonical home op) =
670 let
671 simpleMake left right =
672 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
673 in
674 if home == Var.Module ["Basics"] then
675 Map.findWithDefault simpleMake op basicOps
676 else
677 simpleMake
680basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
681basicOps =
682 Map.fromList (infixOps ++ specialOps)
685infixOps :: [(String, Expression () -> Expression () -> Expression ())]
686infixOps =
687 let
688 infixOp str op =
689 (str, InfixExpr () op)
690 in
691 [ infixOp "+" OpAdd
692 , infixOp "-" OpSub
693 , infixOp "*" OpMul
694 , infixOp "/" OpDiv
695 , infixOp "&&" OpLAnd
696 , infixOp "||" OpLOr
697 ]
700specialOps :: [(String, Expression () -> Expression () -> Expression ())]
701specialOps =
702 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
703 , (,) "|>" $ flip (<|)
704 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
705 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
706 , (,) "<" $ cmp OpLT 0
707 , (,) ">" $ cmp OpGT 0
708 , (,) "<=" $ cmp OpLT 1
709 , (,) ">=" $ cmp OpGT (-1)
710 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
711 ]
714cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
715cmp op n a b =
716 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
719-- BINARY OPERATOR COLLECTORS
721-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
722collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
723collectRightAssoc desiredOp left right =
724 collectRightAssocHelp desiredOp [left] right
727collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
728collectRightAssocHelp desiredOp exprList expr =
729 case expr of
730 A.A _ (Binop op left right) | op == desiredOp ->
731 collectRightAssocHelp desiredOp (left : exprList) right
733 _ ->
734 expr : exprList
737-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
738collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
739collectLeftAssoc desiredOp left right =
740 collectLeftAssocHelp desiredOp [right] left
743collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
744collectLeftAssocHelp desiredOp exprList expr =
745 case expr of
746 A.A _ (Binop op left right) | op == desiredOp ->
747 collectLeftAssocHelp desiredOp (right : exprList) left
749 _ ->
750 expr : exprList