git.iko.soy/elk
on a36152c help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1038 lines 27 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.Dev _ ->
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.Dev _ ->
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.Dev _ -> 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.Dev _ ->
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 (JS.Call (JS.Function Nothing [] stmts) []) ->
217 stmts
219 JsExpr expr ->
220 [ JS.Return (Just expr) ]
222 JsBlock stmts ->
223 stmts
226codeToStmt :: Code -> JS.Stmt
227codeToStmt code =
228 case code of
229 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
230 JS.Block stmts
232 JsExpr expr ->
233 JS.Return (Just expr)
235 JsBlock [stmt] ->
236 stmt
238 JsBlock stmts ->
239 JS.Block stmts
243-- CHARS
246{-# NOINLINE toChar #-}
247toChar :: JS.Expr
248toChar =
249 JS.Ref (Name.fromKernel N.utils "chr")
253-- CTOR
256generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code
257generateCtor mode name index arity =
258 let
259 argNames =
260 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
262 ctorTag =
263 case mode of
264 Name.Dev _ -> JS.String (N.toBuilder name)
265 Name.Prod _ _ -> JS.Int (Index.toMachine index)
266 in
267 generateFunction argNames $ JsExpr $ JS.Object $
268 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
272-- RECORDS
275generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
276generateRecord mode fields =
277 let
278 toPair (field, value) =
279 (Name.fromField mode field, generateJsExpr mode value)
280 in
281 JS.Object (map toPair (Map.toList fields))
285-- DEBUG
288generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
289generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
290 if name /= "todo" then
291 JS.Ref (Name.fromGlobal ModuleName.debug name)
292 else
293 case unhandledValueName of
294 Nothing ->
295 JS.Call (JS.Ref (Name.fromKernel N.debug "todo")) $
296 [ JS.String (N.toBuilder home)
297 , regionToJsExpr region
298 ]
300 Just valueName ->
301 JS.Call (JS.Ref (Name.fromKernel N.debug "todoCase")) $
302 [ JS.String (N.toBuilder home)
303 , regionToJsExpr region
304 , JS.Ref (Name.fromLocal valueName)
305 ]
308regionToJsExpr :: R.Region -> JS.Expr
309regionToJsExpr (R.Region start end) =
310 JS.Object
311 [ ( Name.fromLocal "start", positionToJsExpr start )
312 , ( Name.fromLocal "end", positionToJsExpr end )
313 ]
316positionToJsExpr :: R.Position -> JS.Expr
317positionToJsExpr (R.Position line column) =
318 JS.Object
319 [ ( Name.fromLocal "line", JS.Int line )
320 , ( Name.fromLocal "column", JS.Int column )
321 ]
325-- FUNCTION
328generateFunction :: [Name.Name] -> Code -> Code
329generateFunction args body =
330 case IntMap.lookup (length args) funcHelpers of
331 Just helper ->
332 JsExpr $
333 JS.Call helper
334 [ JS.Function Nothing args $
335 codeToStmtList body
336 ]
338 Nothing ->
339 let
340 addArg arg code =
341 JsExpr $ JS.Function Nothing [arg] $
342 codeToStmtList code
343 in
344 foldr addArg body args
347{-# NOINLINE funcHelpers #-}
348funcHelpers :: IntMap.IntMap JS.Expr
349funcHelpers =
350 IntMap.fromList $
351 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
355-- CALLS
358generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
359generateCall mode func args =
360 case func of
361 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
362 generateCoreCall mode global args
364 Opt.VarBox _ ->
365 case mode of
366 Name.Dev _ ->
367 generateCallHelp mode func args
369 Name.Prod _ _ ->
370 case args of
371 [arg] ->
372 generateJsExpr mode arg
374 _ ->
375 generateCallHelp mode func args
377 _ ->
378 generateCallHelp mode func args
381generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
382generateCallHelp mode func args =
383 generateNormalCall
384 (generateJsExpr mode func)
385 (map (generateJsExpr mode) args)
388generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
389generateGlobalCall home name args =
390 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
393generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
394generateNormalCall func args =
395 case IntMap.lookup (length args) callHelpers of
396 Just helper ->
397 JS.Call helper (func:args)
399 Nothing ->
400 List.foldl' (\f a -> JS.Call f [a]) func args
403{-# NOINLINE callHelpers #-}
404callHelpers :: IntMap.IntMap JS.Expr
405callHelpers =
406 IntMap.fromList $
407 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
411-- CORE CALLS
414generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
415generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
416 if moduleName == N.basics then
417 generateBasicsCall mode home name args
419 else if moduleName == N.bitwise then
420 generateBitwiseCall home name (map (generateJsExpr mode) args)
422 else if moduleName == N.tuple then
423 generateTupleCall home name (map (generateJsExpr mode) args)
425 else if moduleName == N.jsArray then
426 generateJsArrayCall home name (map (generateJsExpr mode) args)
428 else
429 generateGlobalCall home name (map (generateJsExpr mode) args)
432generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
433generateTupleCall home name args =
434 case args of
435 [value] ->
436 case name of
437 "first" -> JS.Access value (Name.fromLocal "a")
438 "second" -> JS.Access value (Name.fromLocal "b")
439 _ -> generateGlobalCall home name args
441 _ ->
442 generateGlobalCall home name args
445generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
446generateJsArrayCall home name args =
447 case args of
448 [entry] | name == "singleton" -> JS.Array [entry]
449 [index, array] | name == "unsafeGet" -> JS.Index array index
450 _ -> generateGlobalCall home name args
453generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
454generateBitwiseCall home name args =
455 case args of
456 [arg] ->
457 case name of
458 "complement" -> JS.Prefix JS.PrefixBNot arg
459 _ -> generateGlobalCall home name args
461 [left,right] ->
462 case name of
463 "and" -> JS.Infix JS.OpBAnd left right
464 "or" -> JS.Infix JS.OpBOr left right
465 "xor" -> JS.Infix JS.OpBXor left right
466 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
467 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
468 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
469 _ -> generateGlobalCall home name args
471 _ ->
472 generateGlobalCall home name args
475generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
476generateBasicsCall mode home name args =
477 case args of
478 [elmArg] ->
479 let arg = generateJsExpr mode elmArg in
480 case name of
481 "not" -> JS.Prefix JS.PrefixLNot arg
482 "negate" -> JS.Prefix JS.PrefixMinus arg
483 "toFloat" -> arg
484 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
485 _ -> generateGlobalCall home name [arg]
487 [elmLeft, elmRight] ->
488 case name of
489 "composeL" -> decomposeL mode elmLeft [elmRight]
490 "composeR" -> decomposeR mode [elmLeft] elmRight
491 "append" -> append mode elmLeft elmRight
492 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
493 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
494 _ ->
495 let
496 left = generateJsExpr mode elmLeft
497 right = generateJsExpr mode elmRight
498 in
499 case name of
500 "add" -> JS.Infix JS.OpAdd left right
501 "sub" -> JS.Infix JS.OpSub left right
502 "mul" -> JS.Infix JS.OpMul left right
503 "fdiv" -> JS.Infix JS.OpDiv left right
504 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
505 "eq" -> equal left right
506 "neq" -> notEqual left right
507 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
508 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
509 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
510 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
511 "or" -> JS.Infix JS.OpLOr left right
512 "and" -> JS.Infix JS.OpLAnd left right
513 "xor" -> JS.Infix JS.OpStrictNEq left right
514 "remainderBy" -> JS.Infix JS.OpMod right left
515 _ -> generateGlobalCall home name [left, right]
517 _ ->
518 generateGlobalCall home name (map (generateJsExpr mode) args)
521equal :: JS.Expr -> JS.Expr -> JS.Expr
522equal left right =
523 if isLiteral left || isLiteral right then
524 strictEq left right
525 else
526 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
529notEqual :: JS.Expr -> JS.Expr -> JS.Expr
530notEqual left right =
531 if isLiteral left || isLiteral right then
532 strictNEq left right
533 else
534 JS.Prefix JS.PrefixLNot $
535 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
538cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
539cmp idealOp backupOp backupInt left right =
540 if isLiteral left || isLiteral right then
541 JS.Infix idealOp left right
542 else
543 JS.Infix backupOp
544 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
545 (JS.Int backupInt)
548isLiteral :: JS.Expr -> Bool
549isLiteral expr =
550 case expr of
551 JS.String _ ->
552 True
554 JS.Float _ ->
555 True
557 JS.Int _ ->
558 True
560 JS.Bool _ ->
561 True
563 _ ->
564 False
567decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
568decomposeL mode expr funcs =
569 case expr of
570 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
571 | home == ModuleName.basics ->
572 decomposeL mode left (func:funcs)
574 _ ->
575 generateJsExpr mode $
576 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
579decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
580decomposeR mode funcs expr =
581 case expr of
582 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
583 | home == ModuleName.basics ->
584 decomposeR mode (func:funcs) right
586 _ ->
587 generateJsExpr mode $
588 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
591apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
592apply func value =
593 case func of
594 Opt.Accessor field ->
595 Opt.Access value field
597 Opt.Call f args ->
598 Opt.Call f (args ++ [value])
600 _ ->
601 Opt.Call func [value]
604append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
605append mode left right =
606 let seqs = generateJsExpr mode left : toSeqs mode right in
607 if any isStringLiteral seqs then
608 foldr1 (JS.Infix JS.OpAdd) seqs
609 else
610 foldr1 jsAppend seqs
613jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
614jsAppend a b =
615 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
618toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
619toSeqs mode expr =
620 case expr of
621 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
622 | home == ModuleName.basics ->
623 generateJsExpr mode left : toSeqs mode right
625 _ ->
626 [generateJsExpr mode expr]
629isStringLiteral :: JS.Expr -> Bool
630isStringLiteral expr =
631 case expr of
632 JS.String _ ->
633 True
635 _ ->
636 False
640-- SIMPLIFY INFIX OPERATORS
643strictEq :: JS.Expr -> JS.Expr -> JS.Expr
644strictEq left right =
645 case left of
646 JS.Int 0 ->
647 JS.Prefix JS.PrefixLNot right
649 JS.Bool bool ->
650 if bool then right else JS.Prefix JS.PrefixLNot right
652 _ ->
653 case right of
654 JS.Int 0 ->
655 JS.Prefix JS.PrefixLNot left
657 JS.Bool bool ->
658 if bool then left else JS.Prefix JS.PrefixLNot left
660 _ ->
661 JS.Infix JS.OpStrictEq left right
664strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
665strictNEq left right =
666 case left of
667 JS.Int 0 ->
668 right
670 JS.Bool bool ->
671 if bool then JS.Prefix JS.PrefixLNot right else right
673 _ ->
674 case right of
675 JS.Int 0 ->
676 left
678 JS.Bool bool ->
679 if bool then JS.Prefix JS.PrefixLNot left else left
681 _ ->
682 JS.Infix JS.OpStrictNEq left right
686-- TAIL CALL
689-- TODO check if JS minifiers collapse unnecessary temporary variables
690--
691generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
692generateTailCall mode name args =
693 let
694 toTempVars (argName, arg) =
695 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
697 toRealVars (argName, _) =
698 JS.ExprStmt $
699 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
700 in
701 JS.Var (map toTempVars args)
702 : map toRealVars args
703 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
707-- DEFINITIONS
710generateDef :: Mode -> Opt.Def -> JS.Stmt
711generateDef mode def =
712 case def of
713 Opt.Def name body ->
714 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
716 Opt.TailDef name argNames body ->
717 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
720generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
721generateTailDef mode name argNames body =
722 generateFunction (map Name.fromLocal argNames) $ JsBlock $
723 [ JS.Labelled (Name.fromLocal name) $
724 JS.While (JS.Bool True) $
725 codeToStmt $ generate mode body
726 ]
730-- PATHS
733generatePath :: Mode -> Opt.Path -> JS.Expr
734generatePath mode path =
735 case path of
736 Opt.Index index subPath ->
737 JS.Access (generatePath mode subPath) (Name.fromIndex index)
739 Opt.Root name ->
740 JS.Ref (Name.fromLocal name)
742 Opt.Field field subPath ->
743 JS.Access (generatePath mode subPath) (Name.fromField mode field)
745 Opt.Unbox subPath ->
746 case mode of
747 Name.Dev _ ->
748 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
750 Name.Prod _ _ ->
751 generatePath mode subPath
755-- GENERATE IFS
758generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
759generateIf mode givenBranches givenFinal =
760 let
761 (branches, final) =
762 crushIfs givenBranches givenFinal
764 convertBranch (condition, expr) =
765 ( generateJsExpr mode condition
766 , generate mode expr
767 )
769 branchExprs = map convertBranch branches
770 finalCode = generate mode final
771 in
772 if isBlock finalCode || any (isBlock . snd) branchExprs then
773 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
774 else
775 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
778addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
779addExprIf (condition, branch) final =
780 JS.If condition (codeToExpr branch) final
783addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
784addStmtIf (condition, branch) final =
785 JS.IfStmt condition (codeToStmt branch) final
788isBlock :: Code -> Bool
789isBlock code =
790 case code of
791 JsBlock _ -> True
792 JsExpr _ -> False
795crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
796crushIfs branches final =
797 crushIfsHelp [] branches final
800crushIfsHelp
801 :: [(Opt.Expr, Opt.Expr)]
802 -> [(Opt.Expr, Opt.Expr)]
803 -> Opt.Expr
804 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
805crushIfsHelp visitedBranches unvisitedBranches final =
806 case unvisitedBranches of
807 [] ->
808 case final of
809 Opt.If subBranches subFinal ->
810 crushIfsHelp visitedBranches subBranches subFinal
812 _ ->
813 (reverse visitedBranches, final)
815 visiting : unvisited ->
816 crushIfsHelp (visiting : visitedBranches) unvisited final
820-- CASE EXPRESSIONS
823generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
824generateCase mode label root decider jumps =
825 foldr (goto mode label) (generateDecider mode label root decider) jumps
828goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
829goto mode label (index, branch) stmts =
830 let
831 labeledDeciderStmt =
832 JS.Labelled
833 (Name.makeLabel label index)
834 (JS.While (JS.Bool True) (JS.Block stmts))
835 in
836 labeledDeciderStmt : codeToStmtList (generate mode branch)
839generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
840generateDecider mode label root decisionTree =
841 case decisionTree of
842 Opt.Leaf (Opt.Inline branch) ->
843 codeToStmtList (generate mode branch)
845 Opt.Leaf (Opt.Jump index) ->
846 [ JS.Break (Just (Name.makeLabel label index)) ]
848 Opt.Chain testChain success failure ->
849 [ JS.IfStmt
850 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
851 (JS.Block $ generateDecider mode label root success)
852 (JS.Block $ generateDecider mode label root failure)
853 ]
855 Opt.FanOut path edges fallback ->
856 [ JS.Switch
857 (generateCaseTest mode root path (fst (head edges)))
858 ( foldr
859 (\edge cases -> generateCaseBranch mode label root edge : cases)
860 [ JS.Default (generateDecider mode label root fallback) ]
861 edges
862 )
863 ]
866generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
867generateIfTest mode root (path, test) =
868 let
869 value = pathToJsExpr mode root path
870 in
871 case test of
872 DT.IsCtor name index _ _ ->
873 strictEq (JS.Access value Name.dollar) $
874 case mode of
875 Name.Dev _ -> JS.String (N.toBuilder name)
876 Name.Prod _ _ -> JS.Int (Index.toMachine index)
878 DT.IsInt int ->
879 strictEq value (JS.Int int)
881 DT.IsChr char ->
882 strictEq (JS.String (Text.encodeUtf8Builder char)) $
883 case mode of
884 Name.Dev _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
885 Name.Prod _ _ -> value
887 DT.IsStr string ->
888 strictEq value (JS.String (Text.encodeUtf8Builder string))
890 DT.IsCons ->
891 JS.Access value (Name.fromLocal "b")
893 DT.IsNil ->
894 JS.Prefix JS.PrefixLNot $
895 JS.Access value (Name.fromLocal "b")
897 DT.IsTuple ->
898 error "COMPILER BUG - there should never be tests on a tuple"
902generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
903generateCaseBranch mode label root (test, subTree) =
904 JS.Case
905 (generateCaseValue mode test)
906 (generateDecider mode label root subTree)
909generateCaseValue :: Mode -> DT.Test -> JS.Expr
910generateCaseValue mode test =
911 case test of
912 DT.IsCtor name index _ _ ->
913 case mode of
914 Name.Dev _ -> JS.String (N.toBuilder name)
915 Name.Prod _ _ -> JS.Int (Index.toMachine index)
917 DT.IsInt int ->
918 JS.Int int
920 DT.IsChr char ->
921 JS.String (Text.encodeUtf8Builder char)
923 DT.IsStr string ->
924 JS.String (Text.encodeUtf8Builder string)
926 DT.IsCons ->
927 error "COMPILER BUG - there should never be three tests on a list"
929 DT.IsNil ->
930 error "COMPILER BUG - there should never be three tests on a list"
932 DT.IsTuple ->
933 error "COMPILER BUG - there should never be three tests on a tuple"
936generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
937generateCaseTest mode root path exampleTest =
938 let
939 value = pathToJsExpr mode root path
940 in
941 case exampleTest of
942 DT.IsCtor _ _ _ opts ->
943 case mode of
944 Name.Dev _ ->
945 JS.Access value Name.dollar
947 Name.Prod _ _ ->
948 case opts of
949 Can.Normal ->
950 JS.Access value Name.dollar
952 Can.Enum ->
953 value
955 Can.Unbox ->
956 value
958 DT.IsInt _ ->
959 value
961 DT.IsStr _ ->
962 value
964 DT.IsChr _ ->
965 case mode of
966 Name.Dev _ ->
967 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
969 Name.Prod _ _ ->
970 value
972 DT.IsCons ->
973 error "COMPILER BUG - there should never be three tests on a list"
975 DT.IsNil ->
976 error "COMPILER BUG - there should never be three tests on a list"
978 DT.IsTuple ->
979 error "COMPILER BUG - there should never be three tests on a list"
983-- PATTERN PATHS
986pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
987pathToJsExpr mode root path =
988 case path of
989 DT.Index index subPath ->
990 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
992 DT.Unbox subPath ->
993 case mode of
994 Name.Dev _ ->
995 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
997 Name.Prod _ _ ->
998 pathToJsExpr mode root subPath
1000 DT.Empty ->
1001 JS.Ref (Name.fromLocal root)
1005-- GENERATE MAIN
1008generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1009generateMain mode interfaces home main =
1010 case main of
1011 Opt.Static ->
1012 JS.Ref (Name.fromKernel N.virtualDom "init")
1013 # JS.Ref (Name.fromGlobal home "main")
1014 # JS.Int 0
1015 # JS.Int 0
1017 Opt.Dynamic msgType decoder ->
1018 JS.Ref (Name.fromGlobal home "main")
1019 # generateJsExpr mode decoder
1020 # toDebugMetadata mode interfaces msgType
1023(#) :: JS.Expr -> JS.Expr -> JS.Expr
1024(#) func arg =
1025 JS.Call func [arg]
1028toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1029toDebugMetadata mode interfaces msgType =
1030 case mode of
1031 Name.Prod _ _ ->
1032 JS.Int 0
1034 Name.Dev _ ->
1035 JS.Json $ Encode.object $
1036 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1037 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))