git.iko.soy/elk
on 7552469 help sign in
elk/src/Generate/JavaScript.hs
735 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 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 branches finally =
313 let
314 convertBranch (condition, expr) =
315 (,) <$> exprToJsExpr condition <*> exprToCode expr
317 ifExpression (condition, branch) otherwise =
318 CondExpr () condition branch otherwise
320 ifStatement (condition, branch) otherwise =
321 IfStmt () condition branch otherwise
322 in
323 do jsBranches <- mapM convertBranch branches
324 jsFinally <- exprToCode finally
326 if any isBlock (jsFinally : map snd jsBranches)
327 then
328 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
329 else
330 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
333-- DEFINITIONS
335defToStatements :: Canonical.Def -> State Int [Statement ()]
336defToStatements (Canonical.Definition pattern expr _) =
337 defToStatementsHelp pattern =<< exprToJsExpr expr
340defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]
341defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =
342 let
343 define x =
344 varDecl x jsExpr
345 in
346 case pattern of
347 P.Var x ->
348 if Help.isOp x then
349 let
350 op = LBracket () (ref "_op") (string x)
351 in
352 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
353 else
354 return [ VarDeclStmt () [ define (Var.varName x) ] ]
356 P.Record fields ->
357 let
358 setField name =
359 varDecl name (obj ["$",name])
360 in
361 return [ VarDeclStmt () (define "$" : map setField fields) ]
363 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
364 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
365 where
366 vars = getVars patterns
367 getVars patterns =
368 case patterns of
369 A.A _ (P.Var x) : rest ->
370 (Var.varName x :) `fmap` getVars rest
371 [] ->
372 Just []
373 _ ->
374 Nothing
376 decl x n = varDecl x (obj ["$","_" ++ show n])
377 setup vars
378 | Help.isTuple name = define "$" : vars
379 | otherwise = define "_raw" : safeAssign : vars
381 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
382 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
383 exception = Crash.crash patternRegion Crash.IncompletePatternMatch
385 _ ->
386 do defs' <- concat <$> mapM toDef vars
387 return (VarDeclStmt () [define "_"] : defs')
388 where
389 vars = P.boundVarList annPattern
390 mkVar = A.A patternRegion . localVar
391 toDef y =
392 let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]
393 pat = A.A patternRegion (P.Var y)
394 in
395 defToStatements (Canonical.Definition pat expr Nothing)
398-- CASE EXPRESSIONS
400generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code
401generateCase region expr branches =
402 do (tempVar, initialMatch) <-
403 Case.toMatch branches
405 (revisedMatch, stmt) <-
406 case expr of
407 A.A _ (Var (Var.Canonical Var.Local x)) ->
408 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
409 _ ->
410 do expr' <- exprToJsExpr expr
411 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
413 match' <- match region revisedMatch
415 jsBlock (stmt ++ match')
418match :: R.Region -> Case.Match -> State Int [Statement ()]
419match region mtch =
420 case mtch of
421 Case.Match name clauses mtch' ->
422 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
423 mtch'' <- match region mtch'
424 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
425 where
426 isLiteral p =
427 case p of
428 Case.Clause (Right _) _ _ ->
429 True
430 _ ->
431 False
433 access name =
434 if any isLiteral clauses then
435 obj [name]
436 else
437 obj (Help.splitDots name ++ ["ctor"])
439 format isChars expr =
440 if or isChars then
441 InfixExpr () OpAdd expr (string "")
442 else
443 expr
445 Case.Fail ->
446 return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]
448 Case.Break ->
449 return [BreakStmt () Nothing]
451 Case.Other expr ->
452 toStatementList <$> exprToCode expr
454 Case.Seq ms ->
455 concat <$> mapM (match region) (dropEnd [] ms)
456 where
457 dropEnd acc [] = acc
458 dropEnd acc (m:ms) =
459 case m of
460 Case.Other _ -> acc ++ [m]
461 _ -> dropEnd (acc ++ [m]) ms
464clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
465clause region variable (Case.Clause value vars mtch) =
466 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
467 where
468 vars' =
469 map (\n -> variable ++ "._" ++ show n) [0..]
471 (isChar, pattern) =
472 case value of
473 Right (Chr c) -> (True, string [c])
474 _ ->
475 (,) False $
476 case value of
477 Right (Boolean b) -> BoolLit () b
478 Right lit -> literal lit
479 Left (Var.Canonical _ name) ->
480 string name
483flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
484flattenLets defs lexpr@(A.A _ expr) =
485 case expr of
486 Let ds body -> flattenLets (defs ++ ds) body
487 _ -> (defs, lexpr)
490generate :: Module.CanonicalModule -> String
491generate modul =
492 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
493 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
494 where
495 names :: [String]
496 names = Module.names modul
498 thisModule :: Expression ()
499 thisModule = obj (localRuntime : names ++ ["values"])
501 programStmts :: [Statement ()]
502 programStmts =
503 concat
504 [ [ ExprStmt () (string "use strict") ]
505 , setup localRuntime (names ++ ["values"])
506 , [ IfSingleStmt () thisModule (ret thisModule) ]
507 , [ VarDeclStmt () localVars ]
508 , body
509 , [ jsExports ]
510 , [ ret thisModule ]
511 ]
513 localVars :: [VarDecl ()]
514 localVars =
515 varDecl "_op" (ObjectLit () [])
516 : internalImports (Module.names modul)
517 ++ explicitImports
518 where
519 explicitImports :: [VarDecl ()]
520 explicitImports =
521 Module.imports modul
522 |> Set.fromList
523 |> Set.toList
524 |> map jsImport
526 jsImport :: Module.Name -> VarDecl ()
527 jsImport name =
528 varDecl (Var.moduleName name) $
529 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
531 body :: [Statement ()]
532 body =
533 concat (evalState defs 0)
534 where
535 defs =
536 Module.program (Module.body modul)
537 |> flattenLets []
538 |> fst
539 |> mapM defToStatements
541 setup namespace path =
542 map create paths
543 where
544 create name =
545 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
546 paths =
547 namespace : path
548 |> List.inits
549 |> init
550 |> drop 2
552 jsExports =
553 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
554 where
555 exs = map entry $ "_op" : concatMap extract (exports modul)
556 entry x = (prop x, ref x)
557 extract value =
558 case value of
559 Var.Alias _ -> []
561 Var.Value x
562 | Help.isOp x -> []
563 | otherwise -> [Var.varName x]
565 Var.Union _ (Var.Listing ctors _) ->
566 map Var.varName ctors
568 assign path expr =
569 case path of
570 [x] -> VarDeclStmt () [ varDecl x expr ]
571 _ ->
572 ExprStmt () $
573 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
576-- BINARY OPERATORS
578binop
579 :: R.Region
580 -> Var.Canonical
581 -> Canonical.Expr
582 -> Canonical.Expr
583 -> State Int Code
584binop region func left right
585 | func == Var.Canonical Var.BuiltIn "::" =
586 exprToCode (A.A region (Data "::" [left,right]))
588 | func == forwardCompose =
589 compose (collectLeftAssoc forwardCompose left right)
591 | func == backwardCompose =
592 compose (collectRightAssoc backwardCompose left right)
594 | func == forwardApply =
595 pipe (collectLeftAssoc forwardApply left right)
597 | func == backwardApply =
598 pipe (collectRightAssoc backwardApply left right)
600 | otherwise =
601 do jsLeft <- exprToJsExpr left
602 jsRight <- exprToJsExpr right
603 jsExpr (makeExpr func jsLeft jsRight)
606-- CONTROL FLOW OPERATOR HELPERS
608apply :: Expression () -> Expression () -> Expression ()
609apply arg func =
610 func <| arg
613compose :: [Canonical.Expr] -> State Int Code
614compose functions =
615 do jsFunctions <- mapM exprToJsExpr functions
616 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
619pipe :: [Canonical.Expr] -> State Int Code
620pipe expressions =
621 do (value:functions) <- mapM exprToJsExpr expressions
622 jsExpr $ List.foldl' apply value functions
625forwardCompose :: Var.Canonical
626forwardCompose =
627 inBasics ">>"
630backwardCompose :: Var.Canonical
631backwardCompose =
632 inBasics "<<"
635forwardApply :: Var.Canonical
636forwardApply =
637 inBasics "|>"
640backwardApply :: Var.Canonical
641backwardApply =
642 inBasics "<|"
645inBasics :: String -> Var.Canonical
646inBasics name =
647 Var.Canonical (Var.Module ["Basics"]) name
650-- BINARY OPERATOR HELPERS
652makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
653makeExpr qualifiedOp@(Var.Canonical home op) =
654 let
655 simpleMake left right =
656 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
657 in
658 if home == Var.Module ["Basics"] then
659 Map.findWithDefault simpleMake op basicOps
660 else
661 simpleMake
664basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
665basicOps =
666 Map.fromList (infixOps ++ specialOps)
669infixOps :: [(String, Expression () -> Expression () -> Expression ())]
670infixOps =
671 let
672 infixOp str op =
673 (str, InfixExpr () op)
674 in
675 [ infixOp "+" OpAdd
676 , infixOp "-" OpSub
677 , infixOp "*" OpMul
678 , infixOp "/" OpDiv
679 , infixOp "&&" OpLAnd
680 , infixOp "||" OpLOr
681 ]
684specialOps :: [(String, Expression () -> Expression () -> Expression ())]
685specialOps =
686 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
687 , (,) "|>" $ flip (<|)
688 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
689 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
690 , (,) "<" $ cmp OpLT 0
691 , (,) ">" $ cmp OpGT 0
692 , (,) "<=" $ cmp OpLT 1
693 , (,) ">=" $ cmp OpGT (-1)
694 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
695 ]
698cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
699cmp op n a b =
700 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
703-- BINARY OPERATOR COLLECTORS
705-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
706collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
707collectRightAssoc desiredOp left right =
708 collectRightAssocHelp desiredOp [left] right
711collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
712collectRightAssocHelp desiredOp exprList expr =
713 case expr of
714 A.A _ (Binop op left right) | op == desiredOp ->
715 collectRightAssocHelp desiredOp (left : exprList) right
717 _ ->
718 expr : exprList
721-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
722collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
723collectLeftAssoc desiredOp left right =
724 collectLeftAssocHelp desiredOp [right] left
727collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
728collectLeftAssocHelp desiredOp exprList expr =
729 case expr of
730 A.A _ (Binop op left right) | op == desiredOp ->
731 collectLeftAssocHelp desiredOp (right : exprList) left
733 _ ->
734 expr : exprList