git.iko.soy/elk
on 83e18b3 help sign in
elk/src/Generate/JavaScript/Expression.hs
1030 lines 26 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateTailDef
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.Bool bool ->
56 JsExpr $ JS.Bool bool
58 Opt.Chr char ->
59 JsExpr $
60 case mode of
61 Name.Debug _ ->
62 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
64 Name.Prod _ _ ->
65 JS.String (Text.encodeUtf8Builder char)
67 Opt.Str string ->
68 JsExpr $ JS.String (Text.encodeUtf8Builder string)
70 Opt.Int int ->
71 JsExpr $ JS.Int int
73 Opt.Float float ->
74 JsExpr $ JS.Float float
76 Opt.VarLocal name ->
77 JsExpr $ JS.Ref (Name.fromLocal name)
79 Opt.VarGlobal (Opt.Global home name) ->
80 JsExpr $ JS.Ref (Name.fromGlobal home name)
82 Opt.VarEnum (Opt.Global home name) index ->
83 case mode of
84 Name.Debug _ ->
85 JsExpr $ JS.Ref (Name.fromGlobal home name)
87 Name.Prod _ _ ->
88 JsExpr $ JS.Int (Index.toMachine index)
90 Opt.VarBox (Opt.Global home name) ->
91 JsExpr $ JS.Ref $
92 case mode of
93 Name.Debug _ -> Name.fromGlobal home name
94 Name.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
96 Opt.VarCycle home name ->
97 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
99 Opt.VarDebug name home region unhandledValueName ->
100 JsExpr $ generateDebug name home region unhandledValueName
102 Opt.VarKernel home name ->
103 JsExpr $ JS.Ref (Name.fromKernel home name)
105 Opt.List entries ->
106 case entries of
107 [] ->
108 JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")
110 _ ->
111 JsExpr $
112 JS.Call
113 (JS.Ref (Name.fromKernel N.list "fromArray"))
114 [ JS.Array $ map (generateJsExpr mode) entries
115 ]
117 Opt.Function args body ->
118 generateFunction (map Name.fromLocal args) (generate mode body)
120 Opt.Call func args ->
121 JsExpr $ generateCall mode func args
123 Opt.TailCall name args ->
124 JsBlock $ generateTailCall mode name args
126 Opt.If branches final ->
127 generateIf mode branches final
129 Opt.Let def body ->
130 JsBlock $
131 generateDef mode def : codeToStmtList (generate mode body)
133 Opt.Destruct (Opt.Destructor name path) body ->
134 let
135 pathExpr = generatePath mode path
136 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
137 in
138 JsBlock $ pathDef : codeToStmtList (generate mode body)
140 Opt.Case label root decider jumps ->
141 JsBlock $ generateCase mode label root decider jumps
143 Opt.Accessor field ->
144 JsExpr $ JS.Function Nothing [Name.dollar]
145 [ JS.Return $ Just $
146 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
147 ]
149 Opt.Access record field ->
150 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
152 Opt.Update record fields ->
153 JsExpr $
154 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
155 [ generateJsExpr mode record
156 , generateRecord mode fields
157 ]
159 Opt.Record fields ->
160 JsExpr $ generateRecord mode fields
162 Opt.Unit ->
163 case mode of
164 Name.Debug _ ->
165 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
167 Name.Prod _ _ ->
168 JsExpr $ JS.Int 0
170 Opt.Tuple a b maybeC ->
171 JsExpr $
172 case maybeC of
173 Nothing ->
174 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
175 [ generateJsExpr mode a
176 , generateJsExpr mode b
177 ]
179 Just c ->
180 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
181 [ generateJsExpr mode a
182 , generateJsExpr mode b
183 , generateJsExpr mode c
184 ]
186 Opt.Shader src ->
187 let string = JS.String (Text.encodeUtf8Builder src) in
188 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
192-- CODE CHUNKS
195data Code
196 = JsExpr JS.Expr
197 | JsBlock [JS.Stmt]
200codeToExpr :: Code -> JS.Expr
201codeToExpr code =
202 case code of
203 JsExpr expr ->
204 expr
206 JsBlock [ JS.Return (Just expr) ] ->
207 expr
209 JsBlock stmts ->
210 JS.Call (JS.Function Nothing [] stmts) []
213codeToStmtList :: Code -> [JS.Stmt]
214codeToStmtList code =
215 case code of
216 JsExpr expr ->
217 [ JS.Return (Just expr) ]
219 JsBlock stmts ->
220 stmts
223codeToStmt :: Code -> JS.Stmt
224codeToStmt code =
225 case code of
226 JsExpr expr ->
227 JS.Return (Just expr)
229 JsBlock [stmt] ->
230 stmt
232 JsBlock stmts ->
233 JS.Block stmts
237-- CHARS
240{-# NOINLINE toChar #-}
241toChar :: JS.Expr
242toChar =
243 JS.Ref (Name.fromKernel N.utils "chr")
247-- CTOR
250generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code
251generateCtor mode name index arity =
252 let
253 argNames =
254 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
256 ctorTag =
257 case mode of
258 Name.Debug _ -> JS.String (N.toBuilder name)
259 Name.Prod _ _ -> JS.Int (Index.toMachine index)
260 in
261 generateFunction argNames $ JsExpr $ JS.Object $
262 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
266-- RECORDS
269generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
270generateRecord mode fields =
271 let
272 toPair (field, value) =
273 (Name.fromField mode field, generateJsExpr mode value)
274 in
275 JS.Object (map toPair (Map.toList fields))
279-- DEBUG
282generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
283generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
284 if name /= "crash" then
285 JS.Ref (Name.fromGlobal ModuleName.debug name)
286 else
287 case unhandledValueName of
288 Nothing ->
289 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
290 [ JS.String (N.toBuilder home)
291 , regionToJsExpr region
292 ]
294 Just valueName ->
295 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
296 [ JS.String (N.toBuilder home)
297 , regionToJsExpr region
298 , JS.Ref (Name.fromLocal valueName)
299 ]
302regionToJsExpr :: R.Region -> JS.Expr
303regionToJsExpr (R.Region start end) =
304 JS.Object
305 [ ( Name.fromLocal "start", positionToJsExpr start )
306 , ( Name.fromLocal "end", positionToJsExpr end )
307 ]
310positionToJsExpr :: R.Position -> JS.Expr
311positionToJsExpr (R.Position line column) =
312 JS.Object
313 [ ( Name.fromLocal "line", JS.Int line )
314 , ( Name.fromLocal "column", JS.Int column )
315 ]
319-- FUNCTION
322generateFunction :: [Name.Name] -> Code -> Code
323generateFunction args body =
324 case IntMap.lookup (length args) funcHelpers of
325 Just helper ->
326 JsExpr $
327 JS.Call helper
328 [ JS.Function Nothing args $
329 codeToStmtList body
330 ]
332 Nothing ->
333 let
334 addArg arg code =
335 JsExpr $ JS.Function Nothing [arg] $
336 codeToStmtList code
337 in
338 foldr addArg body args
341{-# NOINLINE funcHelpers #-}
342funcHelpers :: IntMap.IntMap JS.Expr
343funcHelpers =
344 IntMap.fromList $
345 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
349-- CALLS
352generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
353generateCall mode func args =
354 case func of
355 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
356 generateCoreCall mode global args
358 Opt.VarBox _ ->
359 case mode of
360 Name.Debug _ ->
361 generateCallHelp mode func args
363 Name.Prod _ _ ->
364 case args of
365 [arg] ->
366 generateJsExpr mode arg
368 _ ->
369 generateCallHelp mode func args
371 _ ->
372 generateCallHelp mode func args
375generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
376generateCallHelp mode func args =
377 generateNormalCall
378 (generateJsExpr mode func)
379 (map (generateJsExpr mode) args)
382generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
383generateGlobalCall home name args =
384 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
387generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
388generateNormalCall func args =
389 case IntMap.lookup (length args) callHelpers of
390 Just helper ->
391 JS.Call helper (func:args)
393 Nothing ->
394 List.foldl' (\f a -> JS.Call f [a]) func args
397{-# NOINLINE callHelpers #-}
398callHelpers :: IntMap.IntMap JS.Expr
399callHelpers =
400 IntMap.fromList $
401 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
405-- CORE CALLS
408generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
409generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
410 if moduleName == N.basics then
411 generateBasicsCall mode home name args
413 else if moduleName == N.bitwise then
414 generateBitwiseCall home name (map (generateJsExpr mode) args)
416 else if moduleName == N.tuple then
417 generateTupleCall home name (map (generateJsExpr mode) args)
419 else if moduleName == N.jsArray then
420 generateJsArrayCall home name (map (generateJsExpr mode) args)
422 else
423 generateGlobalCall home name (map (generateJsExpr mode) args)
426generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
427generateTupleCall home name args =
428 case args of
429 [value] ->
430 case name of
431 "first" -> JS.Access value (Name.fromLocal "a")
432 "second" -> JS.Access value (Name.fromLocal "b")
433 _ -> generateGlobalCall home name args
435 _ ->
436 generateGlobalCall home name args
439generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
440generateJsArrayCall home name args =
441 case args of
442 [entry] | name == "singleton" -> JS.Array [entry]
443 [index, array] | name == "unsafeGet" -> JS.Index array index
444 _ -> generateGlobalCall home name args
447generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
448generateBitwiseCall home name args =
449 case args of
450 [arg] ->
451 case name of
452 "complement" -> JS.Prefix JS.PrefixBNot arg
453 _ -> generateGlobalCall home name args
455 [left,right] ->
456 case name of
457 "and" -> JS.Infix JS.OpBAnd left right
458 "or" -> JS.Infix JS.OpBOr left right
459 "xor" -> JS.Infix JS.OpBXor left right
460 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
461 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
462 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
463 _ -> generateGlobalCall home name args
465 _ ->
466 generateGlobalCall home name args
469generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
470generateBasicsCall mode home name args =
471 case args of
472 [elmArg] ->
473 let arg = generateJsExpr mode elmArg in
474 case name of
475 "not" -> JS.Prefix JS.PrefixLNot arg
476 "toFloat" -> arg
477 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
478 _ -> generateGlobalCall home name [arg]
480 [elmLeft, elmRight] ->
481 case name of
482 "composeL" -> decomposeL mode elmLeft [elmRight]
483 "composeR" -> decomposeR mode [elmLeft] elmRight
484 "append" -> append mode elmLeft elmRight
485 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
486 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
487 _ ->
488 let
489 left = generateJsExpr mode elmLeft
490 right = generateJsExpr mode elmRight
491 in
492 case name of
493 "add" -> JS.Infix JS.OpAdd left right
494 "sub" -> JS.Infix JS.OpSub left right
495 "mul" -> JS.Infix JS.OpMul left right
496 "fdiv" -> JS.Infix JS.OpDiv left right
497 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
498 "eq" -> equal left right
499 "neq" -> notEqual left right
500 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
501 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
502 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
503 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
504 "or" -> JS.Infix JS.OpLOr left right
505 "and" -> JS.Infix JS.OpLAnd left right
506 "xor" -> JS.Infix JS.OpStrictNEq left right
507 _ -> generateGlobalCall home name [left, right]
509 _ ->
510 generateGlobalCall home name (map (generateJsExpr mode) args)
513equal :: JS.Expr -> JS.Expr -> JS.Expr
514equal left right =
515 if isLiteral left || isLiteral right then
516 strictEq left right
517 else
518 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
521notEqual :: JS.Expr -> JS.Expr -> JS.Expr
522notEqual left right =
523 if isLiteral left || isLiteral right then
524 strictNEq left right
525 else
526 JS.Prefix JS.PrefixLNot $
527 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
530cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
531cmp idealOp backupOp backupInt left right =
532 if isLiteral left || isLiteral right then
533 JS.Infix idealOp left right
534 else
535 JS.Infix backupOp
536 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
537 (JS.Int backupInt)
540isLiteral :: JS.Expr -> Bool
541isLiteral expr =
542 case expr of
543 JS.String _ ->
544 True
546 JS.Float _ ->
547 True
549 JS.Int _ ->
550 True
552 JS.Bool _ ->
553 True
555 _ ->
556 False
559decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
560decomposeL mode expr funcs =
561 case expr of
562 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
563 | home == ModuleName.basics ->
564 decomposeL mode left (func:funcs)
566 _ ->
567 generateJsExpr mode $
568 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
571decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
572decomposeR mode funcs expr =
573 case expr of
574 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
575 | home == ModuleName.basics ->
576 decomposeR mode (func:funcs) right
578 _ ->
579 generateJsExpr mode $
580 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
583apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
584apply func value =
585 case func of
586 Opt.Accessor field ->
587 Opt.Access value field
589 Opt.Call f args ->
590 Opt.Call f (args ++ [value])
592 _ ->
593 Opt.Call func [value]
596append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
597append mode left right =
598 let seqs = generateJsExpr mode left : toSeqs mode right in
599 if any isStringLiteral seqs then
600 foldr1 (JS.Infix JS.OpAdd) seqs
601 else
602 foldr1 jsAppend seqs
605jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
606jsAppend a b =
607 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
610toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
611toSeqs mode expr =
612 case expr of
613 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
614 | home == ModuleName.basics ->
615 generateJsExpr mode left : toSeqs mode right
617 _ ->
618 [generateJsExpr mode expr]
621isStringLiteral :: JS.Expr -> Bool
622isStringLiteral expr =
623 case expr of
624 JS.String _ ->
625 True
627 _ ->
628 False
632-- SIMPLIFY INFIX OPERATORS
635strictEq :: JS.Expr -> JS.Expr -> JS.Expr
636strictEq left right =
637 case left of
638 JS.Int 0 ->
639 JS.Prefix JS.PrefixLNot right
641 JS.Bool bool ->
642 if bool then right else JS.Prefix JS.PrefixLNot right
644 _ ->
645 case right of
646 JS.Int 0 ->
647 JS.Prefix JS.PrefixLNot left
649 JS.Bool bool ->
650 if bool then left else JS.Prefix JS.PrefixLNot left
652 _ ->
653 JS.Infix JS.OpStrictEq left right
656strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
657strictNEq left right =
658 case left of
659 JS.Int 0 ->
660 right
662 JS.Bool bool ->
663 if bool then JS.Prefix JS.PrefixLNot right else right
665 _ ->
666 case right of
667 JS.Int 0 ->
668 left
670 JS.Bool bool ->
671 if bool then JS.Prefix JS.PrefixLNot left else left
673 _ ->
674 JS.Infix JS.OpStrictNEq left right
678-- TAIL CALL
681-- TODO check if JS minifiers collapse unnecessary temporary variables
682--
683generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
684generateTailCall mode name args =
685 let
686 toTempVars (argName, arg) =
687 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
689 toRealVars (argName, _) =
690 JS.ExprStmt $
691 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
692 in
693 JS.Var (map toTempVars args)
694 : map toRealVars args
695 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
699-- DEFINITIONS
702generateDef :: Mode -> Opt.Def -> JS.Stmt
703generateDef mode def =
704 case def of
705 Opt.Def name body ->
706 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
708 Opt.TailDef name argNames body ->
709 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
712generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
713generateTailDef mode name argNames body =
714 generateFunction (map Name.fromLocal argNames) $ JsBlock $
715 [ JS.Labelled (Name.fromLocal name) $
716 JS.While (JS.Bool True) $
717 codeToStmt $ generate mode body
718 ]
722-- PATHS
725generatePath :: Mode -> Opt.Path -> JS.Expr
726generatePath mode path =
727 case path of
728 Opt.Index index subPath ->
729 JS.Access (generatePath mode subPath) (Name.fromIndex index)
731 Opt.Root name ->
732 JS.Ref (Name.fromLocal name)
734 Opt.Field field subPath ->
735 JS.Access (generatePath mode subPath) (Name.fromField mode field)
737 Opt.Unbox subPath ->
738 case mode of
739 Name.Debug _ ->
740 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
742 Name.Prod _ _ ->
743 generatePath mode subPath
747-- GENERATE IFS
750generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
751generateIf mode givenBranches givenFinal =
752 let
753 (branches, final) =
754 crushIfs givenBranches givenFinal
756 convertBranch (condition, expr) =
757 ( generateJsExpr mode condition
758 , generate mode expr
759 )
761 branchExprs = map convertBranch branches
762 finalCode = generate mode final
763 in
764 if isBlock finalCode || any (isBlock . snd) branchExprs then
765 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
766 else
767 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
770addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
771addExprIf (condition, branch) final =
772 JS.If condition (codeToExpr branch) final
775addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
776addStmtIf (condition, branch) final =
777 JS.IfStmt condition (codeToStmt branch) final
780isBlock :: Code -> Bool
781isBlock code =
782 case code of
783 JsBlock _ -> True
784 JsExpr _ -> False
787crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
788crushIfs branches final =
789 crushIfsHelp [] branches final
792crushIfsHelp
793 :: [(Opt.Expr, Opt.Expr)]
794 -> [(Opt.Expr, Opt.Expr)]
795 -> Opt.Expr
796 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
797crushIfsHelp visitedBranches unvisitedBranches final =
798 case unvisitedBranches of
799 [] ->
800 case final of
801 Opt.If subBranches subFinal ->
802 crushIfsHelp visitedBranches subBranches subFinal
804 _ ->
805 (reverse visitedBranches, final)
807 visiting : unvisited ->
808 crushIfsHelp (visiting : visitedBranches) unvisited final
812-- CASE EXPRESSIONS
815generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
816generateCase mode label root decider jumps =
817 foldr (goto mode label) (generateDecider mode label root decider) jumps
820goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
821goto mode label (index, branch) stmts =
822 let
823 labeledDeciderStmt =
824 JS.Labelled
825 (Name.makeLabel label index)
826 (JS.While (JS.Bool True) (JS.Block stmts))
827 in
828 labeledDeciderStmt : codeToStmtList (generate mode branch)
831generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
832generateDecider mode label root decisionTree =
833 case decisionTree of
834 Opt.Leaf (Opt.Inline branch) ->
835 codeToStmtList (generate mode branch)
837 Opt.Leaf (Opt.Jump index) ->
838 [ JS.Break (Just (Name.makeLabel label index)) ]
840 Opt.Chain testChain success failure ->
841 [ JS.IfStmt
842 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
843 (JS.Block $ generateDecider mode label root success)
844 (JS.Block $ generateDecider mode label root failure)
845 ]
847 Opt.FanOut path edges fallback ->
848 [ JS.Switch
849 (generateCaseTest mode root path (fst (head edges)))
850 ( foldr
851 (\edge cases -> generateCaseBranch mode label root edge : cases)
852 [ JS.Default (generateDecider mode label root fallback) ]
853 edges
854 )
855 ]
858generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
859generateIfTest mode root (path, test) =
860 let
861 value = pathToJsExpr mode root path
862 in
863 case test of
864 DT.IsCtor name index _ _ ->
865 strictEq (JS.Access value Name.dollar) $
866 case mode of
867 Name.Debug _ -> JS.String (N.toBuilder name)
868 Name.Prod _ _ -> JS.Int (Index.toMachine index)
870 DT.IsInt int ->
871 strictEq value (JS.Int int)
873 DT.IsChr char ->
874 strictEq (JS.String (Text.encodeUtf8Builder char)) $
875 case mode of
876 Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
877 Name.Prod _ _ -> value
879 DT.IsStr string ->
880 strictEq value (JS.String (Text.encodeUtf8Builder string))
882 DT.IsCons ->
883 JS.Access value (Name.fromLocal "b")
885 DT.IsNil ->
886 JS.Prefix JS.PrefixLNot $
887 JS.Access value (Name.fromLocal "b")
889 DT.IsTuple ->
890 error "COMPILER BUG - there should never be tests on a tuple"
894generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
895generateCaseBranch mode label root (test, subTree) =
896 JS.Case
897 (generateCaseValue mode test)
898 (generateDecider mode label root subTree)
901generateCaseValue :: Mode -> DT.Test -> JS.Expr
902generateCaseValue mode test =
903 case test of
904 DT.IsCtor name index _ _ ->
905 case mode of
906 Name.Debug _ -> JS.String (N.toBuilder name)
907 Name.Prod _ _ -> JS.Int (Index.toMachine index)
909 DT.IsInt int ->
910 JS.Int int
912 DT.IsChr char ->
913 JS.String (Text.encodeUtf8Builder char)
915 DT.IsStr string ->
916 JS.String (Text.encodeUtf8Builder string)
918 DT.IsCons ->
919 error "COMPILER BUG - there should never be three tests on a list"
921 DT.IsNil ->
922 error "COMPILER BUG - there should never be three tests on a list"
924 DT.IsTuple ->
925 error "COMPILER BUG - there should never be three tests on a tuple"
928generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
929generateCaseTest mode root path exampleTest =
930 let
931 value = pathToJsExpr mode root path
932 in
933 case exampleTest of
934 DT.IsCtor _ _ _ opts ->
935 case mode of
936 Name.Debug _ ->
937 JS.Access value Name.dollar
939 Name.Prod _ _ ->
940 case opts of
941 Can.Normal ->
942 JS.Access value Name.dollar
944 Can.Enum ->
945 value
947 Can.Unbox ->
948 value
950 DT.IsInt _ ->
951 value
953 DT.IsStr _ ->
954 value
956 DT.IsChr _ ->
957 case mode of
958 Name.Debug _ ->
959 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
961 Name.Prod _ _ ->
962 value
964 DT.IsCons ->
965 error "COMPILER BUG - there should never be three tests on a list"
967 DT.IsNil ->
968 error "COMPILER BUG - there should never be three tests on a list"
970 DT.IsTuple ->
971 error "COMPILER BUG - there should never be three tests on a list"
975-- PATTERN PATHS
978pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
979pathToJsExpr mode root path =
980 case path of
981 DT.Index index subPath ->
982 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
984 DT.Unbox subPath ->
985 case mode of
986 Name.Debug _ ->
987 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
989 Name.Prod _ _ ->
990 pathToJsExpr mode root subPath
992 DT.Empty ->
993 JS.Ref (Name.fromLocal root)
997-- GENERATE MAIN
1000generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1001generateMain mode interfaces home main =
1002 case main of
1003 Opt.Static ->
1004 JS.Ref (Name.fromKernel N.browser "staticPage")
1005 # JS.Ref (Name.fromGlobal home "main")
1006 # JS.Int 0
1007 # JS.Int 0
1009 Opt.Dynamic msgType decoder ->
1010 JS.Ref (Name.fromGlobal home "main")
1011 # generateJsExpr mode decoder
1012 # toDebugMetadata mode interfaces msgType
1015(#) :: JS.Expr -> JS.Expr -> JS.Expr
1016(#) func arg =
1017 JS.Call func [arg]
1020toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1021toDebugMetadata mode interfaces msgType =
1022 case mode of
1023 Name.Prod _ _ ->
1024 JS.Int 0
1026 Name.Debug _ ->
1027 JS.Json $ Encode.object $
1028 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1029 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))