git.iko.soy/elk
on 247359c help sign in
elk/src/Generate/JavaScript/Expression.hs
890 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 Generate.JavaScript.Builder as JS
28import qualified Generate.JavaScript.Name as Name
29import qualified Optimize.DecisionTree as DT
30import qualified Reporting.Region as R
34-- ENVIRONMENT
37type Mode = Name.Mode
41-- EXPRESSIONS
44generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
45generateJsExpr mode expression =
46 codeToExpr (generate mode expression)
49generate :: Mode -> Opt.Expr -> Code
50generate mode expression =
51 case expression of
52 Opt.Chr char ->
53 JsExpr $
54 case mode of
55 Name.Debug _ ->
56 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
58 Name.Prod _ _ ->
59 JS.String (Text.encodeUtf8Builder char)
61 Opt.Str string ->
62 JsExpr $ JS.String (Text.encodeUtf8Builder string)
64 Opt.Int int ->
65 JsExpr $ JS.Int int
67 Opt.Float float ->
68 JsExpr $ JS.Float float
70 Opt.VarLocal name ->
71 JsExpr $ JS.Ref (Name.fromLocal name)
73 Opt.VarGlobal (Opt.Global home name) ->
74 JsExpr $ JS.Ref (Name.fromGlobal home name)
76 Opt.VarCycle home name ->
77 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
79 Opt.VarDebug name home region unhandledValueName ->
80 JsExpr $ generateDebug name home region unhandledValueName
82 Opt.VarKernel home name ->
83 JsExpr $ JS.Ref (Name.fromKernel home name)
85 Opt.List entries ->
86 JsExpr $
87 JS.Call
88 (JS.Ref (Name.fromKernel N.list "fromArray"))
89 [ JS.Array $ map (generateJsExpr mode) entries
90 ]
92 Opt.Function args body ->
93 generateFunction (map Name.fromLocal args) (generate mode body)
95 Opt.Call func args ->
96 JsExpr $ generateCall mode func args
98 Opt.TailCall name args ->
99 JsBlock $ generateTailCall mode name args
101 Opt.If branches final ->
102 generateIf mode branches final
104 Opt.Let def body ->
105 JsBlock $
106 generateDef mode def : codeToStmtList (generate mode body)
108 Opt.Case label root decider jumps ->
109 JsBlock $ generateCase mode label root decider jumps
111 Opt.Index expr index ->
112 JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)
114 Opt.Accessor field ->
115 JsExpr $ JS.Function Nothing [Name.dollar]
116 [ JS.Return $ Just $
117 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
118 ]
120 Opt.Access record field ->
121 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
123 Opt.Update record fields ->
124 JsExpr $
125 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
126 [ generateJsExpr mode record
127 , generateRecord mode fields
128 ]
130 Opt.Record fields ->
131 JsExpr $ generateRecord mode fields
133 Opt.Unit ->
134 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
136 Opt.Tuple a b maybeC ->
137 JsExpr $
138 case maybeC of
139 Nothing ->
140 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
141 [ generateJsExpr mode a
142 , generateJsExpr mode b
143 ]
145 Just c ->
146 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
147 [ generateJsExpr mode a
148 , generateJsExpr mode b
149 , generateJsExpr mode c
150 ]
152 Opt.Shader src ->
153 let string = JS.String (Text.encodeUtf8Builder src) in
154 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
158-- CODE CHUNKS
161data Code
162 = JsExpr JS.Expr
163 | JsBlock [JS.Stmt]
166codeToExpr :: Code -> JS.Expr
167codeToExpr code =
168 case code of
169 JsExpr expr ->
170 expr
172 JsBlock stmts ->
173 JS.Call (JS.Function Nothing [] stmts) []
176codeToStmtList :: Code -> [JS.Stmt]
177codeToStmtList code =
178 case code of
179 JsExpr expr ->
180 [ JS.Return (Just expr) ]
182 JsBlock stmts ->
183 stmts
186codeToStmt :: Code -> JS.Stmt
187codeToStmt code =
188 case code of
189 JsExpr expr ->
190 JS.Return (Just expr)
192 JsBlock [stmt] ->
193 stmt
195 JsBlock stmts ->
196 JS.Block stmts
200-- CHARS
203{-# NOINLINE toChar #-}
204toChar :: JS.Expr
205toChar =
206 JS.Ref (Name.fromKernel N.utils "chr")
210-- CTOR
213generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
214generateCtor mode name index arity =
215 let
216 argNames = map Name.fromInt [1 .. arity]
217 argFields = map (\n -> (n, JS.Ref n)) argNames
219 tag =
220 case mode of
221 Name.Debug _ ->
222 ( Name.dollar, JS.String (N.toBuilder name) )
224 Name.Prod _ _ ->
225 ( Name.dollar, JS.Int (Index.toZeroBased index) )
226 in
227 ( argNames, JsExpr (JS.Object (tag:argFields)) )
231-- RECORDS
234generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
235generateRecord mode fields =
236 let
237 toPair (field, value) =
238 (Name.fromField mode field, generateJsExpr mode value)
239 in
240 JS.Object (map toPair (Map.toList fields))
244-- DEBUG
247generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
248generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
249 if name /= "crash" then
250 JS.Ref (Name.fromGlobal ModuleName.debug name)
251 else
252 case unhandledValueName of
253 Nothing ->
254 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
255 [ JS.String (N.toBuilder home)
256 , regionToJsExpr region
257 ]
259 Just valueName ->
260 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
261 [ JS.String (N.toBuilder home)
262 , regionToJsExpr region
263 , JS.Ref (Name.fromLocal valueName)
264 ]
267regionToJsExpr :: R.Region -> JS.Expr
268regionToJsExpr (R.Region start end) =
269 JS.Object
270 [ ( Name.fromLocal "start", positionToJsExpr start )
271 , ( Name.fromLocal "end", positionToJsExpr end )
272 ]
275positionToJsExpr :: R.Position -> JS.Expr
276positionToJsExpr (R.Position line column) =
277 JS.Object
278 [ ( Name.fromLocal "line", JS.Int line )
279 , ( Name.fromLocal "column", JS.Int column )
280 ]
284-- FUNCTION
287generateFunction :: [Name.Name] -> Code -> Code
288generateFunction args body =
289 case IntMap.lookup (length args) funcHelpers of
290 Just helper ->
291 JsExpr $
292 JS.Call helper
293 [ JS.Function Nothing args $
294 codeToStmtList body
295 ]
297 Nothing ->
298 let
299 addArg arg code =
300 JsExpr $ JS.Function Nothing [arg] $
301 codeToStmtList code
302 in
303 foldr addArg body args
306{-# NOINLINE funcHelpers #-}
307funcHelpers :: IntMap.IntMap JS.Expr
308funcHelpers =
309 IntMap.fromList
310 [ (2, JS.Ref (Name.fromLocal "F2"))
311 , (3, JS.Ref (Name.fromLocal "F3"))
312 , (4, JS.Ref (Name.fromLocal "F4"))
313 , (5, JS.Ref (Name.fromLocal "F5"))
314 , (6, JS.Ref (Name.fromLocal "F6"))
315 , (7, JS.Ref (Name.fromLocal "F7"))
316 , (8, JS.Ref (Name.fromLocal "F8"))
317 , (9, JS.Ref (Name.fromLocal "F9"))
318 ]
322-- CALLS
325generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
326generateCall mode func args =
327 case func of
328 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
329 generateCoreCall mode global args
331 _ ->
332 generateNormalCall
333 (generateJsExpr mode func)
334 (map (generateJsExpr mode) args)
337generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
338generateNormalCall' home name args =
339 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
342generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
343generateNormalCall func args =
344 case IntMap.lookup (length args) callHelpers of
345 Just helper ->
346 JS.Call helper (func:args)
348 Nothing ->
349 List.foldl' (\f a -> JS.Call f [a]) func args
352{-# NOINLINE callHelpers #-}
353callHelpers :: IntMap.IntMap JS.Expr
354callHelpers =
355 IntMap.fromList
356 [ (2, JS.Ref (Name.fromLocal "A2"))
357 , (3, JS.Ref (Name.fromLocal "A3"))
358 , (4, JS.Ref (Name.fromLocal "A4"))
359 , (5, JS.Ref (Name.fromLocal "A5"))
360 , (6, JS.Ref (Name.fromLocal "A6"))
361 , (7, JS.Ref (Name.fromLocal "A7"))
362 , (8, JS.Ref (Name.fromLocal "A8"))
363 , (9, JS.Ref (Name.fromLocal "A9"))
364 ]
368-- CORE CALLS
371generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
372generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
373 if moduleName == N.basics then
374 generateBasicsCall mode home name args
376 else if moduleName == N.bitwise then
377 generateBitwiseCall home name (map (generateJsExpr mode) args)
379 else if moduleName == N.tuple then
380 generateTupleCall home name (map (generateJsExpr mode) args)
382 else
383 generateNormalCall' home name (map (generateJsExpr mode) args)
386generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
387generateTupleCall home name args =
388 case args of
389 [value] ->
390 case name of
391 "first" -> JS.Access value (Name.fromLocal "a")
392 "second" -> JS.Access value (Name.fromLocal "b")
393 _ -> generateNormalCall' home name args
395 _ ->
396 generateNormalCall' home name args
399generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
400generateBitwiseCall home name args =
401 case args of
402 [arg] ->
403 case name of
404 "complement" -> JS.Prefix JS.PrefixBNot arg
405 _ -> generateNormalCall' home name args
407 [left,right] ->
408 case name of
409 "and" -> JS.Infix JS.OpBAnd left right
410 "or" -> JS.Infix JS.OpBOr left right
411 "xor" -> JS.Infix JS.OpBXor left right
412 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
413 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
414 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
415 _ -> generateNormalCall' home name args
417 _ ->
418 generateNormalCall' home name args
421generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
422generateBasicsCall mode home name args =
423 case args of
424 [elmArg] ->
425 let arg = generateJsExpr mode elmArg in
426 case name of
427 "not" -> JS.Prefix JS.PrefixLNot arg
428 "toFloat" -> arg
429 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
430 _ -> generateNormalCall' home name [arg]
432 [elmLeft, elmRight] ->
433 case name of
434 "composeL" -> decomposeL mode elmLeft [elmRight]
435 "composeR" -> decomposeR mode [elmLeft] elmRight
436 "append" -> append mode elmLeft elmRight
437 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
438 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
439 _ ->
440 let
441 left = generateJsExpr mode elmLeft
442 right = generateJsExpr mode elmRight
443 in
444 case name of
445 "add" -> JS.Infix JS.OpAdd left right
446 "sub" -> JS.Infix JS.OpSub left right
447 "mul" -> JS.Infix JS.OpMul left right
448 "fdiv" -> JS.Infix JS.OpDiv left right
449 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
450 "eq" -> equal left right
451 "neq" -> notEqual left right
452 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
453 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
454 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
455 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
456 "or" -> JS.Infix JS.OpLOr left right
457 "and" -> JS.Infix JS.OpLAnd left right
458 "xor" -> JS.Infix JS.OpStrictNEq left right
459 _ -> generateNormalCall' home name [left, right]
461 _ ->
462 generateNormalCall' home name (map (generateJsExpr mode) args)
465equal :: JS.Expr -> JS.Expr -> JS.Expr
466equal left right =
467 if isLiteral left || isLiteral right then
468 strictEq left right
469 else
470 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
473notEqual :: JS.Expr -> JS.Expr -> JS.Expr
474notEqual left right =
475 if isLiteral left || isLiteral right then
476 strictNEq left right
477 else
478 JS.Prefix JS.PrefixLNot $
479 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
482cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
483cmp idealOp backupOp backupInt left right =
484 if isLiteral left || isLiteral right then
485 JS.Infix idealOp left right
486 else
487 JS.Infix backupOp
488 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
489 (JS.Int backupInt)
492isLiteral :: JS.Expr -> Bool
493isLiteral expr =
494 case expr of
495 JS.String _ ->
496 True
498 JS.Float _ ->
499 True
501 JS.Int _ ->
502 True
504 JS.Bool _ ->
505 True
507 _ ->
508 False
511decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
512decomposeL mode expr funcs =
513 case expr of
514 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
515 | home == ModuleName.basics ->
516 decomposeL mode left (func:funcs)
518 _ ->
519 generateJsExpr mode $
520 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
523decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
524decomposeR mode funcs expr =
525 case expr of
526 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
527 | home == ModuleName.basics ->
528 decomposeR mode (func:funcs) right
530 _ ->
531 generateJsExpr mode $
532 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
535apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
536apply func value =
537 case func of
538 Opt.Accessor field ->
539 Opt.Access value field
541 Opt.Call f args ->
542 Opt.Call f (args ++ [value])
544 _ ->
545 Opt.Call func [value]
548append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
549append mode left right =
550 let seqs = generateJsExpr mode left : toSeqs mode right in
551 if any isStringLiteral seqs then
552 foldr1 (JS.Infix JS.OpAdd) seqs
553 else
554 foldr1 jsAppend seqs
557jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
558jsAppend a b =
559 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
562toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
563toSeqs mode expr =
564 case expr of
565 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
566 | home == ModuleName.basics ->
567 generateJsExpr mode left : toSeqs mode right
569 _ ->
570 [generateJsExpr mode expr]
573isStringLiteral :: JS.Expr -> Bool
574isStringLiteral expr =
575 case expr of
576 JS.String _ ->
577 True
579 _ ->
580 False
584-- SIMPLIFY INFIX OPERATORS
587strictEq :: JS.Expr -> JS.Expr -> JS.Expr
588strictEq left right =
589 case left of
590 JS.Int 0 ->
591 JS.Prefix JS.PrefixLNot right
593 JS.Bool bool ->
594 if bool then right else JS.Prefix JS.PrefixLNot right
596 _ ->
597 case right of
598 JS.Int 0 ->
599 JS.Prefix JS.PrefixLNot left
601 JS.Bool bool ->
602 if bool then left else JS.Prefix JS.PrefixLNot left
604 _ ->
605 JS.Infix JS.OpStrictEq left right
608strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
609strictNEq left right =
610 case left of
611 JS.Int 0 ->
612 right
614 JS.Bool bool ->
615 if bool then JS.Prefix JS.PrefixLNot right else right
617 _ ->
618 case right of
619 JS.Int 0 ->
620 left
622 JS.Bool bool ->
623 if bool then JS.Prefix JS.PrefixLNot left else left
625 _ ->
626 JS.Infix JS.OpStrictNEq left right
630-- TAIL CALL
633-- TODO check if JS minifiers collapse unnecessary temporary variables
634--
635generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
636generateTailCall mode name args =
637 let
638 toTempVars (argName, arg) =
639 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
641 toRealVars (argName, _) =
642 JS.ExprStmt $
643 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
644 in
645 JS.Var (map toTempVars args)
646 : map toRealVars args
647 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
651-- DEFINITIONS
654generateDef :: Mode -> Opt.Def -> JS.Stmt
655generateDef mode def =
656 case def of
657 Opt.Def name body ->
658 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
660 Opt.TailDef name argNames body ->
661 let
662 function =
663 JS.Function Nothing (map Name.fromLocal argNames)
664 [ JS.Labelled (Name.fromLocal name) $
665 JS.While (JS.Bool True) $
666 codeToStmt $ generate mode body
667 ]
668 in
669 JS.Var [ (Name.fromLocal name, Just function) ]
673-- GENERATE IFS
676generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
677generateIf mode givenBranches givenFinal =
678 let
679 (branches, final) =
680 crushIfs givenBranches givenFinal
682 convertBranch (condition, expr) =
683 ( generateJsExpr mode condition
684 , generate mode expr
685 )
687 branchExprs = map convertBranch branches
688 finalCode = generate mode final
689 in
690 if isBlock finalCode || any (isBlock . snd) branchExprs then
691 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
692 else
693 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
696addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
697addExprIf (condition, branch) final =
698 JS.If condition (codeToExpr branch) final
701addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
702addStmtIf (condition, branch) final =
703 JS.IfStmt condition (codeToStmt branch) final
706isBlock :: Code -> Bool
707isBlock code =
708 case code of
709 JsBlock _ -> True
710 JsExpr _ -> False
713crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
714crushIfs branches final =
715 crushIfsHelp [] branches final
718crushIfsHelp
719 :: [(Opt.Expr, Opt.Expr)]
720 -> [(Opt.Expr, Opt.Expr)]
721 -> Opt.Expr
722 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
723crushIfsHelp visitedBranches unvisitedBranches final =
724 case unvisitedBranches of
725 [] ->
726 case final of
727 Opt.If subBranches subFinal ->
728 crushIfsHelp visitedBranches subBranches subFinal
730 _ ->
731 (reverse visitedBranches, final)
733 visiting : unvisited ->
734 crushIfsHelp (visiting : visitedBranches) unvisited final
738-- CASE EXPRESSIONS
741generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
742generateCase mode label root decider jumps =
743 foldr (goto mode label) (generateDecider mode label root decider) jumps
746goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
747goto mode label (index, branch) stmts =
748 let
749 labeledDeciderStmt =
750 JS.Labelled
751 (Name.makeLabel label index)
752 (JS.While (JS.Bool True) (JS.Block stmts))
753 in
754 labeledDeciderStmt : codeToStmtList (generate mode branch)
757generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
758generateDecider mode label root decisionTree =
759 case decisionTree of
760 Opt.Leaf (Opt.Inline branch) ->
761 codeToStmtList (generate mode branch)
763 Opt.Leaf (Opt.Jump index) ->
764 [ JS.Break (Just (Name.makeLabel label index)) ]
766 Opt.Chain testChain success failure ->
767 let
768 makeTest (path, test) =
769 strictEq
770 (pathToTestableExpr mode root path test)
771 (testToExpr mode test)
772 in
773 [ JS.IfStmt
774 (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))
775 (JS.Block $ generateDecider mode label root success)
776 (JS.Block $ generateDecider mode label root failure)
777 ]
779 Opt.FanOut path edges fallback ->
780 [ JS.Switch
781 (pathToTestableExpr mode root path (fst (head edges)))
782 ( foldr
783 (addCase mode label root)
784 [ JS.Default (generateDecider mode label root fallback) ]
785 edges
786 )
787 ]
790addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
791addCase mode label root (test, subTree) cases =
792 let stmts = generateDecider mode label root subTree in
793 JS.Case (testToExpr mode test) stmts : cases
796testToExpr :: Mode -> DT.Test -> JS.Expr
797testToExpr mode test =
798 case test of
799 DT.IsCtor _ tag index ->
800 case mode of
801 Name.Debug _ ->
802 JS.String (N.toBuilder tag)
804 Name.Prod _ _ ->
805 JS.Int (Index.toZeroBased index)
807 DT.IsInt int ->
808 JS.Int int
810 DT.IsChr char ->
811 JS.String (Text.encodeUtf8Builder char)
813 DT.IsStr string ->
814 JS.String (Text.encodeUtf8Builder string)
817pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
818pathToTestableExpr mode root path exampleTest =
819 let
820 expr =
821 pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path
822 in
823 case exampleTest of
824 DT.IsCtor _ _ _ ->
825 JS.Access expr Name.dollar
827 DT.IsInt _ ->
828 expr
830 DT.IsStr _ ->
831 expr
833 DT.IsChr _ ->
834 case mode of
835 Name.Debug _ ->
836 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
838 Name.Prod _ _ ->
839 expr
842pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr
843pathToJsExpr mode expr path =
844 case path of
845 DT.Index index subpath ->
846 pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath
848 DT.Field field subpath ->
849 pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
851 DT.Empty ->
852 expr
854 DT.Alias ->
855 expr
859-- GENERATE MAIN
862generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> [N.Name] -> Opt.Main -> JS.Expr
863generateMain mode interfaces home segments main =
864 case main of
865 Opt.Static ->
866 JS.Ref (Name.fromKernel N.browser "staticPage")
867 # JS.Ref (Name.fromGlobal home "main")
868 # List.foldl' addDot elm segments
870 Opt.Dynamic decoder msgType ->
871 JS.Ref (Name.fromGlobal home "main")
872 # List.foldl' addDot elm segments
873 # generateJsExpr mode decoder
874 # JS.Json (Type.encodeMetadata (Extract.fromMsg interfaces msgType))
877(#) :: JS.Expr -> JS.Expr -> JS.Expr
878(#) func arg =
879 JS.Call func [arg]
882addDot :: JS.Expr -> N.Name -> JS.Expr
883addDot root name =
884 JS.Index root (JS.String (N.toBuilder name))
887{-# NOINLINE elm #-}
888elm :: JS.Expr
889elm =
890 JS.Ref (Name.fromLocal "Elm")