git.iko.soy/elk
on f91c6d0 help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1055 lines 27 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateField
6 , generateTailDef
7 , generateMain
8 , Code
9 , codeToExpr
10 , codeToStmtList
11 )
12 where
15import qualified Data.IntMap as IntMap
16import qualified Data.List as List
17import Data.Map ((!))
18import qualified Data.Map as Map
19import qualified Data.Text.Encoding as Text
21import qualified AST.Canonical as Can
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Index as Index
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Name as N
28import qualified Elm.Package as Pkg
29import qualified Elm.Compiler.Version as Version
30import qualified Generate.JavaScript.Builder as JS
31import qualified Generate.JavaScript.Mode as Mode
32import qualified Generate.JavaScript.Name as Name
33import qualified Json.Encode as Encode
34import qualified Optimize.DecisionTree as DT
35import qualified Reporting.Region as R
39-- EXPRESSIONS
42generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
43generateJsExpr mode expression =
44 codeToExpr (generate mode expression)
47generate :: Mode.Mode -> Opt.Expr -> Code
48generate mode expression =
49 case expression of
50 Opt.Bool bool ->
51 JsExpr $ JS.Bool bool
53 Opt.Chr char ->
54 JsExpr $
55 case mode of
56 Mode.Dev _ _ ->
57 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
59 Mode.Prod _ _ ->
60 JS.String (Text.encodeUtf8Builder char)
62 Opt.Str string ->
63 JsExpr $ JS.String (Text.encodeUtf8Builder string)
65 Opt.Int int ->
66 JsExpr $ JS.Int int
68 Opt.Float float ->
69 JsExpr $ JS.Float float
71 Opt.VarLocal name ->
72 JsExpr $ JS.Ref (Name.fromLocal name)
74 Opt.VarGlobal (Opt.Global home name) ->
75 JsExpr $ JS.Ref (Name.fromGlobal home name)
77 Opt.VarEnum (Opt.Global home name) index ->
78 case mode of
79 Mode.Dev _ _ ->
80 JsExpr $ JS.Ref (Name.fromGlobal home name)
82 Mode.Prod _ _ ->
83 JsExpr $ JS.Int (Index.toMachine index)
85 Opt.VarBox (Opt.Global home name) ->
86 JsExpr $ JS.Ref $
87 case mode of
88 Mode.Dev _ _ -> Name.fromGlobal home name
89 Mode.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
91 Opt.VarCycle home name ->
92 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
94 Opt.VarDebug name home region unhandledValueName ->
95 JsExpr $ generateDebug name home region unhandledValueName
97 Opt.VarKernel home name ->
98 JsExpr $ JS.Ref (Name.fromKernel home name)
100 Opt.List entries ->
101 case entries of
102 [] ->
103 JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")
105 _ ->
106 JsExpr $
107 JS.Call
108 (JS.Ref (Name.fromKernel N.list "fromArray"))
109 [ JS.Array $ map (generateJsExpr mode) entries
110 ]
112 Opt.Function args body ->
113 generateFunction (map Name.fromLocal args) (generate mode body)
115 Opt.Call func args ->
116 JsExpr $ generateCall mode func args
118 Opt.TailCall name args ->
119 JsBlock $ generateTailCall mode name args
121 Opt.If branches final ->
122 generateIf mode branches final
124 Opt.Let def body ->
125 JsBlock $
126 generateDef mode def : codeToStmtList (generate mode body)
128 Opt.Destruct (Opt.Destructor name path) body ->
129 let
130 pathExpr = generatePath mode path
131 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
132 in
133 JsBlock $ pathDef : codeToStmtList (generate mode body)
135 Opt.Case label root decider jumps ->
136 JsBlock $ generateCase mode label root decider jumps
138 Opt.Accessor field ->
139 JsExpr $ JS.Function Nothing [Name.dollar]
140 [ JS.Return $ Just $
141 JS.Access (JS.Ref Name.dollar) (generateField mode field)
142 ]
144 Opt.Access record field ->
145 JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)
147 Opt.Update record fields ->
148 JsExpr $
149 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
150 [ generateJsExpr mode record
151 , generateRecord mode fields
152 ]
154 Opt.Record fields ->
155 JsExpr $ generateRecord mode fields
157 Opt.Unit ->
158 case mode of
159 Mode.Dev _ _ ->
160 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
162 Mode.Prod _ _ ->
163 JsExpr $ JS.Int 0
165 Opt.Tuple a b maybeC ->
166 JsExpr $
167 case maybeC of
168 Nothing ->
169 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
170 [ generateJsExpr mode a
171 , generateJsExpr mode b
172 ]
174 Just c ->
175 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
176 [ generateJsExpr mode a
177 , generateJsExpr mode b
178 , generateJsExpr mode c
179 ]
181 Opt.Shader src ->
182 let string = JS.String (Text.encodeUtf8Builder src) in
183 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
187-- CODE CHUNKS
190data Code
191 = JsExpr JS.Expr
192 | JsBlock [JS.Stmt]
195codeToExpr :: Code -> JS.Expr
196codeToExpr code =
197 case code of
198 JsExpr expr ->
199 expr
201 JsBlock [ JS.Return (Just expr) ] ->
202 expr
204 JsBlock stmts ->
205 JS.Call (JS.Function Nothing [] stmts) []
208codeToStmtList :: Code -> [JS.Stmt]
209codeToStmtList code =
210 case code of
211 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
212 stmts
214 JsExpr expr ->
215 [ JS.Return (Just expr) ]
217 JsBlock stmts ->
218 stmts
221codeToStmt :: Code -> JS.Stmt
222codeToStmt code =
223 case code of
224 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
225 JS.Block stmts
227 JsExpr expr ->
228 JS.Return (Just expr)
230 JsBlock [stmt] ->
231 stmt
233 JsBlock stmts ->
234 JS.Block stmts
238-- CHARS
241{-# NOINLINE toChar #-}
242toChar :: JS.Expr
243toChar =
244 JS.Ref (Name.fromKernel N.utils "chr")
248-- CTOR
251generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
252generateCtor mode (Opt.Global home name) index arity =
253 let
254 argNames =
255 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
257 ctorTag =
258 case mode of
259 Mode.Dev _ _ -> JS.String (N.toBuilder name)
260 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
261 in
262 generateFunction argNames $ JsExpr $ JS.Object $
263 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
266ctorToInt :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Int
267ctorToInt home name index =
268 if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
269 0 - Index.toHuman index
270 else
271 Index.toMachine index
275-- RECORDS
278generateRecord :: Mode.Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
279generateRecord mode fields =
280 let
281 toPair (field, value) =
282 (generateField mode field, generateJsExpr mode value)
283 in
284 JS.Object (map toPair (Map.toList fields))
287generateField :: Mode.Mode -> N.Name -> Name.Name
288generateField mode name =
289 case mode of
290 Mode.Dev _ _ ->
291 Name.fromLocal name
293 Mode.Prod _ fields ->
294 fields ! name
299-- DEBUG
302generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
303generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
304 if name /= "todo" then
305 JS.Ref (Name.fromGlobal ModuleName.debug name)
306 else
307 case unhandledValueName of
308 Nothing ->
309 JS.Call (JS.Ref (Name.fromKernel N.debug "todo")) $
310 [ JS.String (N.toBuilder home)
311 , regionToJsExpr region
312 ]
314 Just valueName ->
315 JS.Call (JS.Ref (Name.fromKernel N.debug "todoCase")) $
316 [ JS.String (N.toBuilder home)
317 , regionToJsExpr region
318 , JS.Ref (Name.fromLocal valueName)
319 ]
322regionToJsExpr :: R.Region -> JS.Expr
323regionToJsExpr (R.Region start end) =
324 JS.Object
325 [ ( Name.fromLocal "start", positionToJsExpr start )
326 , ( Name.fromLocal "end", positionToJsExpr end )
327 ]
330positionToJsExpr :: R.Position -> JS.Expr
331positionToJsExpr (R.Position line column) =
332 JS.Object
333 [ ( Name.fromLocal "line", JS.Int line )
334 , ( Name.fromLocal "column", JS.Int column )
335 ]
339-- FUNCTION
342generateFunction :: [Name.Name] -> Code -> Code
343generateFunction args body =
344 case IntMap.lookup (length args) funcHelpers of
345 Just helper ->
346 JsExpr $
347 JS.Call helper
348 [ JS.Function Nothing args $
349 codeToStmtList body
350 ]
352 Nothing ->
353 let
354 addArg arg code =
355 JsExpr $ JS.Function Nothing [arg] $
356 codeToStmtList code
357 in
358 foldr addArg body args
361{-# NOINLINE funcHelpers #-}
362funcHelpers :: IntMap.IntMap JS.Expr
363funcHelpers =
364 IntMap.fromList $
365 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
369-- CALLS
372generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
373generateCall mode func args =
374 case func of
375 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
376 generateCoreCall mode global args
378 Opt.VarBox _ ->
379 case mode of
380 Mode.Dev _ _ ->
381 generateCallHelp mode func args
383 Mode.Prod _ _ ->
384 case args of
385 [arg] ->
386 generateJsExpr mode arg
388 _ ->
389 generateCallHelp mode func args
391 _ ->
392 generateCallHelp mode func args
395generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
396generateCallHelp mode func args =
397 generateNormalCall
398 (generateJsExpr mode func)
399 (map (generateJsExpr mode) args)
402generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
403generateGlobalCall home name args =
404 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
407generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
408generateNormalCall func args =
409 case IntMap.lookup (length args) callHelpers of
410 Just helper ->
411 JS.Call helper (func:args)
413 Nothing ->
414 List.foldl' (\f a -> JS.Call f [a]) func args
417{-# NOINLINE callHelpers #-}
418callHelpers :: IntMap.IntMap JS.Expr
419callHelpers =
420 IntMap.fromList $
421 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
425-- CORE CALLS
428generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
429generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
430 if moduleName == N.basics then
431 generateBasicsCall mode home name args
433 else if moduleName == N.bitwise then
434 generateBitwiseCall home name (map (generateJsExpr mode) args)
436 else if moduleName == N.tuple then
437 generateTupleCall home name (map (generateJsExpr mode) args)
439 else if moduleName == N.jsArray then
440 generateJsArrayCall home name (map (generateJsExpr mode) args)
442 else
443 generateGlobalCall home name (map (generateJsExpr mode) args)
446generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
447generateTupleCall home name args =
448 case args of
449 [value] ->
450 case name of
451 "first" -> JS.Access value (Name.fromLocal "a")
452 "second" -> JS.Access value (Name.fromLocal "b")
453 _ -> generateGlobalCall home name args
455 _ ->
456 generateGlobalCall home name args
459generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
460generateJsArrayCall home name args =
461 case args of
462 [entry] | name == "singleton" -> JS.Array [entry]
463 [index, array] | name == "unsafeGet" -> JS.Index array index
464 _ -> generateGlobalCall home name args
467generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
468generateBitwiseCall home name args =
469 case args of
470 [arg] ->
471 case name of
472 "complement" -> JS.Prefix JS.PrefixBNot arg
473 _ -> generateGlobalCall home name args
475 [left,right] ->
476 case name of
477 "and" -> JS.Infix JS.OpBAnd left right
478 "or" -> JS.Infix JS.OpBOr left right
479 "xor" -> JS.Infix JS.OpBXor left right
480 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
481 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
482 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
483 _ -> generateGlobalCall home name args
485 _ ->
486 generateGlobalCall home name args
489generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
490generateBasicsCall mode home name args =
491 case args of
492 [elmArg] ->
493 let arg = generateJsExpr mode elmArg in
494 case name of
495 "not" -> JS.Prefix JS.PrefixLNot arg
496 "negate" -> JS.Prefix JS.PrefixMinus arg
497 "toFloat" -> arg
498 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
499 _ -> generateGlobalCall home name [arg]
501 [elmLeft, elmRight] ->
502 case name of
503 "composeL" -> decomposeL mode elmLeft [elmRight]
504 "composeR" -> decomposeR mode [elmLeft] elmRight
505 "append" -> append mode elmLeft elmRight
506 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
507 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
508 _ ->
509 let
510 left = generateJsExpr mode elmLeft
511 right = generateJsExpr mode elmRight
512 in
513 case name of
514 "add" -> JS.Infix JS.OpAdd left right
515 "sub" -> JS.Infix JS.OpSub left right
516 "mul" -> JS.Infix JS.OpMul left right
517 "fdiv" -> JS.Infix JS.OpDiv left right
518 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
519 "eq" -> equal left right
520 "neq" -> notEqual left right
521 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
522 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
523 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
524 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
525 "or" -> JS.Infix JS.OpLOr left right
526 "and" -> JS.Infix JS.OpLAnd left right
527 "xor" -> JS.Infix JS.OpStrictNEq left right
528 "remainderBy" -> JS.Infix JS.OpMod right left
529 _ -> generateGlobalCall home name [left, right]
531 _ ->
532 generateGlobalCall home name (map (generateJsExpr mode) args)
535equal :: JS.Expr -> JS.Expr -> JS.Expr
536equal left right =
537 if isLiteral left || isLiteral right then
538 strictEq left right
539 else
540 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
543notEqual :: JS.Expr -> JS.Expr -> JS.Expr
544notEqual left right =
545 if isLiteral left || isLiteral right then
546 strictNEq left right
547 else
548 JS.Prefix JS.PrefixLNot $
549 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
552cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
553cmp idealOp backupOp backupInt left right =
554 if isLiteral left || isLiteral right then
555 JS.Infix idealOp left right
556 else
557 JS.Infix backupOp
558 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
559 (JS.Int backupInt)
562isLiteral :: JS.Expr -> Bool
563isLiteral expr =
564 case expr of
565 JS.String _ ->
566 True
568 JS.Float _ ->
569 True
571 JS.Int _ ->
572 True
574 JS.Bool _ ->
575 True
577 _ ->
578 False
581decomposeL :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
582decomposeL mode expr funcs =
583 case expr of
584 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
585 | home == ModuleName.basics ->
586 decomposeL mode left (func:funcs)
588 _ ->
589 generateJsExpr mode $
590 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
593decomposeR :: Mode.Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
594decomposeR mode funcs expr =
595 case expr of
596 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
597 | home == ModuleName.basics ->
598 decomposeR mode (func:funcs) right
600 _ ->
601 generateJsExpr mode $
602 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
605apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
606apply func value =
607 case func of
608 Opt.Accessor field ->
609 Opt.Access value field
611 Opt.Call f args ->
612 Opt.Call f (args ++ [value])
614 _ ->
615 Opt.Call func [value]
618append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
619append mode left right =
620 let seqs = generateJsExpr mode left : toSeqs mode right in
621 if any isStringLiteral seqs then
622 foldr1 (JS.Infix JS.OpAdd) seqs
623 else
624 foldr1 jsAppend seqs
627jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
628jsAppend a b =
629 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
632toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
633toSeqs mode expr =
634 case expr of
635 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
636 | home == ModuleName.basics ->
637 generateJsExpr mode left : toSeqs mode right
639 _ ->
640 [generateJsExpr mode expr]
643isStringLiteral :: JS.Expr -> Bool
644isStringLiteral expr =
645 case expr of
646 JS.String _ ->
647 True
649 _ ->
650 False
654-- SIMPLIFY INFIX OPERATORS
657strictEq :: JS.Expr -> JS.Expr -> JS.Expr
658strictEq left right =
659 case left of
660 JS.Int 0 ->
661 JS.Prefix JS.PrefixLNot right
663 JS.Bool bool ->
664 if bool then right else JS.Prefix JS.PrefixLNot right
666 _ ->
667 case right of
668 JS.Int 0 ->
669 JS.Prefix JS.PrefixLNot left
671 JS.Bool bool ->
672 if bool then left else JS.Prefix JS.PrefixLNot left
674 _ ->
675 JS.Infix JS.OpStrictEq left right
678strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
679strictNEq left right =
680 case left of
681 JS.Int 0 ->
682 right
684 JS.Bool bool ->
685 if bool then JS.Prefix JS.PrefixLNot right else right
687 _ ->
688 case right of
689 JS.Int 0 ->
690 left
692 JS.Bool bool ->
693 if bool then JS.Prefix JS.PrefixLNot left else left
695 _ ->
696 JS.Infix JS.OpStrictNEq left right
700-- TAIL CALL
703-- TODO check if JS minifiers collapse unnecessary temporary variables
704--
705generateTailCall :: Mode.Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
706generateTailCall mode name args =
707 let
708 toTempVars (argName, arg) =
709 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
711 toRealVars (argName, _) =
712 JS.ExprStmt $
713 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
714 in
715 JS.Var (map toTempVars args)
716 : map toRealVars args
717 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
721-- DEFINITIONS
724generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
725generateDef mode def =
726 case def of
727 Opt.Def name body ->
728 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
730 Opt.TailDef name argNames body ->
731 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
734generateTailDef :: Mode.Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
735generateTailDef mode name argNames body =
736 generateFunction (map Name.fromLocal argNames) $ JsBlock $
737 [ JS.Labelled (Name.fromLocal name) $
738 JS.While (JS.Bool True) $
739 codeToStmt $ generate mode body
740 ]
744-- PATHS
747generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
748generatePath mode path =
749 case path of
750 Opt.Index index subPath ->
751 JS.Access (generatePath mode subPath) (Name.fromIndex index)
753 Opt.Root name ->
754 JS.Ref (Name.fromLocal name)
756 Opt.Field field subPath ->
757 JS.Access (generatePath mode subPath) (generateField mode field)
759 Opt.Unbox subPath ->
760 case mode of
761 Mode.Dev _ _ ->
762 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
764 Mode.Prod _ _ ->
765 generatePath mode subPath
769-- GENERATE IFS
772generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
773generateIf mode givenBranches givenFinal =
774 let
775 (branches, final) =
776 crushIfs givenBranches givenFinal
778 convertBranch (condition, expr) =
779 ( generateJsExpr mode condition
780 , generate mode expr
781 )
783 branchExprs = map convertBranch branches
784 finalCode = generate mode final
785 in
786 if isBlock finalCode || any (isBlock . snd) branchExprs then
787 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
788 else
789 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
792addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
793addExprIf (condition, branch) final =
794 JS.If condition (codeToExpr branch) final
797addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
798addStmtIf (condition, branch) final =
799 JS.IfStmt condition (codeToStmt branch) final
802isBlock :: Code -> Bool
803isBlock code =
804 case code of
805 JsBlock _ -> True
806 JsExpr _ -> False
809crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
810crushIfs branches final =
811 crushIfsHelp [] branches final
814crushIfsHelp
815 :: [(Opt.Expr, Opt.Expr)]
816 -> [(Opt.Expr, Opt.Expr)]
817 -> Opt.Expr
818 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
819crushIfsHelp visitedBranches unvisitedBranches final =
820 case unvisitedBranches of
821 [] ->
822 case final of
823 Opt.If subBranches subFinal ->
824 crushIfsHelp visitedBranches subBranches subFinal
826 _ ->
827 (reverse visitedBranches, final)
829 visiting : unvisited ->
830 crushIfsHelp (visiting : visitedBranches) unvisited final
834-- CASE EXPRESSIONS
837generateCase :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
838generateCase mode label root decider jumps =
839 foldr (goto mode label) (generateDecider mode label root decider) jumps
842goto :: Mode.Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
843goto mode label (index, branch) stmts =
844 let
845 labeledDeciderStmt =
846 JS.Labelled
847 (Name.makeLabel label index)
848 (JS.While (JS.Bool True) (JS.Block stmts))
849 in
850 labeledDeciderStmt : codeToStmtList (generate mode branch)
853generateDecider :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
854generateDecider mode label root decisionTree =
855 case decisionTree of
856 Opt.Leaf (Opt.Inline branch) ->
857 codeToStmtList (generate mode branch)
859 Opt.Leaf (Opt.Jump index) ->
860 [ JS.Break (Just (Name.makeLabel label index)) ]
862 Opt.Chain testChain success failure ->
863 [ JS.IfStmt
864 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
865 (JS.Block $ generateDecider mode label root success)
866 (JS.Block $ generateDecider mode label root failure)
867 ]
869 Opt.FanOut path edges fallback ->
870 [ JS.Switch
871 (generateCaseTest mode root path (fst (head edges)))
872 ( foldr
873 (\edge cases -> generateCaseBranch mode label root edge : cases)
874 [ JS.Default (generateDecider mode label root fallback) ]
875 edges
876 )
877 ]
880generateIfTest :: Mode.Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
881generateIfTest mode root (path, test) =
882 let
883 value = pathToJsExpr mode root path
884 in
885 case test of
886 DT.IsCtor home name index _ _ ->
887 strictEq (JS.Access value Name.dollar) $
888 case mode of
889 Mode.Dev _ _ -> JS.String (N.toBuilder name)
890 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
892 DT.IsInt int ->
893 strictEq value (JS.Int int)
895 DT.IsChr char ->
896 strictEq (JS.String (Text.encodeUtf8Builder char)) $
897 case mode of
898 Mode.Dev _ _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
899 Mode.Prod _ _ -> value
901 DT.IsStr string ->
902 strictEq value (JS.String (Text.encodeUtf8Builder string))
904 DT.IsCons ->
905 JS.Access value (Name.fromLocal "b")
907 DT.IsNil ->
908 JS.Prefix JS.PrefixLNot $
909 JS.Access value (Name.fromLocal "b")
911 DT.IsTuple ->
912 error "COMPILER BUG - there should never be tests on a tuple"
916generateCaseBranch :: Mode.Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
917generateCaseBranch mode label root (test, subTree) =
918 JS.Case
919 (generateCaseValue mode test)
920 (generateDecider mode label root subTree)
923generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
924generateCaseValue mode test =
925 case test of
926 DT.IsCtor home name index _ _ ->
927 case mode of
928 Mode.Dev _ _ -> JS.String (N.toBuilder name)
929 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
931 DT.IsInt int ->
932 JS.Int int
934 DT.IsChr char ->
935 JS.String (Text.encodeUtf8Builder char)
937 DT.IsStr string ->
938 JS.String (Text.encodeUtf8Builder string)
940 DT.IsCons ->
941 error "COMPILER BUG - there should never be three tests on a list"
943 DT.IsNil ->
944 error "COMPILER BUG - there should never be three tests on a list"
946 DT.IsTuple ->
947 error "COMPILER BUG - there should never be three tests on a tuple"
950generateCaseTest :: Mode.Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
951generateCaseTest mode root path exampleTest =
952 let
953 value = pathToJsExpr mode root path
954 in
955 case exampleTest of
956 DT.IsCtor _ _ _ _ opts ->
957 case mode of
958 Mode.Dev _ _ ->
959 JS.Access value Name.dollar
961 Mode.Prod _ _ ->
962 case opts of
963 Can.Normal ->
964 JS.Access value Name.dollar
966 Can.Enum ->
967 value
969 Can.Unbox ->
970 value
972 DT.IsInt _ ->
973 value
975 DT.IsStr _ ->
976 value
978 DT.IsChr _ ->
979 case mode of
980 Mode.Dev _ _ ->
981 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
983 Mode.Prod _ _ ->
984 value
986 DT.IsCons ->
987 error "COMPILER BUG - there should never be three tests on a list"
989 DT.IsNil ->
990 error "COMPILER BUG - there should never be three tests on a list"
992 DT.IsTuple ->
993 error "COMPILER BUG - there should never be three tests on a list"
997-- PATTERN PATHS
1000pathToJsExpr :: Mode.Mode -> N.Name -> DT.Path -> JS.Expr
1001pathToJsExpr mode root path =
1002 case path of
1003 DT.Index index subPath ->
1004 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
1006 DT.Unbox subPath ->
1007 case mode of
1008 Mode.Dev _ _ ->
1009 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
1011 Mode.Prod _ _ ->
1012 pathToJsExpr mode root subPath
1014 DT.Empty ->
1015 JS.Ref (Name.fromLocal root)
1019-- GENERATE MAIN
1022generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1023generateMain mode home main =
1024 case main of
1025 Opt.Static ->
1026 JS.Ref (Name.fromKernel N.virtualDom "init")
1027 # JS.Ref (Name.fromGlobal home "main")
1028 # JS.Int 0
1029 # JS.Int 0
1031 Opt.Dynamic msgType decoder ->
1032 JS.Ref (Name.fromGlobal home "main")
1033 # generateJsExpr mode decoder
1034 # toDebugMetadata mode msgType
1037(#) :: JS.Expr -> JS.Expr -> JS.Expr
1038(#) func arg =
1039 JS.Call func [arg]
1042toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1043toDebugMetadata mode msgType =
1044 case mode of
1045 Mode.Prod _ _ ->
1046 JS.Int 0
1048 Mode.Dev _ Nothing ->
1049 JS.Int 0
1051 Mode.Dev _ (Just interfaces) ->
1052 JS.Json $ Encode.object $
1053 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1054 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))