git.iko.soy/elk
on 474ec0d help sign in
elk/src/Generate/JavaScript/Expression.hs
851 lines 22 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateFunction
6 , Code
7 , codeToExpr
8 , codeToStmtList
9 )
10 where
13import qualified Data.IntMap as IntMap
14import qualified Data.List as List
15import qualified Data.Map as Map
16import qualified Data.Text.Encoding as Text
18import qualified AST.Optimized as Opt
19import qualified AST.Module.Name as ModuleName
20import qualified Data.Index as Index
21import qualified Elm.Name as N
22import qualified Elm.Package as Pkg
23import qualified Generate.JavaScript.Builder as JS
24import qualified Generate.JavaScript.Name as Name
25import qualified Optimize.DecisionTree as DT
26import qualified Reporting.Region as R
30-- ENVIRONMENT
33type Mode = Name.Mode
37-- EXPRESSIONS
40generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
41generateJsExpr mode expression =
42 codeToExpr (generate mode expression)
45generate :: Mode -> Opt.Expr -> Code
46generate mode expression =
47 case expression of
48 Opt.Chr char ->
49 JsExpr $
50 case mode of
51 Name.Debug _ ->
52 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
54 Name.Prod _ _ ->
55 JS.String (Text.encodeUtf8Builder char)
57 Opt.Str string ->
58 JsExpr $ JS.String (Text.encodeUtf8Builder string)
60 Opt.Int int ->
61 JsExpr $ JS.Int int
63 Opt.Float float ->
64 JsExpr $ JS.Float float
66 Opt.VarLocal name ->
67 JsExpr $ JS.Ref (Name.fromLocal name)
69 Opt.VarGlobal (Opt.Global home name) ->
70 JsExpr $ JS.Ref (Name.fromGlobal home name)
72 Opt.VarCycle home name ->
73 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
75 Opt.VarDebug name home region unhandledValueName ->
76 JsExpr $ generateDebug name home region unhandledValueName
78 Opt.VarKernel home name ->
79 JsExpr $ JS.Ref (Name.fromKernel home name)
81 Opt.List entries ->
82 JsExpr $
83 JS.Call
84 (JS.Ref (Name.fromKernel N.list "fromArray"))
85 [ JS.Array $ map (generateJsExpr mode) entries
86 ]
88 Opt.Function args body ->
89 generateFunction (map Name.fromLocal args) (generate mode body)
91 Opt.Call func args ->
92 JsExpr $ generateCall mode func args
94 Opt.TailCall name args ->
95 JsBlock $ generateTailCall mode name args
97 Opt.If branches final ->
98 generateIf mode branches final
100 Opt.Let def body ->
101 JsBlock $
102 generateDef mode def : codeToStmtList (generate mode body)
104 Opt.Case label root decider jumps ->
105 JsBlock $ generateCase mode label root decider jumps
107 Opt.Index expr index ->
108 JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)
110 Opt.Accessor field ->
111 JsExpr $ JS.Function Nothing [Name.dollar]
112 [ JS.Return $ Just $
113 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
114 ]
116 Opt.Access record field ->
117 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
119 Opt.Update record fields ->
120 JsExpr $
121 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
122 [ generateJsExpr mode record
123 , generateRecord mode fields
124 ]
126 Opt.Record fields ->
127 JsExpr $ generateRecord mode fields
129 Opt.Unit ->
130 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
132 Opt.Tuple a b maybeC ->
133 JsExpr $
134 case maybeC of
135 Nothing ->
136 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
137 [ generateJsExpr mode a
138 , generateJsExpr mode b
139 ]
141 Just c ->
142 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
143 [ generateJsExpr mode a
144 , generateJsExpr mode b
145 , generateJsExpr mode c
146 ]
148 Opt.Shader src ->
149 let string = JS.String (Text.encodeUtf8Builder src) in
150 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
154-- CODE CHUNKS
157data Code
158 = JsExpr JS.Expr
159 | JsBlock [JS.Stmt]
162codeToExpr :: Code -> JS.Expr
163codeToExpr code =
164 case code of
165 JsExpr expr ->
166 expr
168 JsBlock stmts ->
169 JS.Call (JS.Function Nothing [] stmts) []
172codeToStmtList :: Code -> [JS.Stmt]
173codeToStmtList code =
174 case code of
175 JsExpr expr ->
176 [ JS.Return (Just expr) ]
178 JsBlock stmts ->
179 stmts
182codeToStmt :: Code -> JS.Stmt
183codeToStmt code =
184 case code of
185 JsExpr expr ->
186 JS.Return (Just expr)
188 JsBlock [stmt] ->
189 stmt
191 JsBlock stmts ->
192 JS.Block stmts
196-- CHARS
199{-# NOINLINE toChar #-}
200toChar :: JS.Expr
201toChar =
202 JS.Ref (Name.fromKernel N.utils "chr")
206-- CTOR
209generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
210generateCtor mode name index arity =
211 let
212 argNames = map Name.fromInt [1 .. arity]
213 argFields = map (\n -> (n, JS.Ref n)) argNames
215 tag =
216 case mode of
217 Name.Debug _ ->
218 ( Name.dollar, JS.String (N.toBuilder name) )
220 Name.Prod _ _ ->
221 ( Name.dollar, JS.Int (Index.toZeroBased index) )
222 in
223 ( argNames, JsExpr (JS.Object (tag:argFields)) )
227-- RECORDS
230generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
231generateRecord mode fields =
232 let
233 toPair (field, value) =
234 (Name.fromField mode field, generateJsExpr mode value)
235 in
236 JS.Object (map toPair (Map.toList fields))
240-- DEBUG
243generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
244generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
245 if name /= "crash" then
246 JS.Ref (Name.fromGlobal ModuleName.debug name)
247 else
248 case unhandledValueName of
249 Nothing ->
250 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
251 [ JS.String (N.toBuilder home)
252 , regionToJsExpr region
253 ]
255 Just valueName ->
256 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
257 [ JS.String (N.toBuilder home)
258 , regionToJsExpr region
259 , JS.Ref (Name.fromLocal valueName)
260 ]
263regionToJsExpr :: R.Region -> JS.Expr
264regionToJsExpr (R.Region start end) =
265 JS.Object
266 [ ( Name.fromLocal "start", positionToJsExpr start )
267 , ( Name.fromLocal "end", positionToJsExpr end )
268 ]
271positionToJsExpr :: R.Position -> JS.Expr
272positionToJsExpr (R.Position line column) =
273 JS.Object
274 [ ( Name.fromLocal "line", JS.Int line )
275 , ( Name.fromLocal "column", JS.Int column )
276 ]
280-- FUNCTION
283generateFunction :: [Name.Name] -> Code -> Code
284generateFunction args body =
285 case IntMap.lookup (length args) funcHelpers of
286 Just helper ->
287 JsExpr $
288 JS.Call helper
289 [ JS.Function Nothing args $
290 codeToStmtList body
291 ]
293 Nothing ->
294 let
295 addArg arg code =
296 JsExpr $ JS.Function Nothing [arg] $
297 codeToStmtList code
298 in
299 foldr addArg body args
302{-# NOINLINE funcHelpers #-}
303funcHelpers :: IntMap.IntMap JS.Expr
304funcHelpers =
305 IntMap.fromList
306 [ (2, JS.Ref (Name.fromLocal "F2"))
307 , (3, JS.Ref (Name.fromLocal "F3"))
308 , (4, JS.Ref (Name.fromLocal "F4"))
309 , (5, JS.Ref (Name.fromLocal "F5"))
310 , (6, JS.Ref (Name.fromLocal "F6"))
311 , (7, JS.Ref (Name.fromLocal "F7"))
312 , (8, JS.Ref (Name.fromLocal "F8"))
313 , (9, JS.Ref (Name.fromLocal "F9"))
314 ]
318-- CALLS
321generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
322generateCall mode func args =
323 case func of
324 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
325 generateCoreCall mode global args
327 _ ->
328 generateNormalCall
329 (generateJsExpr mode func)
330 (map (generateJsExpr mode) args)
333generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
334generateNormalCall' home name args =
335 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
338generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
339generateNormalCall func args =
340 case IntMap.lookup (length args) callHelpers of
341 Just helper ->
342 JS.Call helper (func:args)
344 Nothing ->
345 List.foldl' (\f a -> JS.Call f [a]) func args
348{-# NOINLINE callHelpers #-}
349callHelpers :: IntMap.IntMap JS.Expr
350callHelpers =
351 IntMap.fromList
352 [ (2, JS.Ref (Name.fromLocal "A2"))
353 , (3, JS.Ref (Name.fromLocal "A3"))
354 , (4, JS.Ref (Name.fromLocal "A4"))
355 , (5, JS.Ref (Name.fromLocal "A5"))
356 , (6, JS.Ref (Name.fromLocal "A6"))
357 , (7, JS.Ref (Name.fromLocal "A7"))
358 , (8, JS.Ref (Name.fromLocal "A8"))
359 , (9, JS.Ref (Name.fromLocal "A9"))
360 ]
364-- CORE CALLS
367generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
368generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
369 if moduleName == N.basics then
370 generateBasicsCall mode home name args
372 else if moduleName == N.bitwise then
373 generateBitwiseCall home name (map (generateJsExpr mode) args)
375 else if moduleName == N.tuple then
376 generateTupleCall home name (map (generateJsExpr mode) args)
378 else
379 generateNormalCall' home name (map (generateJsExpr mode) args)
382generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
383generateTupleCall home name args =
384 case args of
385 [value] ->
386 case name of
387 "first" -> JS.Access value (Name.fromLocal "a")
388 "second" -> JS.Access value (Name.fromLocal "b")
389 _ -> generateNormalCall' home name args
391 _ ->
392 generateNormalCall' home name args
395generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
396generateBitwiseCall home name args =
397 case args of
398 [arg] ->
399 case name of
400 "complement" -> JS.Prefix JS.PrefixBNot arg
401 _ -> generateNormalCall' home name args
403 [left,right] ->
404 case name of
405 "and" -> JS.Infix JS.OpBAnd left right
406 "or" -> JS.Infix JS.OpBOr left right
407 "xor" -> JS.Infix JS.OpBXor left right
408 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
409 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
410 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
411 _ -> generateNormalCall' home name args
413 _ ->
414 generateNormalCall' home name args
417generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
418generateBasicsCall mode home name args =
419 case args of
420 [elmArg] ->
421 let arg = generateJsExpr mode elmArg in
422 case name of
423 "not" -> JS.Prefix JS.PrefixLNot arg
424 "toFloat" -> arg
425 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
426 _ -> generateNormalCall' home name [arg]
428 [elmLeft, elmRight] ->
429 case name of
430 "composeL" -> decomposeL mode elmLeft [elmRight]
431 "composeR" -> decomposeR mode [elmLeft] elmRight
432 "append" -> append mode elmLeft elmRight
433 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
434 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
435 _ ->
436 let
437 left = generateJsExpr mode elmLeft
438 right = generateJsExpr mode elmRight
439 in
440 case name of
441 "add" -> JS.Infix JS.OpAdd left right
442 "sub" -> JS.Infix JS.OpSub left right
443 "mul" -> JS.Infix JS.OpMul left right
444 "fdiv" -> JS.Infix JS.OpDiv left right
445 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
446 "eq" -> equal left right
447 "neq" -> notEqual left right
448 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
449 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
450 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
451 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
452 "or" -> JS.Infix JS.OpLOr left right
453 "and" -> JS.Infix JS.OpLAnd left right
454 "xor" -> JS.Infix JS.OpStrictNEq left right
455 _ -> generateNormalCall' home name [left, right]
457 _ ->
458 generateNormalCall' home name (map (generateJsExpr mode) args)
461equal :: JS.Expr -> JS.Expr -> JS.Expr
462equal left right =
463 if isLiteral left || isLiteral right then
464 strictEq left right
465 else
466 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
469notEqual :: JS.Expr -> JS.Expr -> JS.Expr
470notEqual left right =
471 if isLiteral left || isLiteral right then
472 strictNEq left right
473 else
474 JS.Prefix JS.PrefixLNot $
475 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
478cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
479cmp idealOp backupOp backupInt left right =
480 if isLiteral left || isLiteral right then
481 JS.Infix idealOp left right
482 else
483 JS.Infix backupOp
484 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
485 (JS.Int backupInt)
488isLiteral :: JS.Expr -> Bool
489isLiteral expr =
490 case expr of
491 JS.String _ ->
492 True
494 JS.Float _ ->
495 True
497 JS.Int _ ->
498 True
500 JS.Bool _ ->
501 True
503 _ ->
504 False
507decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
508decomposeL mode expr funcs =
509 case expr of
510 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
511 | home == ModuleName.basics ->
512 decomposeL mode left (func:funcs)
514 _ ->
515 generateJsExpr mode $
516 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
519decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
520decomposeR mode funcs expr =
521 case expr of
522 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
523 | home == ModuleName.basics ->
524 decomposeR mode (func:funcs) right
526 _ ->
527 generateJsExpr mode $
528 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
531apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
532apply func value =
533 case func of
534 Opt.Accessor field ->
535 Opt.Access value field
537 Opt.Call f args ->
538 Opt.Call f (args ++ [value])
540 _ ->
541 Opt.Call func [value]
544append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
545append mode left right =
546 let seqs = generateJsExpr mode left : toSeqs mode right in
547 if any isStringLiteral seqs then
548 foldr1 (JS.Infix JS.OpAdd) seqs
549 else
550 foldr1 jsAppend seqs
553jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
554jsAppend a b =
555 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
558toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
559toSeqs mode expr =
560 case expr of
561 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
562 | home == ModuleName.basics ->
563 generateJsExpr mode left : toSeqs mode right
565 _ ->
566 [generateJsExpr mode expr]
569isStringLiteral :: JS.Expr -> Bool
570isStringLiteral expr =
571 case expr of
572 JS.String _ ->
573 True
575 _ ->
576 False
580-- SIMPLIFY INFIX OPERATORS
583strictEq :: JS.Expr -> JS.Expr -> JS.Expr
584strictEq left right =
585 case left of
586 JS.Int 0 ->
587 JS.Prefix JS.PrefixLNot right
589 JS.Bool bool ->
590 if bool then right else JS.Prefix JS.PrefixLNot right
592 _ ->
593 case right of
594 JS.Int 0 ->
595 JS.Prefix JS.PrefixLNot left
597 JS.Bool bool ->
598 if bool then left else JS.Prefix JS.PrefixLNot left
600 _ ->
601 JS.Infix JS.OpStrictEq left right
604strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
605strictNEq left right =
606 case left of
607 JS.Int 0 ->
608 right
610 JS.Bool bool ->
611 if bool then JS.Prefix JS.PrefixLNot right else right
613 _ ->
614 case right of
615 JS.Int 0 ->
616 left
618 JS.Bool bool ->
619 if bool then JS.Prefix JS.PrefixLNot left else left
621 _ ->
622 JS.Infix JS.OpStrictNEq left right
626-- TAIL CALL
629-- TODO check if JS minifiers collapse unnecessary temporary variables
630--
631generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
632generateTailCall mode name args =
633 let
634 toTempVars (argName, arg) =
635 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
637 toRealVars (argName, _) =
638 JS.ExprStmt $
639 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
640 in
641 JS.Var (map toTempVars args)
642 : map toRealVars args
643 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
647-- DEFINITIONS
650generateDef :: Mode -> Opt.Def -> JS.Stmt
651generateDef mode def =
652 case def of
653 Opt.Def name body ->
654 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
656 Opt.TailDef name argNames body ->
657 let
658 function =
659 JS.Function Nothing (map Name.fromLocal argNames)
660 [ JS.Labelled (Name.fromLocal name) $
661 JS.While (JS.Bool True) $
662 codeToStmt $ generate mode body
663 ]
664 in
665 JS.Var [ (Name.fromLocal name, Just function) ]
669-- GENERATE IFS
672generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
673generateIf mode givenBranches givenFinal =
674 let
675 (branches, final) =
676 crushIfs givenBranches givenFinal
678 convertBranch (condition, expr) =
679 ( generateJsExpr mode condition
680 , generate mode expr
681 )
683 branchExprs = map convertBranch branches
684 finalCode = generate mode final
685 in
686 if isBlock finalCode || any (isBlock . snd) branchExprs then
687 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
688 else
689 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
692addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
693addExprIf (condition, branch) final =
694 JS.If condition (codeToExpr branch) final
697addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
698addStmtIf (condition, branch) final =
699 JS.IfStmt condition (codeToStmt branch) final
702isBlock :: Code -> Bool
703isBlock code =
704 case code of
705 JsBlock _ -> True
706 JsExpr _ -> False
709crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
710crushIfs branches final =
711 crushIfsHelp [] branches final
714crushIfsHelp
715 :: [(Opt.Expr, Opt.Expr)]
716 -> [(Opt.Expr, Opt.Expr)]
717 -> Opt.Expr
718 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
719crushIfsHelp visitedBranches unvisitedBranches final =
720 case unvisitedBranches of
721 [] ->
722 case final of
723 Opt.If subBranches subFinal ->
724 crushIfsHelp visitedBranches subBranches subFinal
726 _ ->
727 (reverse visitedBranches, final)
729 visiting : unvisited ->
730 crushIfsHelp (visiting : visitedBranches) unvisited final
734-- CASE EXPRESSIONS
737generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
738generateCase mode label root decider jumps =
739 foldr (goto mode label) (generateDecider mode label root decider) jumps
742goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
743goto mode label (index, branch) stmts =
744 let
745 labeledDeciderStmt =
746 JS.Labelled
747 (Name.makeLabel label index)
748 (JS.While (JS.Bool True) (JS.Block stmts))
749 in
750 labeledDeciderStmt : codeToStmtList (generate mode branch)
753generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
754generateDecider mode label root decisionTree =
755 case decisionTree of
756 Opt.Leaf (Opt.Inline branch) ->
757 codeToStmtList (generate mode branch)
759 Opt.Leaf (Opt.Jump index) ->
760 [ JS.Break (Just (Name.makeLabel label index)) ]
762 Opt.Chain testChain success failure ->
763 let
764 makeTest (path, test) =
765 strictEq
766 (pathToTestableExpr mode root path test)
767 (testToExpr mode test)
768 in
769 [ JS.IfStmt
770 (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))
771 (JS.Block $ generateDecider mode label root success)
772 (JS.Block $ generateDecider mode label root failure)
773 ]
775 Opt.FanOut path edges fallback ->
776 [ JS.Switch
777 (pathToTestableExpr mode root path (fst (head edges)))
778 ( foldr
779 (addCase mode label root)
780 [ JS.Default (generateDecider mode label root fallback) ]
781 edges
782 )
783 ]
786addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
787addCase mode label root (test, subTree) cases =
788 let stmts = generateDecider mode label root subTree in
789 JS.Case (testToExpr mode test) stmts : cases
792testToExpr :: Mode -> DT.Test -> JS.Expr
793testToExpr mode test =
794 case test of
795 DT.IsCtor _ tag index ->
796 case mode of
797 Name.Debug _ ->
798 JS.String (N.toBuilder tag)
800 Name.Prod _ _ ->
801 JS.Int (Index.toZeroBased index)
803 DT.IsInt int ->
804 JS.Int int
806 DT.IsChr char ->
807 JS.String (Text.encodeUtf8Builder char)
809 DT.IsStr string ->
810 JS.String (Text.encodeUtf8Builder string)
813pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
814pathToTestableExpr mode root path exampleTest =
815 let
816 expr =
817 pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path
818 in
819 case exampleTest of
820 DT.IsCtor _ _ _ ->
821 JS.Access expr Name.dollar
823 DT.IsInt _ ->
824 expr
826 DT.IsStr _ ->
827 expr
829 DT.IsChr _ ->
830 case mode of
831 Name.Debug _ ->
832 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
834 Name.Prod _ _ ->
835 expr
838pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr
839pathToJsExpr mode expr path =
840 case path of
841 DT.Index index subpath ->
842 pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath
844 DT.Field field subpath ->
845 pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
847 DT.Empty ->
848 expr
850 DT.Alias ->
851 expr