git.iko.soy/elk
on 904fc5a help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1056 lines 27 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateField
6 , generateTailDef
7 , generateMain
8 , Code
9 , codeToExpr
10 , codeToStmtList
11 )
12 where
15import qualified Data.IntMap as IntMap
16import qualified Data.List as List
17import Data.Map ((!))
18import qualified Data.Map as Map
19import qualified Data.Text.Encoding as Text
21import qualified AST.Canonical as Can
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Index as Index
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Name as N
28import qualified Elm.Package as Pkg
29import qualified Elm.Compiler.Version as Version
30import qualified Generate.JavaScript.Builder as JS
31import qualified Generate.JavaScript.Mode as Mode
32import qualified Generate.JavaScript.Name as Name
33import qualified Json.Encode as Encode
34import qualified Optimize.DecisionTree as DT
35import qualified Reporting.Region as R
39-- EXPRESSIONS
42generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
43generateJsExpr mode expression =
44 codeToExpr (generate mode expression)
47generate :: Mode.Mode -> Opt.Expr -> Code
48generate mode expression =
49 case expression of
50 Opt.Bool bool ->
51 JsExpr $ JS.Bool bool
53 Opt.Chr char ->
54 JsExpr $
55 case mode of
56 Mode.Dev _ _ ->
57 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
59 Mode.Prod _ _ ->
60 JS.String (Text.encodeUtf8Builder char)
62 Opt.Str string ->
63 JsExpr $ JS.String (Text.encodeUtf8Builder string)
65 Opt.Int int ->
66 JsExpr $ JS.Int int
68 Opt.Float float ->
69 JsExpr $ JS.Float float
71 Opt.VarLocal name ->
72 JsExpr $ JS.Ref (Name.fromLocal name)
74 Opt.VarGlobal (Opt.Global home name) ->
75 JsExpr $ JS.Ref (Name.fromGlobal home name)
77 Opt.VarEnum (Opt.Global home name) index ->
78 case mode of
79 Mode.Dev _ _ ->
80 JsExpr $ JS.Ref (Name.fromGlobal home name)
82 Mode.Prod _ _ ->
83 JsExpr $ JS.Int (Index.toMachine index)
85 Opt.VarBox (Opt.Global home name) ->
86 JsExpr $ JS.Ref $
87 case mode of
88 Mode.Dev _ _ -> Name.fromGlobal home name
89 Mode.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
91 Opt.VarCycle home name ->
92 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
94 Opt.VarDebug name home region unhandledValueName ->
95 JsExpr $ generateDebug name home region unhandledValueName
97 Opt.VarKernel home name ->
98 JsExpr $ JS.Ref (Name.fromKernel home name)
100 Opt.List entries ->
101 case entries of
102 [] ->
103 JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")
105 _ ->
106 JsExpr $
107 JS.Call
108 (JS.Ref (Name.fromKernel N.list "fromArray"))
109 [ JS.Array $ map (generateJsExpr mode) entries
110 ]
112 Opt.Function args body ->
113 generateFunction (map Name.fromLocal args) (generate mode body)
115 Opt.Call func args ->
116 JsExpr $ generateCall mode func args
118 Opt.TailCall name args ->
119 JsBlock $ generateTailCall mode name args
121 Opt.If branches final ->
122 generateIf mode branches final
124 Opt.Let def body ->
125 JsBlock $
126 generateDef mode def : codeToStmtList (generate mode body)
128 Opt.Destruct (Opt.Destructor name path) body ->
129 let
130 pathExpr = generatePath mode path
131 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
132 in
133 JsBlock $ pathDef : codeToStmtList (generate mode body)
135 Opt.Case label root decider jumps ->
136 JsBlock $ generateCase mode label root decider jumps
138 Opt.Accessor field ->
139 JsExpr $ JS.Function Nothing [Name.dollar]
140 [ JS.Return $ Just $
141 JS.Access (JS.Ref Name.dollar) (generateField mode field)
142 ]
144 Opt.Access record field ->
145 JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)
147 Opt.Update record fields ->
148 JsExpr $
149 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
150 [ generateJsExpr mode record
151 , generateRecord mode fields
152 ]
154 Opt.Record fields ->
155 JsExpr $ generateRecord mode fields
157 Opt.Unit ->
158 case mode of
159 Mode.Dev _ _ ->
160 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
162 Mode.Prod _ _ ->
163 JsExpr $ JS.Int 0
165 Opt.Tuple a b maybeC ->
166 JsExpr $
167 case maybeC of
168 Nothing ->
169 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
170 [ generateJsExpr mode a
171 , generateJsExpr mode b
172 ]
174 Just c ->
175 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
176 [ generateJsExpr mode a
177 , generateJsExpr mode b
178 , generateJsExpr mode c
179 ]
181 Opt.Shader src ->
182 let string = JS.String (Text.encodeUtf8Builder src) in
183 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
187-- CODE CHUNKS
190data Code
191 = JsExpr JS.Expr
192 | JsBlock [JS.Stmt]
195codeToExpr :: Code -> JS.Expr
196codeToExpr code =
197 case code of
198 JsExpr expr ->
199 expr
201 JsBlock [ JS.Return (Just expr) ] ->
202 expr
204 JsBlock stmts ->
205 JS.Call (JS.Function Nothing [] stmts) []
208codeToStmtList :: Code -> [JS.Stmt]
209codeToStmtList code =
210 case code of
211 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
212 stmts
214 JsExpr expr ->
215 [ JS.Return (Just expr) ]
217 JsBlock stmts ->
218 stmts
221codeToStmt :: Code -> JS.Stmt
222codeToStmt code =
223 case code of
224 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
225 JS.Block stmts
227 JsExpr expr ->
228 JS.Return (Just expr)
230 JsBlock [stmt] ->
231 stmt
233 JsBlock stmts ->
234 JS.Block stmts
238-- CHARS
241{-# NOINLINE toChar #-}
242toChar :: JS.Expr
243toChar =
244 JS.Ref (Name.fromKernel N.utils "chr")
248-- CTOR
251generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
252generateCtor mode (Opt.Global home name) index arity =
253 let
254 argNames =
255 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
257 ctorTag =
258 case mode of
259 Mode.Dev _ _ -> JS.String (N.toBuilder name)
260 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
261 in
262 generateFunction argNames $ JsExpr $ JS.Object $
263 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
266ctorToInt :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Int
267ctorToInt home name index =
268 if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
269 0 - Index.toHuman index
270 else
271 Index.toMachine index
275-- RECORDS
278generateRecord :: Mode.Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
279generateRecord mode fields =
280 let
281 toPair (field, value) =
282 (generateField mode field, generateJsExpr mode value)
283 in
284 JS.Object (map toPair (Map.toList fields))
287generateField :: Mode.Mode -> N.Name -> Name.Name
288generateField mode name =
289 case mode of
290 Mode.Dev _ _ ->
291 Name.fromLocal name
293 Mode.Prod _ fields ->
294 fields ! name
299-- DEBUG
302generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
303generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
304 if name /= "todo" then
305 JS.Ref (Name.fromGlobal ModuleName.debug name)
306 else
307 case unhandledValueName of
308 Nothing ->
309 JS.Call (JS.Ref (Name.fromKernel N.debug "todo")) $
310 [ JS.String (N.toBuilder home)
311 , regionToJsExpr region
312 ]
314 Just valueName ->
315 JS.Call (JS.Ref (Name.fromKernel N.debug "todoCase")) $
316 [ JS.String (N.toBuilder home)
317 , regionToJsExpr region
318 , JS.Ref (Name.fromLocal valueName)
319 ]
322regionToJsExpr :: R.Region -> JS.Expr
323regionToJsExpr (R.Region start end) =
324 JS.Object
325 [ ( Name.fromLocal "start", positionToJsExpr start )
326 , ( Name.fromLocal "end", positionToJsExpr end )
327 ]
330positionToJsExpr :: R.Position -> JS.Expr
331positionToJsExpr (R.Position line column) =
332 JS.Object
333 [ ( Name.fromLocal "line", JS.Int line )
334 , ( Name.fromLocal "column", JS.Int column )
335 ]
339-- FUNCTION
342generateFunction :: [Name.Name] -> Code -> Code
343generateFunction args body =
344 case IntMap.lookup (length args) funcHelpers of
345 Just helper ->
346 JsExpr $
347 JS.Call helper
348 [ JS.Function Nothing args $
349 codeToStmtList body
350 ]
352 Nothing ->
353 let
354 addArg arg code =
355 JsExpr $ JS.Function Nothing [arg] $
356 codeToStmtList code
357 in
358 foldr addArg body args
361{-# NOINLINE funcHelpers #-}
362funcHelpers :: IntMap.IntMap JS.Expr
363funcHelpers =
364 IntMap.fromList $
365 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
369-- CALLS
372generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
373generateCall mode func args =
374 case func of
375 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
376 generateCoreCall mode global args
378 Opt.VarBox _ ->
379 case mode of
380 Mode.Dev _ _ ->
381 generateCallHelp mode func args
383 Mode.Prod _ _ ->
384 case args of
385 [arg] ->
386 generateJsExpr mode arg
388 _ ->
389 generateCallHelp mode func args
391 _ ->
392 generateCallHelp mode func args
395generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
396generateCallHelp mode func args =
397 generateNormalCall
398 (generateJsExpr mode func)
399 (map (generateJsExpr mode) args)
402generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
403generateGlobalCall home name args =
404 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
407generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
408generateNormalCall func args =
409 case IntMap.lookup (length args) callHelpers of
410 Just helper ->
411 JS.Call helper (func:args)
413 Nothing ->
414 List.foldl' (\f a -> JS.Call f [a]) func args
417{-# NOINLINE callHelpers #-}
418callHelpers :: IntMap.IntMap JS.Expr
419callHelpers =
420 IntMap.fromList $
421 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
425-- CORE CALLS
428generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
429generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
430 if moduleName == N.basics then
431 generateBasicsCall mode home name args
433 else if moduleName == N.bitwise then
434 generateBitwiseCall home name (map (generateJsExpr mode) args)
436 else if moduleName == N.tuple then
437 generateTupleCall home name (map (generateJsExpr mode) args)
439 else if moduleName == N.jsArray then
440 generateJsArrayCall home name (map (generateJsExpr mode) args)
442 else
443 generateGlobalCall home name (map (generateJsExpr mode) args)
446generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
447generateTupleCall home name args =
448 case args of
449 [value] ->
450 case name of
451 "first" -> JS.Access value (Name.fromLocal "a")
452 "second" -> JS.Access value (Name.fromLocal "b")
453 _ -> generateGlobalCall home name args
455 _ ->
456 generateGlobalCall home name args
459generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
460generateJsArrayCall home name args =
461 case args of
462 [entry] | name == "singleton" -> JS.Array [entry]
463 [index, array] | name == "unsafeGet" -> JS.Index array index
464 _ -> generateGlobalCall home name args
467generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
468generateBitwiseCall home name args =
469 case args of
470 [arg] ->
471 case name of
472 "complement" -> JS.Prefix JS.PrefixBNot arg
473 _ -> generateGlobalCall home name args
475 [left,right] ->
476 case name of
477 "and" -> JS.Infix JS.OpBAnd left right
478 "or" -> JS.Infix JS.OpBOr left right
479 "xor" -> JS.Infix JS.OpBXor left right
480 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
481 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
482 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
483 _ -> generateGlobalCall home name args
485 _ ->
486 generateGlobalCall home name args
489generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
490generateBasicsCall mode home name args =
491 case args of
492 [elmArg] ->
493 let arg = generateJsExpr mode elmArg in
494 case name of
495 "not" -> JS.Prefix JS.PrefixLNot arg
496 "negate" -> JS.Prefix JS.PrefixMinus arg
497 "toFloat" -> arg
498 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
499 _ -> generateGlobalCall home name [arg]
501 [elmLeft, elmRight] ->
502 case name of
503 -- NOTE: removed "composeL" and "composeR" because of this issue:
504 -- https://github.com/elm/compiler/issues/1722
505 "append" -> append mode elmLeft elmRight
506 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
507 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
508 _ ->
509 let
510 left = generateJsExpr mode elmLeft
511 right = generateJsExpr mode elmRight
512 in
513 case name of
514 "add" -> JS.Infix JS.OpAdd left right
515 "sub" -> JS.Infix JS.OpSub left right
516 "mul" -> JS.Infix JS.OpMul left right
517 "fdiv" -> JS.Infix JS.OpDiv left right
518 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
519 "eq" -> equal left right
520 "neq" -> notEqual left right
521 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
522 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
523 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
524 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
525 "or" -> JS.Infix JS.OpLOr left right
526 "and" -> JS.Infix JS.OpLAnd left right
527 "xor" -> JS.Infix JS.OpStrictNEq left right
528 "remainderBy" -> JS.Infix JS.OpMod right left
529 _ -> generateGlobalCall home name [left, right]
531 _ ->
532 generateGlobalCall home name (map (generateJsExpr mode) args)
535equal :: JS.Expr -> JS.Expr -> JS.Expr
536equal left right =
537 if isLiteral left || isLiteral right then
538 strictEq left right
539 else
540 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
543notEqual :: JS.Expr -> JS.Expr -> JS.Expr
544notEqual left right =
545 if isLiteral left || isLiteral right then
546 strictNEq left right
547 else
548 JS.Prefix JS.PrefixLNot $
549 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
552cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
553cmp idealOp backupOp backupInt left right =
554 if isLiteral left || isLiteral right then
555 JS.Infix idealOp left right
556 else
557 JS.Infix backupOp
558 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
559 (JS.Int backupInt)
562isLiteral :: JS.Expr -> Bool
563isLiteral expr =
564 case expr of
565 JS.String _ ->
566 True
568 JS.Float _ ->
569 True
571 JS.Int _ ->
572 True
574 JS.Bool _ ->
575 True
577 _ ->
578 False
581apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
582apply func value =
583 case func of
584 Opt.Accessor field ->
585 Opt.Access value field
587 Opt.Call f args ->
588 Opt.Call f (args ++ [value])
590 _ ->
591 Opt.Call func [value]
594append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
595append mode left right =
596 let seqs = generateJsExpr mode left : toSeqs mode right in
597 if any isStringLiteral seqs then
598 foldr1 (JS.Infix JS.OpAdd) seqs
599 else
600 foldr1 jsAppend seqs
603jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
604jsAppend a b =
605 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
608toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
609toSeqs mode expr =
610 case expr of
611 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
612 | home == ModuleName.basics ->
613 generateJsExpr mode left : toSeqs mode right
615 _ ->
616 [generateJsExpr mode expr]
619isStringLiteral :: JS.Expr -> Bool
620isStringLiteral expr =
621 case expr of
622 JS.String _ ->
623 True
625 _ ->
626 False
630-- SIMPLIFY INFIX OPERATORS
633strictEq :: JS.Expr -> JS.Expr -> JS.Expr
634strictEq left right =
635 case left of
636 JS.Int 0 ->
637 JS.Prefix JS.PrefixLNot right
639 JS.Bool bool ->
640 if bool then right else JS.Prefix JS.PrefixLNot right
642 _ ->
643 case right of
644 JS.Int 0 ->
645 JS.Prefix JS.PrefixLNot left
647 JS.Bool bool ->
648 if bool then left else JS.Prefix JS.PrefixLNot left
650 _ ->
651 JS.Infix JS.OpStrictEq left right
654strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
655strictNEq left right =
656 case left of
657 JS.Int 0 ->
658 right
660 JS.Bool bool ->
661 if bool then JS.Prefix JS.PrefixLNot right else right
663 _ ->
664 case right of
665 JS.Int 0 ->
666 left
668 JS.Bool bool ->
669 if bool then JS.Prefix JS.PrefixLNot left else left
671 _ ->
672 JS.Infix JS.OpStrictNEq left right
676-- TAIL CALL
679-- TODO check if JS minifiers collapse unnecessary temporary variables
680--
681generateTailCall :: Mode.Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
682generateTailCall mode name args =
683 let
684 toTempVars (argName, arg) =
685 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
687 toRealVars (argName, _) =
688 JS.ExprStmt $
689 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
690 in
691 JS.Var (map toTempVars args)
692 : map toRealVars args
693 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
697-- DEFINITIONS
700generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
701generateDef mode def =
702 case def of
703 Opt.Def name body ->
704 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
706 Opt.TailDef name argNames body ->
707 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
710generateTailDef :: Mode.Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
711generateTailDef mode name argNames body =
712 generateFunction (map Name.fromLocal argNames) $ JsBlock $
713 [ JS.Labelled (Name.fromLocal name) $
714 JS.While (JS.Bool True) $
715 codeToStmt $ generate mode body
716 ]
720-- PATHS
723generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
724generatePath mode path =
725 case path of
726 Opt.Index index subPath ->
727 JS.Access (generatePath mode subPath) (Name.fromIndex index)
729 Opt.Root name ->
730 JS.Ref (Name.fromLocal name)
732 Opt.Field field subPath ->
733 JS.Access (generatePath mode subPath) (generateField mode field)
735 Opt.Unbox subPath ->
736 case mode of
737 Mode.Dev _ _ ->
738 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
740 Mode.Prod _ _ ->
741 generatePath mode subPath
745-- GENERATE IFS
748generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
749generateIf mode givenBranches givenFinal =
750 let
751 (branches, final) =
752 crushIfs givenBranches givenFinal
754 convertBranch (condition, expr) =
755 ( generateJsExpr mode condition
756 , generate mode expr
757 )
759 branchExprs = map convertBranch branches
760 finalCode = generate mode final
761 in
762 if isBlock finalCode || any (isBlock . snd) branchExprs then
763 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
764 else
765 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
768addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
769addExprIf (condition, branch) final =
770 JS.If condition (codeToExpr branch) final
773addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
774addStmtIf (condition, branch) final =
775 JS.IfStmt condition (codeToStmt branch) final
778isBlock :: Code -> Bool
779isBlock code =
780 case code of
781 JsBlock _ -> True
782 JsExpr _ -> False
785crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
786crushIfs branches final =
787 crushIfsHelp [] branches final
790crushIfsHelp
791 :: [(Opt.Expr, Opt.Expr)]
792 -> [(Opt.Expr, Opt.Expr)]
793 -> Opt.Expr
794 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
795crushIfsHelp visitedBranches unvisitedBranches final =
796 case unvisitedBranches of
797 [] ->
798 case final of
799 Opt.If subBranches subFinal ->
800 crushIfsHelp visitedBranches subBranches subFinal
802 _ ->
803 (reverse visitedBranches, final)
805 visiting : unvisited ->
806 crushIfsHelp (visiting : visitedBranches) unvisited final
810-- CASE EXPRESSIONS
813generateCase :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
814generateCase mode label root decider jumps =
815 foldr (goto mode label) (generateDecider mode label root decider) jumps
818goto :: Mode.Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
819goto mode label (index, branch) stmts =
820 let
821 labeledDeciderStmt =
822 JS.Labelled
823 (Name.makeLabel label index)
824 (JS.While (JS.Bool True) (JS.Block stmts))
825 in
826 labeledDeciderStmt : codeToStmtList (generate mode branch)
829generateDecider :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
830generateDecider mode label root decisionTree =
831 case decisionTree of
832 Opt.Leaf (Opt.Inline branch) ->
833 codeToStmtList (generate mode branch)
835 Opt.Leaf (Opt.Jump index) ->
836 [ JS.Break (Just (Name.makeLabel label index)) ]
838 Opt.Chain testChain success failure ->
839 [ JS.IfStmt
840 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
841 (JS.Block $ generateDecider mode label root success)
842 (JS.Block $ generateDecider mode label root failure)
843 ]
845 Opt.FanOut path edges fallback ->
846 [ JS.Switch
847 (generateCaseTest mode root path (fst (head edges)))
848 ( foldr
849 (\edge cases -> generateCaseBranch mode label root edge : cases)
850 [ JS.Default (generateDecider mode label root fallback) ]
851 edges
852 )
853 ]
856generateIfTest :: Mode.Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
857generateIfTest mode root (path, test) =
858 let
859 value = pathToJsExpr mode root path
860 in
861 case test of
862 DT.IsCtor home name index _ opts ->
863 let
864 tag =
865 case mode of
866 Mode.Dev _ _ -> JS.Access value Name.dollar
867 Mode.Prod _ _ ->
868 case opts of
869 Can.Normal -> JS.Access value Name.dollar
870 Can.Enum -> value
871 Can.Unbox -> value
872 in
873 strictEq tag $
874 case mode of
875 Mode.Dev _ _ -> JS.String (N.toBuilder name)
876 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
878 DT.IsBool True ->
879 value
881 DT.IsBool False ->
882 JS.Prefix JS.PrefixLNot value
884 DT.IsInt int ->
885 strictEq value (JS.Int int)
887 DT.IsChr char ->
888 strictEq (JS.String (Text.encodeUtf8Builder char)) $
889 case mode of
890 Mode.Dev _ _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
891 Mode.Prod _ _ -> value
893 DT.IsStr string ->
894 strictEq value (JS.String (Text.encodeUtf8Builder string))
896 DT.IsCons ->
897 JS.Access value (Name.fromLocal "b")
899 DT.IsNil ->
900 JS.Prefix JS.PrefixLNot $
901 JS.Access value (Name.fromLocal "b")
903 DT.IsTuple ->
904 error "COMPILER BUG - there should never be tests on a tuple"
908generateCaseBranch :: Mode.Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
909generateCaseBranch mode label root (test, subTree) =
910 JS.Case
911 (generateCaseValue mode test)
912 (generateDecider mode label root subTree)
915generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
916generateCaseValue mode test =
917 case test of
918 DT.IsCtor home name index _ _ ->
919 case mode of
920 Mode.Dev _ _ -> JS.String (N.toBuilder name)
921 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)
923 DT.IsInt int ->
924 JS.Int int
926 DT.IsChr char ->
927 JS.String (Text.encodeUtf8Builder char)
929 DT.IsStr string ->
930 JS.String (Text.encodeUtf8Builder string)
932 DT.IsBool _ ->
933 error "COMPILER BUG - there should never be three tests on a boolean"
935 DT.IsCons ->
936 error "COMPILER BUG - there should never be three tests on a list"
938 DT.IsNil ->
939 error "COMPILER BUG - there should never be three tests on a list"
941 DT.IsTuple ->
942 error "COMPILER BUG - there should never be three tests on a tuple"
945generateCaseTest :: Mode.Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
946generateCaseTest mode root path exampleTest =
947 let
948 value = pathToJsExpr mode root path
949 in
950 case exampleTest of
951 DT.IsCtor home name _ _ opts ->
952 if name == N.bool && home == ModuleName.basics then
953 value
954 else
955 case mode of
956 Mode.Dev _ _ ->
957 JS.Access value Name.dollar
959 Mode.Prod _ _ ->
960 case opts of
961 Can.Normal ->
962 JS.Access value Name.dollar
964 Can.Enum ->
965 value
967 Can.Unbox ->
968 value
970 DT.IsInt _ ->
971 value
973 DT.IsStr _ ->
974 value
976 DT.IsChr _ ->
977 case mode of
978 Mode.Dev _ _ ->
979 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
981 Mode.Prod _ _ ->
982 value
984 DT.IsBool _ ->
985 error "COMPILER BUG - there should never be three tests on a list"
987 DT.IsCons ->
988 error "COMPILER BUG - there should never be three tests on a list"
990 DT.IsNil ->
991 error "COMPILER BUG - there should never be three tests on a list"
993 DT.IsTuple ->
994 error "COMPILER BUG - there should never be three tests on a list"
998-- PATTERN PATHS
1001pathToJsExpr :: Mode.Mode -> N.Name -> DT.Path -> JS.Expr
1002pathToJsExpr mode root path =
1003 case path of
1004 DT.Index index subPath ->
1005 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
1007 DT.Unbox subPath ->
1008 case mode of
1009 Mode.Dev _ _ ->
1010 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
1012 Mode.Prod _ _ ->
1013 pathToJsExpr mode root subPath
1015 DT.Empty ->
1016 JS.Ref (Name.fromLocal root)
1020-- GENERATE MAIN
1023generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1024generateMain mode home main =
1025 case main of
1026 Opt.Static ->
1027 JS.Ref (Name.fromKernel N.virtualDom "init")
1028 # JS.Ref (Name.fromGlobal home "main")
1029 # JS.Int 0
1030 # JS.Int 0
1032 Opt.Dynamic msgType decoder ->
1033 JS.Ref (Name.fromGlobal home "main")
1034 # generateJsExpr mode decoder
1035 # toDebugMetadata mode msgType
1038(#) :: JS.Expr -> JS.Expr -> JS.Expr
1039(#) func arg =
1040 JS.Call func [arg]
1043toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1044toDebugMetadata mode msgType =
1045 case mode of
1046 Mode.Prod _ _ ->
1047 JS.Int 0
1049 Mode.Dev _ Nothing ->
1050 JS.Int 0
1052 Mode.Dev _ (Just interfaces) ->
1053 JS.Json $ Encode.object $
1054 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1055 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))