git.iko.soy/elk
on 82b3bd0 help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1068 lines 28 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.Name as Name
20import qualified Data.Set as Set
21import qualified Data.Utf8 as Utf8
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
25import qualified Data.Index as Index
26import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type.Extract as Extract
28import qualified Elm.Version as V
29import qualified Elm.ModuleName as ModuleName
30import qualified Elm.Package as Pkg
31import qualified Generate.JavaScript.Builder as JS
32import qualified Generate.JavaScript.Name as JsName
33import qualified Generate.Mode as Mode
34import qualified Json.Encode as Encode
35import qualified Optimize.DecisionTree as DT
36import qualified Reporting.Annotation as A
40-- EXPRESSIONS
43generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
44generateJsExpr mode expression =
45 codeToExpr (generate mode expression)
48generate :: Mode.Mode -> Opt.Expr -> Code
49generate mode expression =
50 case expression of
51 Opt.Bool bool ->
52 JsExpr $ JS.Bool bool
54 Opt.Chr char ->
55 JsExpr $
56 case mode of
57 Mode.Dev _ ->
58 JS.Call toChar [ JS.String (Utf8.toBuilder char) ]
60 Mode.Prod _ ->
61 JS.String (Utf8.toBuilder char)
63 Opt.Str string ->
64 JsExpr $ JS.String (Utf8.toBuilder string)
66 Opt.Int int ->
67 JsExpr $ JS.Int int
69 Opt.Float float ->
70 JsExpr $ JS.Float (Utf8.toBuilder float)
72 Opt.VarLocal name ->
73 JsExpr $ JS.Ref (JsName.fromLocal name)
75 Opt.VarGlobal (Opt.Global home name) ->
76 JsExpr $ JS.Ref (JsName.fromGlobal home name)
78 Opt.VarEnum (Opt.Global home name) index ->
79 case mode of
80 Mode.Dev _ ->
81 JsExpr $ JS.Ref (JsName.fromGlobal home name)
83 Mode.Prod _ ->
84 JsExpr $ JS.Int (Index.toMachine index)
86 Opt.VarBox (Opt.Global home name) ->
87 JsExpr $ JS.Ref $
88 case mode of
89 Mode.Dev _ -> JsName.fromGlobal home name
90 Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity
92 Opt.VarCycle home name ->
93 JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) []
95 Opt.VarDebug name home region unhandledValueName ->
96 JsExpr $ generateDebug name home region unhandledValueName
98 Opt.VarKernel home name ->
99 JsExpr $ JS.Ref (JsName.fromKernel home name)
101 Opt.List entries ->
102 case entries of
103 [] ->
104 JsExpr $ JS.Ref (JsName.fromKernel Name.list "Nil")
106 _ ->
107 JsExpr $
108 JS.Call
109 (JS.Ref (JsName.fromKernel Name.list "fromArray"))
110 [ JS.Array $ map (generateJsExpr mode) entries
111 ]
113 Opt.Function args body ->
114 generateFunction (map JsName.fromLocal args) (generate mode body)
116 Opt.Call func args ->
117 JsExpr $ generateCall mode func args
119 Opt.TailCall name args ->
120 JsBlock $ generateTailCall mode name args
122 Opt.If branches final ->
123 generateIf mode branches final
125 Opt.Let def body ->
126 JsBlock $
127 generateDef mode def : codeToStmtList (generate mode body)
129 Opt.Destruct (Opt.Destructor name path) body ->
130 let
131 pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
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 [JsName.dollar]
140 [ JS.Return $
141 JS.Access (JS.Ref JsName.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 (JsName.fromKernel Name.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 (JsName.fromKernel Name.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 (JsName.fromKernel Name.utils "Tuple2"))
170 [ generateJsExpr mode a
171 , generateJsExpr mode b
172 ]
174 Just c ->
175 JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3"))
176 [ generateJsExpr mode a
177 , generateJsExpr mode b
178 , generateJsExpr mode c
179 ]
181 Opt.Shader src attributes uniforms ->
182 let
183 toTranlation field =
184 ( JsName.fromLocal field
185 , JS.String (JsName.toBuilder (generateField mode field))
186 )
188 toTranslationObject fields =
189 JS.Object (map toTranlation (Set.toList fields))
190 in
191 JsExpr $ JS.Object $
192 [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
193 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
194 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
195 ]
199-- CODE CHUNKS
202data Code
203 = JsExpr JS.Expr
204 | JsBlock [JS.Stmt]
207codeToExpr :: Code -> JS.Expr
208codeToExpr code =
209 case code of
210 JsExpr expr ->
211 expr
213 JsBlock [ JS.Return expr ] ->
214 expr
216 JsBlock stmts ->
217 JS.Call (JS.Function Nothing [] stmts) []
220codeToStmtList :: Code -> [JS.Stmt]
221codeToStmtList code =
222 case code of
223 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
224 stmts
226 JsExpr expr ->
227 [ JS.Return expr ]
229 JsBlock stmts ->
230 stmts
233codeToStmt :: Code -> JS.Stmt
234codeToStmt code =
235 case code of
236 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
237 JS.Block stmts
239 JsExpr expr ->
240 JS.Return expr
242 JsBlock [stmt] ->
243 stmt
245 JsBlock stmts ->
246 JS.Block stmts
250-- CHARS
253{-# NOINLINE toChar #-}
254toChar :: JS.Expr
255toChar =
256 JS.Ref (JsName.fromKernel Name.utils "chr")
260-- CTOR
263generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
264generateCtor mode (Opt.Global home name) index arity =
265 let
266 argNames =
267 Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]
269 ctorTag =
270 case mode of
271 Mode.Dev _ -> JS.String (Name.toBuilder name)
272 Mode.Prod _ -> JS.Int (ctorToInt home name index)
273 in
274 generateFunction argNames $ JsExpr $ JS.Object $
275 (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
278ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int
279ctorToInt home name index =
280 if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
281 0 - Index.toHuman index
282 else
283 Index.toMachine index
287-- RECORDS
290generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr
291generateRecord mode fields =
292 let
293 toPair (field, value) =
294 (generateField mode field, generateJsExpr mode value)
295 in
296 JS.Object (map toPair (Map.toList fields))
299generateField :: Mode.Mode -> Name.Name -> JsName.Name
300generateField mode name =
301 case mode of
302 Mode.Dev _ ->
303 JsName.fromLocal name
305 Mode.Prod fields ->
306 fields ! name
311-- DEBUG
314generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr
315generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
316 if name /= "todo" then
317 JS.Ref (JsName.fromGlobal ModuleName.debug name)
318 else
319 case unhandledValueName of
320 Nothing ->
321 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $
322 [ JS.String (Name.toBuilder home)
323 , regionToJsExpr region
324 ]
326 Just valueName ->
327 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $
328 [ JS.String (Name.toBuilder home)
329 , regionToJsExpr region
330 , JS.Ref (JsName.fromLocal valueName)
331 ]
334regionToJsExpr :: A.Region -> JS.Expr
335regionToJsExpr (A.Region start end) =
336 JS.Object
337 [ ( JsName.fromLocal "start", positionToJsExpr start )
338 , ( JsName.fromLocal "end", positionToJsExpr end )
339 ]
342positionToJsExpr :: A.Position -> JS.Expr
343positionToJsExpr (A.Position line column) =
344 JS.Object
345 [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) )
346 , ( JsName.fromLocal "column", JS.Int (fromIntegral column) )
347 ]
351-- FUNCTION
354generateFunction :: [JsName.Name] -> Code -> Code
355generateFunction args body =
356 case IntMap.lookup (length args) funcHelpers of
357 Just helper ->
358 JsExpr $
359 JS.Call helper
360 [ JS.Function Nothing args $
361 codeToStmtList body
362 ]
364 Nothing ->
365 let
366 addArg arg code =
367 JsExpr $ JS.Function Nothing [arg] $
368 codeToStmtList code
369 in
370 foldr addArg body args
373{-# NOINLINE funcHelpers #-}
374funcHelpers :: IntMap.IntMap JS.Expr
375funcHelpers =
376 IntMap.fromList $
377 map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9]
381-- CALLS
384generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
385generateCall mode func args =
386 case func of
387 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
388 generateCoreCall mode global args
390 Opt.VarBox _ ->
391 case mode of
392 Mode.Dev _ ->
393 generateCallHelp mode func args
395 Mode.Prod _ ->
396 case args of
397 [arg] ->
398 generateJsExpr mode arg
400 _ ->
401 generateCallHelp mode func args
403 _ ->
404 generateCallHelp mode func args
407generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
408generateCallHelp mode func args =
409 generateNormalCall
410 (generateJsExpr mode func)
411 (map (generateJsExpr mode) args)
414generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
415generateGlobalCall home name args =
416 generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args
419generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
420generateNormalCall func args =
421 case IntMap.lookup (length args) callHelpers of
422 Just helper ->
423 JS.Call helper (func:args)
425 Nothing ->
426 List.foldl' (\f a -> JS.Call f [a]) func args
429{-# NOINLINE callHelpers #-}
430callHelpers :: IntMap.IntMap JS.Expr
431callHelpers =
432 IntMap.fromList $
433 map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9]
437-- CORE CALLS
440generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
441generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
442 if moduleName == Name.basics then
443 generateBasicsCall mode home name args
445 else if moduleName == Name.bitwise then
446 generateBitwiseCall home name (map (generateJsExpr mode) args)
448 else if moduleName == Name.tuple then
449 generateTupleCall home name (map (generateJsExpr mode) args)
451 else if moduleName == Name.jsArray then
452 generateJsArrayCall home name (map (generateJsExpr mode) args)
454 else
455 generateGlobalCall home name (map (generateJsExpr mode) args)
458generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
459generateTupleCall home name args =
460 case args of
461 [value] ->
462 case name of
463 "first" -> JS.Access value (JsName.fromLocal "a")
464 "second" -> JS.Access value (JsName.fromLocal "b")
465 _ -> generateGlobalCall home name args
467 _ ->
468 generateGlobalCall home name args
471generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
472generateJsArrayCall home name args =
473 case args of
474 [entry] | name == "singleton" -> JS.Array [entry]
475 [index, array] | name == "unsafeGet" -> JS.Index array index
476 _ -> generateGlobalCall home name args
479generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
480generateBitwiseCall home name args =
481 case args of
482 [arg] ->
483 case name of
484 "complement" -> JS.Prefix JS.PrefixComplement arg
485 _ -> generateGlobalCall home name args
487 [left,right] ->
488 case name of
489 "and" -> JS.Infix JS.OpBitwiseAnd left right
490 "or" -> JS.Infix JS.OpBitwiseOr left right
491 "xor" -> JS.Infix JS.OpBitwiseXor left right
492 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
493 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
494 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
495 _ -> generateGlobalCall home name args
497 _ ->
498 generateGlobalCall home name args
501generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr
502generateBasicsCall mode home name args =
503 case args of
504 [elmArg] ->
505 let arg = generateJsExpr mode elmArg in
506 case name of
507 "not" -> JS.Prefix JS.PrefixNot arg
508 "negate" -> JS.Prefix JS.PrefixNegate arg
509 "toFloat" -> arg
510 "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
511 _ -> generateGlobalCall home name [arg]
513 [elmLeft, elmRight] ->
514 case name of
515 -- NOTE: removed "composeL" and "composeR" because of this issue:
516 -- https://github.com/elm/compiler/issues/1722
517 "append" -> append mode elmLeft elmRight
518 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
519 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
520 _ ->
521 let
522 left = generateJsExpr mode elmLeft
523 right = generateJsExpr mode elmRight
524 in
525 case name of
526 "add" -> JS.Infix JS.OpAdd left right
527 "sub" -> JS.Infix JS.OpSub left right
528 "mul" -> JS.Infix JS.OpMul left right
529 "fdiv" -> JS.Infix JS.OpDiv left right
530 "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
531 "eq" -> equal left right
532 "neq" -> notEqual left right
533 "lt" -> cmp JS.OpLt JS.OpLt 0 left right
534 "gt" -> cmp JS.OpGt JS.OpGt 0 left right
535 "le" -> cmp JS.OpLe JS.OpLt 1 left right
536 "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
537 "or" -> JS.Infix JS.OpOr left right
538 "and" -> JS.Infix JS.OpAnd left right
539 "xor" -> JS.Infix JS.OpNe left right
540 "remainderBy" -> JS.Infix JS.OpMod right left
541 _ -> generateGlobalCall home name [left, right]
543 _ ->
544 generateGlobalCall home name (map (generateJsExpr mode) args)
547equal :: JS.Expr -> JS.Expr -> JS.Expr
548equal left right =
549 if isLiteral left || isLiteral right then
550 strictEq left right
551 else
552 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
555notEqual :: JS.Expr -> JS.Expr -> JS.Expr
556notEqual left right =
557 if isLiteral left || isLiteral right then
558 strictNEq left right
559 else
560 JS.Prefix JS.PrefixNot $
561 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
564cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
565cmp idealOp backupOp backupInt left right =
566 if isLiteral left || isLiteral right then
567 JS.Infix idealOp left right
568 else
569 JS.Infix backupOp
570 (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right])
571 (JS.Int backupInt)
574isLiteral :: JS.Expr -> Bool
575isLiteral expr =
576 case expr of
577 JS.String _ ->
578 True
580 JS.Float _ ->
581 True
583 JS.Int _ ->
584 True
586 JS.Bool _ ->
587 True
589 _ ->
590 False
593apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
594apply func value =
595 case func of
596 Opt.Accessor field ->
597 Opt.Access value field
599 Opt.Call f args ->
600 Opt.Call f (args ++ [value])
602 _ ->
603 Opt.Call func [value]
606append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
607append mode left right =
608 let seqs = generateJsExpr mode left : toSeqs mode right in
609 if any isStringLiteral seqs then
610 foldr1 (JS.Infix JS.OpAdd) seqs
611 else
612 foldr1 jsAppend seqs
615jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
616jsAppend a b =
617 JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b]
620toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
621toSeqs mode expr =
622 case expr of
623 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
624 | home == ModuleName.basics ->
625 generateJsExpr mode left : toSeqs mode right
627 _ ->
628 [generateJsExpr mode expr]
631isStringLiteral :: JS.Expr -> Bool
632isStringLiteral expr =
633 case expr of
634 JS.String _ ->
635 True
637 _ ->
638 False
642-- SIMPLIFY INFIX OPERATORS
645strictEq :: JS.Expr -> JS.Expr -> JS.Expr
646strictEq left right =
647 case left of
648 JS.Int 0 ->
649 JS.Prefix JS.PrefixNot right
651 JS.Bool bool ->
652 if bool then right else JS.Prefix JS.PrefixNot right
654 _ ->
655 case right of
656 JS.Int 0 ->
657 JS.Prefix JS.PrefixNot left
659 JS.Bool bool ->
660 if bool then left else JS.Prefix JS.PrefixNot left
662 _ ->
663 JS.Infix JS.OpEq left right
666strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
667strictNEq left right =
668 case left of
669 JS.Int 0 ->
670 JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
672 JS.Bool bool ->
673 if bool then JS.Prefix JS.PrefixNot right else right
675 _ ->
676 case right of
677 JS.Int 0 ->
678 JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
680 JS.Bool bool ->
681 if bool then JS.Prefix JS.PrefixNot left else left
683 _ ->
684 JS.Infix JS.OpNe left right
688-- TAIL CALL
691-- TODO check if JS minifiers collapse unnecessary temporary variables
692--
693generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt]
694generateTailCall mode name args =
695 let
696 toTempVars (argName, arg) =
697 ( JsName.makeTemp argName, generateJsExpr mode arg )
699 toRealVars (argName, _) =
700 JS.ExprStmt $
701 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
702 in
703 JS.Vars (map toTempVars args)
704 : map toRealVars args
705 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
709-- DEFINITIONS
712generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
713generateDef mode def =
714 case def of
715 Opt.Def name body ->
716 JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
718 Opt.TailDef name argNames body ->
719 JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
722generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
723generateTailDef mode name argNames body =
724 generateFunction (map JsName.fromLocal argNames) $ JsBlock $
725 [ JS.Labelled (JsName.fromLocal name) $
726 JS.While (JS.Bool True) $
727 codeToStmt $ generate mode body
728 ]
732-- PATHS
735generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
736generatePath mode path =
737 case path of
738 Opt.Index index subPath ->
739 JS.Access (generatePath mode subPath) (JsName.fromIndex index)
741 Opt.Root name ->
742 JS.Ref (JsName.fromLocal name)
744 Opt.Field field subPath ->
745 JS.Access (generatePath mode subPath) (generateField mode field)
747 Opt.Unbox subPath ->
748 case mode of
749 Mode.Dev _ ->
750 JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first)
752 Mode.Prod _ ->
753 generatePath mode subPath
757-- GENERATE IFS
760generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
761generateIf mode givenBranches givenFinal =
762 let
763 (branches, final) =
764 crushIfs givenBranches givenFinal
766 convertBranch (condition, expr) =
767 ( generateJsExpr mode condition
768 , generate mode expr
769 )
771 branchExprs = map convertBranch branches
772 finalCode = generate mode final
773 in
774 if isBlock finalCode || any (isBlock . snd) branchExprs then
775 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
776 else
777 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
780addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
781addExprIf (condition, branch) final =
782 JS.If condition (codeToExpr branch) final
785addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
786addStmtIf (condition, branch) final =
787 JS.IfStmt condition (codeToStmt branch) final
790isBlock :: Code -> Bool
791isBlock code =
792 case code of
793 JsBlock _ -> True
794 JsExpr _ -> False
797crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
798crushIfs branches final =
799 crushIfsHelp [] branches final
802crushIfsHelp
803 :: [(Opt.Expr, Opt.Expr)]
804 -> [(Opt.Expr, Opt.Expr)]
805 -> Opt.Expr
806 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
807crushIfsHelp visitedBranches unvisitedBranches final =
808 case unvisitedBranches of
809 [] ->
810 case final of
811 Opt.If subBranches subFinal ->
812 crushIfsHelp visitedBranches subBranches subFinal
814 _ ->
815 (reverse visitedBranches, final)
817 visiting : unvisited ->
818 crushIfsHelp (visiting : visitedBranches) unvisited final
822-- CASE EXPRESSIONS
825generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
826generateCase mode label root decider jumps =
827 foldr (goto mode label) (generateDecider mode label root decider) jumps
830goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
831goto mode label (index, branch) stmts =
832 let
833 labeledDeciderStmt =
834 JS.Labelled
835 (JsName.makeLabel label index)
836 (JS.While (JS.Bool True) (JS.Block stmts))
837 in
838 labeledDeciderStmt : codeToStmtList (generate mode branch)
841generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
842generateDecider mode label root decisionTree =
843 case decisionTree of
844 Opt.Leaf (Opt.Inline branch) ->
845 codeToStmtList (generate mode branch)
847 Opt.Leaf (Opt.Jump index) ->
848 [ JS.Break (Just (JsName.makeLabel label index)) ]
850 Opt.Chain testChain success failure ->
851 [ JS.IfStmt
852 (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
853 (JS.Block $ generateDecider mode label root success)
854 (JS.Block $ generateDecider mode label root failure)
855 ]
857 Opt.FanOut path edges fallback ->
858 [ JS.Switch
859 (generateCaseTest mode root path (fst (head edges)))
860 ( foldr
861 (\edge cases -> generateCaseBranch mode label root edge : cases)
862 [ JS.Default (generateDecider mode label root fallback) ]
863 edges
864 )
865 ]
868generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr
869generateIfTest mode root (path, test) =
870 let
871 value = pathToJsExpr mode root path
872 in
873 case test of
874 DT.IsCtor home name index _ opts ->
875 let
876 tag =
877 case mode of
878 Mode.Dev _ -> JS.Access value JsName.dollar
879 Mode.Prod _ ->
880 case opts of
881 Can.Normal -> JS.Access value JsName.dollar
882 Can.Enum -> value
883 Can.Unbox -> value
884 in
885 strictEq tag $
886 case mode of
887 Mode.Dev _ -> JS.String (Name.toBuilder name)
888 Mode.Prod _ -> JS.Int (ctorToInt home name index)
890 DT.IsBool True ->
891 value
893 DT.IsBool False ->
894 JS.Prefix JS.PrefixNot value
896 DT.IsInt int ->
897 strictEq value (JS.Int int)
899 DT.IsChr char ->
900 strictEq (JS.String (Utf8.toBuilder char)) $
901 case mode of
902 Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
903 Mode.Prod _ -> value
905 DT.IsStr string ->
906 strictEq value (JS.String (Utf8.toBuilder string))
908 DT.IsCons ->
909 JS.Access value (JsName.fromLocal "b")
911 DT.IsNil ->
912 JS.Prefix JS.PrefixNot $
913 JS.Access value (JsName.fromLocal "b")
915 DT.IsTuple ->
916 error "COMPILER BUG - there should never be tests on a tuple"
920generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
921generateCaseBranch mode label root (test, subTree) =
922 JS.Case
923 (generateCaseValue mode test)
924 (generateDecider mode label root subTree)
927generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
928generateCaseValue mode test =
929 case test of
930 DT.IsCtor home name index _ _ ->
931 case mode of
932 Mode.Dev _ -> JS.String (Name.toBuilder name)
933 Mode.Prod _ -> JS.Int (ctorToInt home name index)
935 DT.IsInt int ->
936 JS.Int int
938 DT.IsChr char ->
939 JS.String (Utf8.toBuilder char)
941 DT.IsStr string ->
942 JS.String (Utf8.toBuilder string)
944 DT.IsBool _ ->
945 error "COMPILER BUG - there should never be three tests on a boolean"
947 DT.IsCons ->
948 error "COMPILER BUG - there should never be three tests on a list"
950 DT.IsNil ->
951 error "COMPILER BUG - there should never be three tests on a list"
953 DT.IsTuple ->
954 error "COMPILER BUG - there should never be three tests on a tuple"
957generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr
958generateCaseTest mode root path exampleTest =
959 let
960 value = pathToJsExpr mode root path
961 in
962 case exampleTest of
963 DT.IsCtor home name _ _ opts ->
964 if name == Name.bool && home == ModuleName.basics then
965 value
966 else
967 case mode of
968 Mode.Dev _ ->
969 JS.Access value JsName.dollar
971 Mode.Prod _ ->
972 case opts of
973 Can.Normal ->
974 JS.Access value JsName.dollar
976 Can.Enum ->
977 value
979 Can.Unbox ->
980 value
982 DT.IsInt _ ->
983 value
985 DT.IsStr _ ->
986 value
988 DT.IsChr _ ->
989 case mode of
990 Mode.Dev _ ->
991 JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
993 Mode.Prod _ ->
994 value
996 DT.IsBool _ ->
997 error "COMPILER BUG - there should never be three tests on a list"
999 DT.IsCons ->
1000 error "COMPILER BUG - there should never be three tests on a list"
1002 DT.IsNil ->
1003 error "COMPILER BUG - there should never be three tests on a list"
1005 DT.IsTuple ->
1006 error "COMPILER BUG - there should never be three tests on a list"
1010-- PATTERN PATHS
1013pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr
1014pathToJsExpr mode root path =
1015 case path of
1016 DT.Index index subPath ->
1017 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index)
1019 DT.Unbox subPath ->
1020 case mode of
1021 Mode.Dev _ ->
1022 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first)
1024 Mode.Prod _ ->
1025 pathToJsExpr mode root subPath
1027 DT.Empty ->
1028 JS.Ref (JsName.fromLocal root)
1032-- GENERATE MAIN
1035generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1036generateMain mode home main =
1037 case main of
1038 Opt.Static ->
1039 JS.Ref (JsName.fromKernel Name.virtualDom "init")
1040 # JS.Ref (JsName.fromGlobal home "main")
1041 # JS.Int 0
1042 # JS.Int 0
1044 Opt.Dynamic msgType decoder ->
1045 JS.Ref (JsName.fromGlobal home "main")
1046 # generateJsExpr mode decoder
1047 # toDebugMetadata mode msgType
1050(#) :: JS.Expr -> JS.Expr -> JS.Expr
1051(#) func arg =
1052 JS.Call func [arg]
1055toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1056toDebugMetadata mode msgType =
1057 case mode of
1058 Mode.Prod _ ->
1059 JS.Int 0
1061 Mode.Dev Nothing ->
1062 JS.Int 0
1064 Mode.Dev (Just interfaces) ->
1065 JS.Json $ Encode.object $
1066 [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1067 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))