git.iko.soy/elk
on 0da3204 help sign in
elk/src/Generate/JavaScript/Expression.hs
899 lines 23 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateFunction
6 , generateMain
7 , Code
8 , codeToExpr
9 , codeToStmtList
10 )
11 where
14import qualified Data.IntMap as IntMap
15import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Text.Encoding as Text
19import qualified AST.Optimized as Opt
20import qualified AST.Module.Name as ModuleName
21import qualified Data.Index as Index
22import qualified Elm.Compiler.Type as Type
23import qualified Elm.Compiler.Type.Extract as Extract
24import qualified Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Elm.Package as Pkg
27import qualified Elm.Compiler.Version as Version
28import qualified Generate.JavaScript.Builder as JS
29import qualified Generate.JavaScript.Name as Name
30import qualified Json.Encode as Encode
31import qualified Optimize.DecisionTree as DT
32import qualified Reporting.Region as R
36-- ENVIRONMENT
39type Mode = Name.Mode
43-- EXPRESSIONS
46generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
47generateJsExpr mode expression =
48 codeToExpr (generate mode expression)
51generate :: Mode -> Opt.Expr -> Code
52generate mode expression =
53 case expression of
54 Opt.Chr char ->
55 JsExpr $
56 case mode of
57 Name.Debug _ ->
58 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
60 Name.Prod _ _ ->
61 JS.String (Text.encodeUtf8Builder char)
63 Opt.Str string ->
64 JsExpr $ JS.String (Text.encodeUtf8Builder string)
66 Opt.Int int ->
67 JsExpr $ JS.Int int
69 Opt.Float float ->
70 JsExpr $ JS.Float float
72 Opt.VarLocal name ->
73 JsExpr $ JS.Ref (Name.fromLocal name)
75 Opt.VarGlobal (Opt.Global home name) ->
76 JsExpr $ JS.Ref (Name.fromGlobal home name)
78 Opt.VarCycle home name ->
79 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
81 Opt.VarDebug name home region unhandledValueName ->
82 JsExpr $ generateDebug name home region unhandledValueName
84 Opt.VarKernel home name ->
85 JsExpr $ JS.Ref (Name.fromKernel home name)
87 Opt.List entries ->
88 JsExpr $
89 JS.Call
90 (JS.Ref (Name.fromKernel N.list "fromArray"))
91 [ JS.Array $ map (generateJsExpr mode) entries
92 ]
94 Opt.Function args body ->
95 generateFunction (map Name.fromLocal args) (generate mode body)
97 Opt.Call func args ->
98 JsExpr $ generateCall mode func args
100 Opt.TailCall name args ->
101 JsBlock $ generateTailCall mode name args
103 Opt.If branches final ->
104 generateIf mode branches final
106 Opt.Let def body ->
107 JsBlock $
108 generateDef mode def : codeToStmtList (generate mode body)
110 Opt.Case label root decider jumps ->
111 JsBlock $ generateCase mode label root decider jumps
113 Opt.Index expr index ->
114 JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)
116 Opt.Accessor field ->
117 JsExpr $ JS.Function Nothing [Name.dollar]
118 [ JS.Return $ Just $
119 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
120 ]
122 Opt.Access record field ->
123 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
125 Opt.Update record fields ->
126 JsExpr $
127 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
128 [ generateJsExpr mode record
129 , generateRecord mode fields
130 ]
132 Opt.Record fields ->
133 JsExpr $ generateRecord mode fields
135 Opt.Unit ->
136 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
138 Opt.Tuple a b maybeC ->
139 JsExpr $
140 case maybeC of
141 Nothing ->
142 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
143 [ generateJsExpr mode a
144 , generateJsExpr mode b
145 ]
147 Just c ->
148 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
149 [ generateJsExpr mode a
150 , generateJsExpr mode b
151 , generateJsExpr mode c
152 ]
154 Opt.Shader src ->
155 let string = JS.String (Text.encodeUtf8Builder src) in
156 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
160-- CODE CHUNKS
163data Code
164 = JsExpr JS.Expr
165 | JsBlock [JS.Stmt]
168codeToExpr :: Code -> JS.Expr
169codeToExpr code =
170 case code of
171 JsExpr expr ->
172 expr
174 JsBlock stmts ->
175 JS.Call (JS.Function Nothing [] stmts) []
178codeToStmtList :: Code -> [JS.Stmt]
179codeToStmtList code =
180 case code of
181 JsExpr expr ->
182 [ JS.Return (Just expr) ]
184 JsBlock stmts ->
185 stmts
188codeToStmt :: Code -> JS.Stmt
189codeToStmt code =
190 case code of
191 JsExpr expr ->
192 JS.Return (Just expr)
194 JsBlock [stmt] ->
195 stmt
197 JsBlock stmts ->
198 JS.Block stmts
202-- CHARS
205{-# NOINLINE toChar #-}
206toChar :: JS.Expr
207toChar =
208 JS.Ref (Name.fromKernel N.utils "chr")
212-- CTOR
215generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
216generateCtor mode name index arity =
217 let
218 argNames = map Name.fromInt [1 .. arity]
219 argFields = map (\n -> (n, JS.Ref n)) argNames
221 tag =
222 case mode of
223 Name.Debug _ ->
224 ( Name.dollar, JS.String (N.toBuilder name) )
226 Name.Prod _ _ ->
227 ( Name.dollar, JS.Int (Index.toZeroBased index) )
228 in
229 ( argNames, JsExpr (JS.Object (tag:argFields)) )
233-- RECORDS
236generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
237generateRecord mode fields =
238 let
239 toPair (field, value) =
240 (Name.fromField mode field, generateJsExpr mode value)
241 in
242 JS.Object (map toPair (Map.toList fields))
246-- DEBUG
249generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
250generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
251 if name /= "crash" then
252 JS.Ref (Name.fromGlobal ModuleName.debug name)
253 else
254 case unhandledValueName of
255 Nothing ->
256 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
257 [ JS.String (N.toBuilder home)
258 , regionToJsExpr region
259 ]
261 Just valueName ->
262 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
263 [ JS.String (N.toBuilder home)
264 , regionToJsExpr region
265 , JS.Ref (Name.fromLocal valueName)
266 ]
269regionToJsExpr :: R.Region -> JS.Expr
270regionToJsExpr (R.Region start end) =
271 JS.Object
272 [ ( Name.fromLocal "start", positionToJsExpr start )
273 , ( Name.fromLocal "end", positionToJsExpr end )
274 ]
277positionToJsExpr :: R.Position -> JS.Expr
278positionToJsExpr (R.Position line column) =
279 JS.Object
280 [ ( Name.fromLocal "line", JS.Int line )
281 , ( Name.fromLocal "column", JS.Int column )
282 ]
286-- FUNCTION
289generateFunction :: [Name.Name] -> Code -> Code
290generateFunction args body =
291 case IntMap.lookup (length args) funcHelpers of
292 Just helper ->
293 JsExpr $
294 JS.Call helper
295 [ JS.Function Nothing args $
296 codeToStmtList body
297 ]
299 Nothing ->
300 let
301 addArg arg code =
302 JsExpr $ JS.Function Nothing [arg] $
303 codeToStmtList code
304 in
305 foldr addArg body args
308{-# NOINLINE funcHelpers #-}
309funcHelpers :: IntMap.IntMap JS.Expr
310funcHelpers =
311 IntMap.fromList
312 [ (2, JS.Ref (Name.fromLocal "F2"))
313 , (3, JS.Ref (Name.fromLocal "F3"))
314 , (4, JS.Ref (Name.fromLocal "F4"))
315 , (5, JS.Ref (Name.fromLocal "F5"))
316 , (6, JS.Ref (Name.fromLocal "F6"))
317 , (7, JS.Ref (Name.fromLocal "F7"))
318 , (8, JS.Ref (Name.fromLocal "F8"))
319 , (9, JS.Ref (Name.fromLocal "F9"))
320 ]
324-- CALLS
327generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
328generateCall mode func args =
329 case func of
330 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
331 generateCoreCall mode global args
333 _ ->
334 generateNormalCall
335 (generateJsExpr mode func)
336 (map (generateJsExpr mode) args)
339generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
340generateNormalCall' home name args =
341 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
344generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
345generateNormalCall func args =
346 case IntMap.lookup (length args) callHelpers of
347 Just helper ->
348 JS.Call helper (func:args)
350 Nothing ->
351 List.foldl' (\f a -> JS.Call f [a]) func args
354{-# NOINLINE callHelpers #-}
355callHelpers :: IntMap.IntMap JS.Expr
356callHelpers =
357 IntMap.fromList
358 [ (2, JS.Ref (Name.fromLocal "A2"))
359 , (3, JS.Ref (Name.fromLocal "A3"))
360 , (4, JS.Ref (Name.fromLocal "A4"))
361 , (5, JS.Ref (Name.fromLocal "A5"))
362 , (6, JS.Ref (Name.fromLocal "A6"))
363 , (7, JS.Ref (Name.fromLocal "A7"))
364 , (8, JS.Ref (Name.fromLocal "A8"))
365 , (9, JS.Ref (Name.fromLocal "A9"))
366 ]
370-- CORE CALLS
373generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
374generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
375 if moduleName == N.basics then
376 generateBasicsCall mode home name args
378 else if moduleName == N.bitwise then
379 generateBitwiseCall home name (map (generateJsExpr mode) args)
381 else if moduleName == N.tuple then
382 generateTupleCall home name (map (generateJsExpr mode) args)
384 else
385 generateNormalCall' home name (map (generateJsExpr mode) args)
388generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
389generateTupleCall home name args =
390 case args of
391 [value] ->
392 case name of
393 "first" -> JS.Access value (Name.fromLocal "a")
394 "second" -> JS.Access value (Name.fromLocal "b")
395 _ -> generateNormalCall' home name args
397 _ ->
398 generateNormalCall' home name args
401generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
402generateBitwiseCall home name args =
403 case args of
404 [arg] ->
405 case name of
406 "complement" -> JS.Prefix JS.PrefixBNot arg
407 _ -> generateNormalCall' home name args
409 [left,right] ->
410 case name of
411 "and" -> JS.Infix JS.OpBAnd left right
412 "or" -> JS.Infix JS.OpBOr left right
413 "xor" -> JS.Infix JS.OpBXor left right
414 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
415 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
416 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
417 _ -> generateNormalCall' home name args
419 _ ->
420 generateNormalCall' home name args
423generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
424generateBasicsCall mode home name args =
425 case args of
426 [elmArg] ->
427 let arg = generateJsExpr mode elmArg in
428 case name of
429 "not" -> JS.Prefix JS.PrefixLNot arg
430 "toFloat" -> arg
431 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
432 _ -> generateNormalCall' home name [arg]
434 [elmLeft, elmRight] ->
435 case name of
436 "composeL" -> decomposeL mode elmLeft [elmRight]
437 "composeR" -> decomposeR mode [elmLeft] elmRight
438 "append" -> append mode elmLeft elmRight
439 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
440 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
441 _ ->
442 let
443 left = generateJsExpr mode elmLeft
444 right = generateJsExpr mode elmRight
445 in
446 case name of
447 "add" -> JS.Infix JS.OpAdd left right
448 "sub" -> JS.Infix JS.OpSub left right
449 "mul" -> JS.Infix JS.OpMul left right
450 "fdiv" -> JS.Infix JS.OpDiv left right
451 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
452 "eq" -> equal left right
453 "neq" -> notEqual left right
454 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
455 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
456 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
457 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
458 "or" -> JS.Infix JS.OpLOr left right
459 "and" -> JS.Infix JS.OpLAnd left right
460 "xor" -> JS.Infix JS.OpStrictNEq left right
461 _ -> generateNormalCall' home name [left, right]
463 _ ->
464 generateNormalCall' home name (map (generateJsExpr mode) args)
467equal :: JS.Expr -> JS.Expr -> JS.Expr
468equal left right =
469 if isLiteral left || isLiteral right then
470 strictEq left right
471 else
472 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
475notEqual :: JS.Expr -> JS.Expr -> JS.Expr
476notEqual left right =
477 if isLiteral left || isLiteral right then
478 strictNEq left right
479 else
480 JS.Prefix JS.PrefixLNot $
481 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
484cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
485cmp idealOp backupOp backupInt left right =
486 if isLiteral left || isLiteral right then
487 JS.Infix idealOp left right
488 else
489 JS.Infix backupOp
490 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
491 (JS.Int backupInt)
494isLiteral :: JS.Expr -> Bool
495isLiteral expr =
496 case expr of
497 JS.String _ ->
498 True
500 JS.Float _ ->
501 True
503 JS.Int _ ->
504 True
506 JS.Bool _ ->
507 True
509 _ ->
510 False
513decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
514decomposeL mode expr funcs =
515 case expr of
516 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
517 | home == ModuleName.basics ->
518 decomposeL mode left (func:funcs)
520 _ ->
521 generateJsExpr mode $
522 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
525decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
526decomposeR mode funcs expr =
527 case expr of
528 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
529 | home == ModuleName.basics ->
530 decomposeR mode (func:funcs) right
532 _ ->
533 generateJsExpr mode $
534 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
537apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
538apply func value =
539 case func of
540 Opt.Accessor field ->
541 Opt.Access value field
543 Opt.Call f args ->
544 Opt.Call f (args ++ [value])
546 _ ->
547 Opt.Call func [value]
550append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
551append mode left right =
552 let seqs = generateJsExpr mode left : toSeqs mode right in
553 if any isStringLiteral seqs then
554 foldr1 (JS.Infix JS.OpAdd) seqs
555 else
556 foldr1 jsAppend seqs
559jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
560jsAppend a b =
561 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
564toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
565toSeqs mode expr =
566 case expr of
567 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
568 | home == ModuleName.basics ->
569 generateJsExpr mode left : toSeqs mode right
571 _ ->
572 [generateJsExpr mode expr]
575isStringLiteral :: JS.Expr -> Bool
576isStringLiteral expr =
577 case expr of
578 JS.String _ ->
579 True
581 _ ->
582 False
586-- SIMPLIFY INFIX OPERATORS
589strictEq :: JS.Expr -> JS.Expr -> JS.Expr
590strictEq left right =
591 case left of
592 JS.Int 0 ->
593 JS.Prefix JS.PrefixLNot right
595 JS.Bool bool ->
596 if bool then right else JS.Prefix JS.PrefixLNot right
598 _ ->
599 case right of
600 JS.Int 0 ->
601 JS.Prefix JS.PrefixLNot left
603 JS.Bool bool ->
604 if bool then left else JS.Prefix JS.PrefixLNot left
606 _ ->
607 JS.Infix JS.OpStrictEq left right
610strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
611strictNEq left right =
612 case left of
613 JS.Int 0 ->
614 right
616 JS.Bool bool ->
617 if bool then JS.Prefix JS.PrefixLNot right else right
619 _ ->
620 case right of
621 JS.Int 0 ->
622 left
624 JS.Bool bool ->
625 if bool then JS.Prefix JS.PrefixLNot left else left
627 _ ->
628 JS.Infix JS.OpStrictNEq left right
632-- TAIL CALL
635-- TODO check if JS minifiers collapse unnecessary temporary variables
636--
637generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
638generateTailCall mode name args =
639 let
640 toTempVars (argName, arg) =
641 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
643 toRealVars (argName, _) =
644 JS.ExprStmt $
645 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
646 in
647 JS.Var (map toTempVars args)
648 : map toRealVars args
649 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
653-- DEFINITIONS
656generateDef :: Mode -> Opt.Def -> JS.Stmt
657generateDef mode def =
658 case def of
659 Opt.Def name body ->
660 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
662 Opt.TailDef name argNames body ->
663 let
664 function =
665 JS.Function Nothing (map Name.fromLocal argNames)
666 [ JS.Labelled (Name.fromLocal name) $
667 JS.While (JS.Bool True) $
668 codeToStmt $ generate mode body
669 ]
670 in
671 JS.Var [ (Name.fromLocal name, Just function) ]
675-- GENERATE IFS
678generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
679generateIf mode givenBranches givenFinal =
680 let
681 (branches, final) =
682 crushIfs givenBranches givenFinal
684 convertBranch (condition, expr) =
685 ( generateJsExpr mode condition
686 , generate mode expr
687 )
689 branchExprs = map convertBranch branches
690 finalCode = generate mode final
691 in
692 if isBlock finalCode || any (isBlock . snd) branchExprs then
693 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
694 else
695 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
698addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
699addExprIf (condition, branch) final =
700 JS.If condition (codeToExpr branch) final
703addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
704addStmtIf (condition, branch) final =
705 JS.IfStmt condition (codeToStmt branch) final
708isBlock :: Code -> Bool
709isBlock code =
710 case code of
711 JsBlock _ -> True
712 JsExpr _ -> False
715crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
716crushIfs branches final =
717 crushIfsHelp [] branches final
720crushIfsHelp
721 :: [(Opt.Expr, Opt.Expr)]
722 -> [(Opt.Expr, Opt.Expr)]
723 -> Opt.Expr
724 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
725crushIfsHelp visitedBranches unvisitedBranches final =
726 case unvisitedBranches of
727 [] ->
728 case final of
729 Opt.If subBranches subFinal ->
730 crushIfsHelp visitedBranches subBranches subFinal
732 _ ->
733 (reverse visitedBranches, final)
735 visiting : unvisited ->
736 crushIfsHelp (visiting : visitedBranches) unvisited final
740-- CASE EXPRESSIONS
743generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
744generateCase mode label root decider jumps =
745 foldr (goto mode label) (generateDecider mode label root decider) jumps
748goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
749goto mode label (index, branch) stmts =
750 let
751 labeledDeciderStmt =
752 JS.Labelled
753 (Name.makeLabel label index)
754 (JS.While (JS.Bool True) (JS.Block stmts))
755 in
756 labeledDeciderStmt : codeToStmtList (generate mode branch)
759generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
760generateDecider mode label root decisionTree =
761 case decisionTree of
762 Opt.Leaf (Opt.Inline branch) ->
763 codeToStmtList (generate mode branch)
765 Opt.Leaf (Opt.Jump index) ->
766 [ JS.Break (Just (Name.makeLabel label index)) ]
768 Opt.Chain testChain success failure ->
769 let
770 makeTest (path, test) =
771 strictEq
772 (pathToTestableExpr mode root path test)
773 (testToExpr mode test)
774 in
775 [ JS.IfStmt
776 (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))
777 (JS.Block $ generateDecider mode label root success)
778 (JS.Block $ generateDecider mode label root failure)
779 ]
781 Opt.FanOut path edges fallback ->
782 [ JS.Switch
783 (pathToTestableExpr mode root path (fst (head edges)))
784 ( foldr
785 (addCase mode label root)
786 [ JS.Default (generateDecider mode label root fallback) ]
787 edges
788 )
789 ]
792addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
793addCase mode label root (test, subTree) cases =
794 let stmts = generateDecider mode label root subTree in
795 JS.Case (testToExpr mode test) stmts : cases
798testToExpr :: Mode -> DT.Test -> JS.Expr
799testToExpr mode test =
800 case test of
801 DT.IsCtor _ tag index ->
802 case mode of
803 Name.Debug _ ->
804 JS.String (N.toBuilder tag)
806 Name.Prod _ _ ->
807 JS.Int (Index.toZeroBased index)
809 DT.IsInt int ->
810 JS.Int int
812 DT.IsChr char ->
813 JS.String (Text.encodeUtf8Builder char)
815 DT.IsStr string ->
816 JS.String (Text.encodeUtf8Builder string)
819pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
820pathToTestableExpr mode root path exampleTest =
821 let
822 expr =
823 pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path
824 in
825 case exampleTest of
826 DT.IsCtor _ _ _ ->
827 JS.Access expr Name.dollar
829 DT.IsInt _ ->
830 expr
832 DT.IsStr _ ->
833 expr
835 DT.IsChr _ ->
836 case mode of
837 Name.Debug _ ->
838 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
840 Name.Prod _ _ ->
841 expr
844pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr
845pathToJsExpr mode expr path =
846 case path of
847 DT.Index index subpath ->
848 pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath
850 DT.Field field subpath ->
851 pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
853 DT.Empty ->
854 expr
856 DT.Alias ->
857 expr
861-- GENERATE MAIN
864generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> [N.Name] -> Opt.Main -> JS.Expr
865generateMain mode interfaces home segments main =
866 case main of
867 Opt.Static ->
868 JS.Ref (Name.fromKernel N.browser "staticPage")
869 # JS.Ref (Name.fromGlobal home "main")
870 # List.foldl' addDot elm segments
872 Opt.Dynamic decoder msgType ->
873 let
874 jsonMetadata =
875 Encode.object
876 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
877 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
878 ]
879 in
880 JS.Ref (Name.fromGlobal home "main")
881 # List.foldl' addDot elm segments
882 # generateJsExpr mode decoder
883 # JS.Json jsonMetadata
886(#) :: JS.Expr -> JS.Expr -> JS.Expr
887(#) func arg =
888 JS.Call func [arg]
891addDot :: JS.Expr -> N.Name -> JS.Expr
892addDot root name =
893 JS.Index root (JS.String (N.toBuilder name))
896{-# NOINLINE elm #-}
897elm :: JS.Expr
898elm =
899 JS.Ref (Name.fromLocal "Elm")