git.iko.soy/elk
on 7dfbc30 help sign in
elk/src/Generate/JavaScript/Expression.hs
898 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.Canonical as Can
20import qualified AST.Optimized as Opt
21import qualified AST.Module.Name as ModuleName
22import qualified Data.Index as Index
23import qualified Elm.Compiler.Type as Type
24import qualified Elm.Compiler.Type.Extract as Extract
25import qualified Elm.Interface as I
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
28import qualified Elm.Compiler.Version as Version
29import qualified Generate.JavaScript.Builder as JS
30import qualified Generate.JavaScript.Name as Name
31import qualified Json.Encode as Encode
32import qualified Optimize.DecisionTree as DT
33import qualified Reporting.Region as R
37-- ENVIRONMENT
40type Mode = Name.Mode
44-- EXPRESSIONS
47generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
48generateJsExpr mode expression =
49 codeToExpr (generate mode expression)
52generate :: Mode -> Opt.Expr -> Code
53generate mode expression =
54 case expression of
55 Opt.Chr char ->
56 JsExpr $
57 case mode of
58 Name.Debug _ ->
59 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
61 Name.Prod _ _ ->
62 JS.String (Text.encodeUtf8Builder char)
64 Opt.Str string ->
65 JsExpr $ JS.String (Text.encodeUtf8Builder string)
67 Opt.Int int ->
68 JsExpr $ JS.Int int
70 Opt.Float float ->
71 JsExpr $ JS.Float float
73 Opt.VarLocal name ->
74 JsExpr $ JS.Ref (Name.fromLocal name)
76 Opt.VarGlobal (Opt.Global home name) ->
77 JsExpr $ JS.Ref (Name.fromGlobal home name)
79 Opt.VarCycle home name ->
80 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
82 Opt.VarDebug name home region unhandledValueName ->
83 JsExpr $ generateDebug name home region unhandledValueName
85 Opt.VarKernel home name ->
86 JsExpr $ JS.Ref (Name.fromKernel home name)
88 Opt.List entries ->
89 JsExpr $
90 JS.Call
91 (JS.Ref (Name.fromKernel N.list "fromArray"))
92 [ JS.Array $ map (generateJsExpr mode) entries
93 ]
95 Opt.Function args body ->
96 generateFunction (map Name.fromLocal args) (generate mode body)
98 Opt.Call func args ->
99 JsExpr $ generateCall mode func args
101 Opt.TailCall name args ->
102 JsBlock $ generateTailCall mode name args
104 Opt.If branches final ->
105 generateIf mode branches final
107 Opt.Let def body ->
108 JsBlock $
109 generateDef mode def : codeToStmtList (generate mode body)
111 Opt.Case label root decider jumps ->
112 JsBlock $ generateCase mode label root decider jumps
114 Opt.Index expr index ->
115 JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)
117 Opt.Accessor field ->
118 JsExpr $ JS.Function Nothing [Name.dollar]
119 [ JS.Return $ Just $
120 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
121 ]
123 Opt.Access record field ->
124 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
126 Opt.Update record fields ->
127 JsExpr $
128 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
129 [ generateJsExpr mode record
130 , generateRecord mode fields
131 ]
133 Opt.Record fields ->
134 JsExpr $ generateRecord mode fields
136 Opt.Unit ->
137 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
139 Opt.Tuple a b maybeC ->
140 JsExpr $
141 case maybeC of
142 Nothing ->
143 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
144 [ generateJsExpr mode a
145 , generateJsExpr mode b
146 ]
148 Just c ->
149 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
150 [ generateJsExpr mode a
151 , generateJsExpr mode b
152 , generateJsExpr mode c
153 ]
155 Opt.Shader src ->
156 let string = JS.String (Text.encodeUtf8Builder src) in
157 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
161-- CODE CHUNKS
164data Code
165 = JsExpr JS.Expr
166 | JsBlock [JS.Stmt]
169codeToExpr :: Code -> JS.Expr
170codeToExpr code =
171 case code of
172 JsExpr expr ->
173 expr
175 JsBlock [ JS.Return (Just expr) ] ->
176 expr
178 JsBlock stmts ->
179 JS.Call (JS.Function Nothing [] stmts) []
182codeToStmtList :: Code -> [JS.Stmt]
183codeToStmtList code =
184 case code of
185 JsExpr expr ->
186 [ JS.Return (Just expr) ]
188 JsBlock stmts ->
189 stmts
192codeToStmt :: Code -> JS.Stmt
193codeToStmt code =
194 case code of
195 JsExpr expr ->
196 JS.Return (Just expr)
198 JsBlock [stmt] ->
199 stmt
201 JsBlock stmts ->
202 JS.Block stmts
206-- CHARS
209{-# NOINLINE toChar #-}
210toChar :: JS.Expr
211toChar =
212 JS.Ref (Name.fromKernel N.utils "chr")
216-- CTOR
219generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
220generateCtor mode name index arity =
221 let
222 argNames = map Name.fromInt [1 .. arity]
223 argFields = map (\n -> (n, JS.Ref n)) argNames
225 tag =
226 case mode of
227 Name.Debug _ ->
228 ( Name.dollar, JS.String (N.toBuilder name) )
230 Name.Prod _ _ ->
231 ( Name.dollar, JS.Int (Index.toZeroBased index) )
232 in
233 ( argNames, JsExpr (JS.Object (tag:argFields)) )
237-- RECORDS
240generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
241generateRecord mode fields =
242 let
243 toPair (field, value) =
244 (Name.fromField mode field, generateJsExpr mode value)
245 in
246 JS.Object (map toPair (Map.toList fields))
250-- DEBUG
253generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
254generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
255 if name /= "crash" then
256 JS.Ref (Name.fromGlobal ModuleName.debug name)
257 else
258 case unhandledValueName of
259 Nothing ->
260 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
261 [ JS.String (N.toBuilder home)
262 , regionToJsExpr region
263 ]
265 Just valueName ->
266 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
267 [ JS.String (N.toBuilder home)
268 , regionToJsExpr region
269 , JS.Ref (Name.fromLocal valueName)
270 ]
273regionToJsExpr :: R.Region -> JS.Expr
274regionToJsExpr (R.Region start end) =
275 JS.Object
276 [ ( Name.fromLocal "start", positionToJsExpr start )
277 , ( Name.fromLocal "end", positionToJsExpr end )
278 ]
281positionToJsExpr :: R.Position -> JS.Expr
282positionToJsExpr (R.Position line column) =
283 JS.Object
284 [ ( Name.fromLocal "line", JS.Int line )
285 , ( Name.fromLocal "column", JS.Int column )
286 ]
290-- FUNCTION
293generateFunction :: [Name.Name] -> Code -> Code
294generateFunction args body =
295 case IntMap.lookup (length args) funcHelpers of
296 Just helper ->
297 JsExpr $
298 JS.Call helper
299 [ JS.Function Nothing args $
300 codeToStmtList body
301 ]
303 Nothing ->
304 let
305 addArg arg code =
306 JsExpr $ JS.Function Nothing [arg] $
307 codeToStmtList code
308 in
309 foldr addArg body args
312{-# NOINLINE funcHelpers #-}
313funcHelpers :: IntMap.IntMap JS.Expr
314funcHelpers =
315 IntMap.fromList
316 [ (2, JS.Ref (Name.fromLocal "F2"))
317 , (3, JS.Ref (Name.fromLocal "F3"))
318 , (4, JS.Ref (Name.fromLocal "F4"))
319 , (5, JS.Ref (Name.fromLocal "F5"))
320 , (6, JS.Ref (Name.fromLocal "F6"))
321 , (7, JS.Ref (Name.fromLocal "F7"))
322 , (8, JS.Ref (Name.fromLocal "F8"))
323 , (9, JS.Ref (Name.fromLocal "F9"))
324 ]
328-- CALLS
331generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
332generateCall mode func args =
333 case func of
334 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
335 generateCoreCall mode global args
337 _ ->
338 generateNormalCall
339 (generateJsExpr mode func)
340 (map (generateJsExpr mode) args)
343generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
344generateNormalCall' home name args =
345 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
348generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
349generateNormalCall func args =
350 case IntMap.lookup (length args) callHelpers of
351 Just helper ->
352 JS.Call helper (func:args)
354 Nothing ->
355 List.foldl' (\f a -> JS.Call f [a]) func args
358{-# NOINLINE callHelpers #-}
359callHelpers :: IntMap.IntMap JS.Expr
360callHelpers =
361 IntMap.fromList
362 [ (2, JS.Ref (Name.fromLocal "A2"))
363 , (3, JS.Ref (Name.fromLocal "A3"))
364 , (4, JS.Ref (Name.fromLocal "A4"))
365 , (5, JS.Ref (Name.fromLocal "A5"))
366 , (6, JS.Ref (Name.fromLocal "A6"))
367 , (7, JS.Ref (Name.fromLocal "A7"))
368 , (8, JS.Ref (Name.fromLocal "A8"))
369 , (9, JS.Ref (Name.fromLocal "A9"))
370 ]
374-- CORE CALLS
377generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
378generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
379 if moduleName == N.basics then
380 generateBasicsCall mode home name args
382 else if moduleName == N.bitwise then
383 generateBitwiseCall home name (map (generateJsExpr mode) args)
385 else if moduleName == N.tuple then
386 generateTupleCall home name (map (generateJsExpr mode) args)
388 else
389 generateNormalCall' home name (map (generateJsExpr mode) args)
392generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
393generateTupleCall home name args =
394 case args of
395 [value] ->
396 case name of
397 "first" -> JS.Access value (Name.fromLocal "a")
398 "second" -> JS.Access value (Name.fromLocal "b")
399 _ -> generateNormalCall' home name args
401 _ ->
402 generateNormalCall' home name args
405generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
406generateBitwiseCall home name args =
407 case args of
408 [arg] ->
409 case name of
410 "complement" -> JS.Prefix JS.PrefixBNot arg
411 _ -> generateNormalCall' home name args
413 [left,right] ->
414 case name of
415 "and" -> JS.Infix JS.OpBAnd left right
416 "or" -> JS.Infix JS.OpBOr left right
417 "xor" -> JS.Infix JS.OpBXor left right
418 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
419 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
420 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
421 _ -> generateNormalCall' home name args
423 _ ->
424 generateNormalCall' home name args
427generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
428generateBasicsCall mode home name args =
429 case args of
430 [elmArg] ->
431 let arg = generateJsExpr mode elmArg in
432 case name of
433 "not" -> JS.Prefix JS.PrefixLNot arg
434 "toFloat" -> arg
435 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
436 _ -> generateNormalCall' home name [arg]
438 [elmLeft, elmRight] ->
439 case name of
440 "composeL" -> decomposeL mode elmLeft [elmRight]
441 "composeR" -> decomposeR mode [elmLeft] elmRight
442 "append" -> append mode elmLeft elmRight
443 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
444 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
445 _ ->
446 let
447 left = generateJsExpr mode elmLeft
448 right = generateJsExpr mode elmRight
449 in
450 case name of
451 "add" -> JS.Infix JS.OpAdd left right
452 "sub" -> JS.Infix JS.OpSub left right
453 "mul" -> JS.Infix JS.OpMul left right
454 "fdiv" -> JS.Infix JS.OpDiv left right
455 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
456 "eq" -> equal left right
457 "neq" -> notEqual left right
458 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
459 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
460 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
461 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
462 "or" -> JS.Infix JS.OpLOr left right
463 "and" -> JS.Infix JS.OpLAnd left right
464 "xor" -> JS.Infix JS.OpStrictNEq left right
465 _ -> generateNormalCall' home name [left, right]
467 _ ->
468 generateNormalCall' home name (map (generateJsExpr mode) args)
471equal :: JS.Expr -> JS.Expr -> JS.Expr
472equal left right =
473 if isLiteral left || isLiteral right then
474 strictEq left right
475 else
476 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
479notEqual :: JS.Expr -> JS.Expr -> JS.Expr
480notEqual left right =
481 if isLiteral left || isLiteral right then
482 strictNEq left right
483 else
484 JS.Prefix JS.PrefixLNot $
485 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
488cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
489cmp idealOp backupOp backupInt left right =
490 if isLiteral left || isLiteral right then
491 JS.Infix idealOp left right
492 else
493 JS.Infix backupOp
494 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
495 (JS.Int backupInt)
498isLiteral :: JS.Expr -> Bool
499isLiteral expr =
500 case expr of
501 JS.String _ ->
502 True
504 JS.Float _ ->
505 True
507 JS.Int _ ->
508 True
510 JS.Bool _ ->
511 True
513 _ ->
514 False
517decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
518decomposeL mode expr funcs =
519 case expr of
520 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
521 | home == ModuleName.basics ->
522 decomposeL mode left (func:funcs)
524 _ ->
525 generateJsExpr mode $
526 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
529decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
530decomposeR mode funcs expr =
531 case expr of
532 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
533 | home == ModuleName.basics ->
534 decomposeR mode (func:funcs) right
536 _ ->
537 generateJsExpr mode $
538 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
541apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
542apply func value =
543 case func of
544 Opt.Accessor field ->
545 Opt.Access value field
547 Opt.Call f args ->
548 Opt.Call f (args ++ [value])
550 _ ->
551 Opt.Call func [value]
554append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
555append mode left right =
556 let seqs = generateJsExpr mode left : toSeqs mode right in
557 if any isStringLiteral seqs then
558 foldr1 (JS.Infix JS.OpAdd) seqs
559 else
560 foldr1 jsAppend seqs
563jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
564jsAppend a b =
565 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
568toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
569toSeqs mode expr =
570 case expr of
571 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
572 | home == ModuleName.basics ->
573 generateJsExpr mode left : toSeqs mode right
575 _ ->
576 [generateJsExpr mode expr]
579isStringLiteral :: JS.Expr -> Bool
580isStringLiteral expr =
581 case expr of
582 JS.String _ ->
583 True
585 _ ->
586 False
590-- SIMPLIFY INFIX OPERATORS
593strictEq :: JS.Expr -> JS.Expr -> JS.Expr
594strictEq left right =
595 case left of
596 JS.Int 0 ->
597 JS.Prefix JS.PrefixLNot right
599 JS.Bool bool ->
600 if bool then right else JS.Prefix JS.PrefixLNot right
602 _ ->
603 case right of
604 JS.Int 0 ->
605 JS.Prefix JS.PrefixLNot left
607 JS.Bool bool ->
608 if bool then left else JS.Prefix JS.PrefixLNot left
610 _ ->
611 JS.Infix JS.OpStrictEq left right
614strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
615strictNEq left right =
616 case left of
617 JS.Int 0 ->
618 right
620 JS.Bool bool ->
621 if bool then JS.Prefix JS.PrefixLNot right else right
623 _ ->
624 case right of
625 JS.Int 0 ->
626 left
628 JS.Bool bool ->
629 if bool then JS.Prefix JS.PrefixLNot left else left
631 _ ->
632 JS.Infix JS.OpStrictNEq left right
636-- TAIL CALL
639-- TODO check if JS minifiers collapse unnecessary temporary variables
640--
641generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
642generateTailCall mode name args =
643 let
644 toTempVars (argName, arg) =
645 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
647 toRealVars (argName, _) =
648 JS.ExprStmt $
649 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
650 in
651 JS.Var (map toTempVars args)
652 : map toRealVars args
653 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
657-- DEFINITIONS
660generateDef :: Mode -> Opt.Def -> JS.Stmt
661generateDef mode def =
662 case def of
663 Opt.Def name body ->
664 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
666 Opt.TailDef name argNames body ->
667 let
668 function =
669 JS.Function Nothing (map Name.fromLocal argNames)
670 [ JS.Labelled (Name.fromLocal name) $
671 JS.While (JS.Bool True) $
672 codeToStmt $ generate mode body
673 ]
674 in
675 JS.Var [ (Name.fromLocal name, Just function) ]
679-- GENERATE IFS
682generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
683generateIf mode givenBranches givenFinal =
684 let
685 (branches, final) =
686 crushIfs givenBranches givenFinal
688 convertBranch (condition, expr) =
689 ( generateJsExpr mode condition
690 , generate mode expr
691 )
693 branchExprs = map convertBranch branches
694 finalCode = generate mode final
695 in
696 if isBlock finalCode || any (isBlock . snd) branchExprs then
697 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
698 else
699 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
702addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
703addExprIf (condition, branch) final =
704 JS.If condition (codeToExpr branch) final
707addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
708addStmtIf (condition, branch) final =
709 JS.IfStmt condition (codeToStmt branch) final
712isBlock :: Code -> Bool
713isBlock code =
714 case code of
715 JsBlock _ -> True
716 JsExpr _ -> False
719crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
720crushIfs branches final =
721 crushIfsHelp [] branches final
724crushIfsHelp
725 :: [(Opt.Expr, Opt.Expr)]
726 -> [(Opt.Expr, Opt.Expr)]
727 -> Opt.Expr
728 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
729crushIfsHelp visitedBranches unvisitedBranches final =
730 case unvisitedBranches of
731 [] ->
732 case final of
733 Opt.If subBranches subFinal ->
734 crushIfsHelp visitedBranches subBranches subFinal
736 _ ->
737 (reverse visitedBranches, final)
739 visiting : unvisited ->
740 crushIfsHelp (visiting : visitedBranches) unvisited final
744-- CASE EXPRESSIONS
747generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
748generateCase mode label root decider jumps =
749 foldr (goto mode label) (generateDecider mode label root decider) jumps
752goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
753goto mode label (index, branch) stmts =
754 let
755 labeledDeciderStmt =
756 JS.Labelled
757 (Name.makeLabel label index)
758 (JS.While (JS.Bool True) (JS.Block stmts))
759 in
760 labeledDeciderStmt : codeToStmtList (generate mode branch)
763generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
764generateDecider mode label root decisionTree =
765 case decisionTree of
766 Opt.Leaf (Opt.Inline branch) ->
767 codeToStmtList (generate mode branch)
769 Opt.Leaf (Opt.Jump index) ->
770 [ JS.Break (Just (Name.makeLabel label index)) ]
772 Opt.Chain testChain success failure ->
773 let
774 makeTest (path, test) =
775 strictEq
776 (pathToTestableExpr mode root path test)
777 (testToExpr mode test)
778 in
779 [ JS.IfStmt
780 (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))
781 (JS.Block $ generateDecider mode label root success)
782 (JS.Block $ generateDecider mode label root failure)
783 ]
785 Opt.FanOut path edges fallback ->
786 [ JS.Switch
787 (pathToTestableExpr mode root path (fst (head edges)))
788 ( foldr
789 (addCase mode label root)
790 [ JS.Default (generateDecider mode label root fallback) ]
791 edges
792 )
793 ]
796addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
797addCase mode label root (test, subTree) cases =
798 let stmts = generateDecider mode label root subTree in
799 JS.Case (testToExpr mode test) stmts : cases
802testToExpr :: Mode -> DT.Test -> JS.Expr
803testToExpr mode test =
804 case test of
805 DT.IsCtor _ tag index ->
806 case mode of
807 Name.Debug _ ->
808 JS.String (N.toBuilder tag)
810 Name.Prod _ _ ->
811 JS.Int (Index.toZeroBased index)
813 DT.IsInt int ->
814 JS.Int int
816 DT.IsChr char ->
817 JS.String (Text.encodeUtf8Builder char)
819 DT.IsStr string ->
820 JS.String (Text.encodeUtf8Builder string)
823pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
824pathToTestableExpr mode root path exampleTest =
825 let
826 expr =
827 pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path
828 in
829 case exampleTest of
830 DT.IsCtor _ _ _ ->
831 JS.Access expr Name.dollar
833 DT.IsInt _ ->
834 expr
836 DT.IsStr _ ->
837 expr
839 DT.IsChr _ ->
840 case mode of
841 Name.Debug _ ->
842 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
844 Name.Prod _ _ ->
845 expr
848pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr
849pathToJsExpr mode expr path =
850 case path of
851 DT.Index index subpath ->
852 pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath
854 DT.Field field subpath ->
855 pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
857 DT.Empty ->
858 expr
860 DT.Alias ->
861 expr
865-- GENERATE MAIN
868generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
869generateMain mode interfaces home main =
870 case main of
871 Opt.Static ->
872 JS.Ref (Name.fromKernel N.browser "staticPage")
873 # JS.Ref (Name.fromGlobal home "main")
874 # JS.Int 0
875 # JS.Int 0
877 Opt.Dynamic decoder msgType ->
878 JS.Ref (Name.fromGlobal home "main")
879 # generateJsExpr mode decoder
880 # toDebugMetadata mode interfaces msgType
883(#) :: JS.Expr -> JS.Expr -> JS.Expr
884(#) func arg =
885 JS.Call func [arg]
888toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
889toDebugMetadata mode interfaces msgType =
890 case mode of
891 Name.Prod _ _ ->
892 JS.Int 0
894 Name.Debug _ ->
895 JS.Json $ Encode.object $
896 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
897 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
898 ]