git.iko.soy/elk
on cc76ccb help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1070 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 AST.Utils.Shader as Shader
26import qualified Data.Index as Index
27import qualified Elm.Compiler.Type as Type
28import qualified Elm.Compiler.Type.Extract as Extract
29import qualified Elm.Version as V
30import qualified Elm.ModuleName as ModuleName
31import qualified Elm.Package as Pkg
32import qualified Generate.JavaScript.Builder as JS
33import qualified Generate.JavaScript.Name as JsName
34import qualified Generate.Mode as Mode
35import qualified Json.Encode as Encode
36import Json.Encode ((==>))
37import qualified Optimize.DecisionTree as DT
38import qualified Reporting.Annotation as A
42-- EXPRESSIONS
45generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
46generateJsExpr mode expression =
47 codeToExpr (generate mode expression)
50generate :: Mode.Mode -> Opt.Expr -> Code
51generate mode expression =
52 case expression of
53 Opt.Bool bool ->
54 JsExpr $ JS.Bool bool
56 Opt.Chr char ->
57 JsExpr $
58 case mode of
59 Mode.Dev _ ->
60 JS.Call toChar [ JS.String (Utf8.toBuilder char) ]
62 Mode.Prod _ ->
63 JS.String (Utf8.toBuilder char)
65 Opt.Str string ->
66 JsExpr $ JS.String (Utf8.toBuilder string)
68 Opt.Int int ->
69 JsExpr $ JS.Int int
71 Opt.Float float ->
72 JsExpr $ JS.Float (Utf8.toBuilder float)
74 Opt.VarLocal name ->
75 JsExpr $ JS.Ref (JsName.fromLocal name)
77 Opt.VarGlobal (Opt.Global home name) ->
78 JsExpr $ JS.Ref (JsName.fromGlobal home name)
80 Opt.VarEnum (Opt.Global home name) index ->
81 case mode of
82 Mode.Dev _ ->
83 JsExpr $ JS.Ref (JsName.fromGlobal home name)
85 Mode.Prod _ ->
86 JsExpr $ JS.Int (Index.toMachine index)
88 Opt.VarBox (Opt.Global home name) ->
89 JsExpr $ JS.Ref $
90 case mode of
91 Mode.Dev _ -> JsName.fromGlobal home name
92 Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity
94 Opt.VarCycle home name ->
95 JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) []
97 Opt.VarDebug name home region unhandledValueName ->
98 JsExpr $ generateDebug name home region unhandledValueName
100 Opt.VarKernel home name ->
101 JsExpr $ JS.Ref (JsName.fromKernel home name)
103 Opt.List entries ->
104 case entries of
105 [] ->
106 JsExpr $ JS.Ref (JsName.fromKernel Name.list "Nil")
108 _ ->
109 JsExpr $
110 JS.Call
111 (JS.Ref (JsName.fromKernel Name.list "fromArray"))
112 [ JS.Array $ map (generateJsExpr mode) entries
113 ]
115 Opt.Function args body ->
116 generateFunction (map JsName.fromLocal args) (generate mode body)
118 Opt.Call func args ->
119 JsExpr $ generateCall mode func args
121 Opt.TailCall name args ->
122 JsBlock $ generateTailCall mode name args
124 Opt.If branches final ->
125 generateIf mode branches final
127 Opt.Let def body ->
128 JsBlock $
129 generateDef mode def : codeToStmtList (generate mode body)
131 Opt.Destruct (Opt.Destructor name path) body ->
132 let
133 pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
134 in
135 JsBlock $ pathDef : codeToStmtList (generate mode body)
137 Opt.Case label root decider jumps ->
138 JsBlock $ generateCase mode label root decider jumps
140 Opt.Accessor field ->
141 JsExpr $ JS.Function Nothing [JsName.dollar]
142 [ JS.Return $
143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
144 ]
146 Opt.Access record field ->
147 JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)
149 Opt.Update record fields ->
150 JsExpr $
151 JS.Call (JS.Ref (JsName.fromKernel Name.utils "update"))
152 [ generateJsExpr mode record
153 , generateRecord mode fields
154 ]
156 Opt.Record fields ->
157 JsExpr $ generateRecord mode fields
159 Opt.Unit ->
160 case mode of
161 Mode.Dev _ ->
162 JsExpr $ JS.Ref (JsName.fromKernel Name.utils "Tuple0")
164 Mode.Prod _ ->
165 JsExpr $ JS.Int 0
167 Opt.Tuple a b maybeC ->
168 JsExpr $
169 case maybeC of
170 Nothing ->
171 JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple2"))
172 [ generateJsExpr mode a
173 , generateJsExpr mode b
174 ]
176 Just c ->
177 JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3"))
178 [ generateJsExpr mode a
179 , generateJsExpr mode b
180 , generateJsExpr mode c
181 ]
183 Opt.Shader src attributes uniforms ->
184 let
185 toTranlation field =
186 ( JsName.fromLocal field
187 , JS.String (JsName.toBuilder (generateField mode field))
188 )
190 toTranslationObject fields =
191 JS.Object (map toTranlation (Set.toList fields))
192 in
193 JsExpr $ JS.Object $
194 [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
197 ]
201-- CODE CHUNKS
204data Code
205 = JsExpr JS.Expr
206 | JsBlock [JS.Stmt]
209codeToExpr :: Code -> JS.Expr
210codeToExpr code =
211 case code of
212 JsExpr expr ->
213 expr
215 JsBlock [ JS.Return expr ] ->
216 expr
218 JsBlock stmts ->
219 JS.Call (JS.Function Nothing [] stmts) []
222codeToStmtList :: Code -> [JS.Stmt]
223codeToStmtList code =
224 case code of
225 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
226 stmts
228 JsExpr expr ->
229 [ JS.Return expr ]
231 JsBlock stmts ->
232 stmts
235codeToStmt :: Code -> JS.Stmt
236codeToStmt code =
237 case code of
238 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
239 JS.Block stmts
241 JsExpr expr ->
242 JS.Return expr
244 JsBlock [stmt] ->
245 stmt
247 JsBlock stmts ->
248 JS.Block stmts
252-- CHARS
255{-# NOINLINE toChar #-}
256toChar :: JS.Expr
257toChar =
258 JS.Ref (JsName.fromKernel Name.utils "chr")
262-- CTOR
265generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
266generateCtor mode (Opt.Global home name) index arity =
267 let
268 argNames =
269 Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]
271 ctorTag =
272 case mode of
273 Mode.Dev _ -> JS.String (Name.toBuilder name)
274 Mode.Prod _ -> JS.Int (ctorToInt home name index)
275 in
276 generateFunction argNames $ JsExpr $ JS.Object $
277 (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
280ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int
281ctorToInt home name index =
282 if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
283 0 - Index.toHuman index
284 else
285 Index.toMachine index
289-- RECORDS
292generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr
293generateRecord mode fields =
294 let
295 toPair (field, value) =
296 (generateField mode field, generateJsExpr mode value)
297 in
298 JS.Object (map toPair (Map.toList fields))
301generateField :: Mode.Mode -> Name.Name -> JsName.Name
302generateField mode name =
303 case mode of
304 Mode.Dev _ ->
305 JsName.fromLocal name
307 Mode.Prod fields ->
308 fields ! name
313-- DEBUG
316generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr
317generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
318 if name /= "todo" then
319 JS.Ref (JsName.fromGlobal ModuleName.debug name)
320 else
321 case unhandledValueName of
322 Nothing ->
323 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $
324 [ JS.String (Name.toBuilder home)
325 , regionToJsExpr region
326 ]
328 Just valueName ->
329 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $
330 [ JS.String (Name.toBuilder home)
331 , regionToJsExpr region
332 , JS.Ref (JsName.fromLocal valueName)
333 ]
336regionToJsExpr :: A.Region -> JS.Expr
337regionToJsExpr (A.Region start end) =
338 JS.Object
339 [ ( JsName.fromLocal "start", positionToJsExpr start )
340 , ( JsName.fromLocal "end", positionToJsExpr end )
341 ]
344positionToJsExpr :: A.Position -> JS.Expr
345positionToJsExpr (A.Position line column) =
346 JS.Object
347 [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) )
348 , ( JsName.fromLocal "column", JS.Int (fromIntegral column) )
349 ]
353-- FUNCTION
356generateFunction :: [JsName.Name] -> Code -> Code
357generateFunction args body =
358 case IntMap.lookup (length args) funcHelpers of
359 Just helper ->
360 JsExpr $
361 JS.Call helper
362 [ JS.Function Nothing args $
363 codeToStmtList body
364 ]
366 Nothing ->
367 let
368 addArg arg code =
369 JsExpr $ JS.Function Nothing [arg] $
370 codeToStmtList code
371 in
372 foldr addArg body args
375{-# NOINLINE funcHelpers #-}
376funcHelpers :: IntMap.IntMap JS.Expr
377funcHelpers =
378 IntMap.fromList $
379 map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9]
383-- CALLS
386generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
387generateCall mode func args =
388 case func of
389 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
390 generateCoreCall mode global args
392 Opt.VarBox _ ->
393 case mode of
394 Mode.Dev _ ->
395 generateCallHelp mode func args
397 Mode.Prod _ ->
398 case args of
399 [arg] ->
400 generateJsExpr mode arg
402 _ ->
403 generateCallHelp mode func args
405 _ ->
406 generateCallHelp mode func args
409generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
410generateCallHelp mode func args =
411 generateNormalCall
412 (generateJsExpr mode func)
413 (map (generateJsExpr mode) args)
416generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
417generateGlobalCall home name args =
418 generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args
421generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
422generateNormalCall func args =
423 case IntMap.lookup (length args) callHelpers of
424 Just helper ->
425 JS.Call helper (func:args)
427 Nothing ->
428 List.foldl' (\f a -> JS.Call f [a]) func args
431{-# NOINLINE callHelpers #-}
432callHelpers :: IntMap.IntMap JS.Expr
433callHelpers =
434 IntMap.fromList $
435 map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9]
439-- CORE CALLS
442generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
443generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
444 if moduleName == Name.basics then
445 generateBasicsCall mode home name args
447 else if moduleName == Name.bitwise then
448 generateBitwiseCall home name (map (generateJsExpr mode) args)
450 else if moduleName == Name.tuple then
451 generateTupleCall home name (map (generateJsExpr mode) args)
453 else if moduleName == Name.jsArray then
454 generateJsArrayCall home name (map (generateJsExpr mode) args)
456 else
457 generateGlobalCall home name (map (generateJsExpr mode) args)
460generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
461generateTupleCall home name args =
462 case args of
463 [value] ->
464 case name of
465 "first" -> JS.Access value (JsName.fromLocal "a")
466 "second" -> JS.Access value (JsName.fromLocal "b")
467 _ -> generateGlobalCall home name args
469 _ ->
470 generateGlobalCall home name args
473generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
474generateJsArrayCall home name args =
475 case args of
476 [entry] | name == "singleton" -> JS.Array [entry]
477 [index, array] | name == "unsafeGet" -> JS.Index array index
478 _ -> generateGlobalCall home name args
481generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
482generateBitwiseCall home name args =
483 case args of
484 [arg] ->
485 case name of
486 "complement" -> JS.Prefix JS.PrefixComplement arg
487 _ -> generateGlobalCall home name args
489 [left,right] ->
490 case name of
491 "and" -> JS.Infix JS.OpBitwiseAnd left right
492 "or" -> JS.Infix JS.OpBitwiseOr left right
493 "xor" -> JS.Infix JS.OpBitwiseXor left right
494 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
495 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
496 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
497 _ -> generateGlobalCall home name args
499 _ ->
500 generateGlobalCall home name args
503generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr
504generateBasicsCall mode home name args =
505 case args of
506 [elmArg] ->
507 let arg = generateJsExpr mode elmArg in
508 case name of
509 "not" -> JS.Prefix JS.PrefixNot arg
510 "negate" -> JS.Prefix JS.PrefixNegate arg
511 "toFloat" -> arg
512 "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
513 _ -> generateGlobalCall home name [arg]
515 [elmLeft, elmRight] ->
516 case name of
517 -- NOTE: removed "composeL" and "composeR" because of this issue:
518 -- https://github.com/elm/compiler/issues/1722
519 "append" -> append mode elmLeft elmRight
520 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
521 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
522 _ ->
523 let
524 left = generateJsExpr mode elmLeft
525 right = generateJsExpr mode elmRight
526 in
527 case name of
528 "add" -> JS.Infix JS.OpAdd left right
529 "sub" -> JS.Infix JS.OpSub left right
530 "mul" -> JS.Infix JS.OpMul left right
531 "fdiv" -> JS.Infix JS.OpDiv left right
532 "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
533 "eq" -> equal left right
534 "neq" -> notEqual left right
535 "lt" -> cmp JS.OpLt JS.OpLt 0 left right
536 "gt" -> cmp JS.OpGt JS.OpGt 0 left right
537 "le" -> cmp JS.OpLe JS.OpLt 1 left right
538 "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
539 "or" -> JS.Infix JS.OpOr left right
540 "and" -> JS.Infix JS.OpAnd left right
541 "xor" -> JS.Infix JS.OpNe left right
542 "remainderBy" -> JS.Infix JS.OpMod right left
543 _ -> generateGlobalCall home name [left, right]
545 _ ->
546 generateGlobalCall home name (map (generateJsExpr mode) args)
549equal :: JS.Expr -> JS.Expr -> JS.Expr
550equal left right =
551 if isLiteral left || isLiteral right then
552 strictEq left right
553 else
554 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
557notEqual :: JS.Expr -> JS.Expr -> JS.Expr
558notEqual left right =
559 if isLiteral left || isLiteral right then
560 strictNEq left right
561 else
562 JS.Prefix JS.PrefixNot $
563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
566cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
567cmp idealOp backupOp backupInt left right =
568 if isLiteral left || isLiteral right then
569 JS.Infix idealOp left right
570 else
571 JS.Infix backupOp
572 (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right])
573 (JS.Int backupInt)
576isLiteral :: JS.Expr -> Bool
577isLiteral expr =
578 case expr of
579 JS.String _ ->
580 True
582 JS.Float _ ->
583 True
585 JS.Int _ ->
586 True
588 JS.Bool _ ->
589 True
591 _ ->
592 False
595apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
596apply func value =
597 case func of
598 Opt.Accessor field ->
599 Opt.Access value field
601 Opt.Call f args ->
602 Opt.Call f (args ++ [value])
604 _ ->
605 Opt.Call func [value]
608append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
609append mode left right =
610 let seqs = generateJsExpr mode left : toSeqs mode right in
611 if any isStringLiteral seqs then
612 foldr1 (JS.Infix JS.OpAdd) seqs
613 else
614 foldr1 jsAppend seqs
617jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
618jsAppend a b =
619 JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b]
622toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
623toSeqs mode expr =
624 case expr of
625 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
626 | home == ModuleName.basics ->
627 generateJsExpr mode left : toSeqs mode right
629 _ ->
630 [generateJsExpr mode expr]
633isStringLiteral :: JS.Expr -> Bool
634isStringLiteral expr =
635 case expr of
636 JS.String _ ->
637 True
639 _ ->
640 False
644-- SIMPLIFY INFIX OPERATORS
647strictEq :: JS.Expr -> JS.Expr -> JS.Expr
648strictEq left right =
649 case left of
650 JS.Int 0 ->
651 JS.Prefix JS.PrefixNot right
653 JS.Bool bool ->
654 if bool then right else JS.Prefix JS.PrefixNot right
656 _ ->
657 case right of
658 JS.Int 0 ->
659 JS.Prefix JS.PrefixNot left
661 JS.Bool bool ->
662 if bool then left else JS.Prefix JS.PrefixNot left
664 _ ->
665 JS.Infix JS.OpEq left right
668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
669strictNEq left right =
670 case left of
671 JS.Int 0 ->
672 JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
674 JS.Bool bool ->
675 if bool then JS.Prefix JS.PrefixNot right else right
677 _ ->
678 case right of
679 JS.Int 0 ->
680 JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
682 JS.Bool bool ->
683 if bool then JS.Prefix JS.PrefixNot left else left
685 _ ->
686 JS.Infix JS.OpNe left right
690-- TAIL CALL
693-- TODO check if JS minifiers collapse unnecessary temporary variables
694--
695generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt]
696generateTailCall mode name args =
697 let
698 toTempVars (argName, arg) =
699 ( JsName.makeTemp argName, generateJsExpr mode arg )
701 toRealVars (argName, _) =
702 JS.ExprStmt $
703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
704 in
705 JS.Vars (map toTempVars args)
706 : map toRealVars args
707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
711-- DEFINITIONS
714generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
715generateDef mode def =
716 case def of
717 Opt.Def name body ->
718 JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
720 Opt.TailDef name argNames body ->
721 JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
725generateTailDef mode name argNames body =
726 generateFunction (map JsName.fromLocal argNames) $ JsBlock $
727 [ JS.Labelled (JsName.fromLocal name) $
728 JS.While (JS.Bool True) $
729 codeToStmt $ generate mode body
730 ]
734-- PATHS
737generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
738generatePath mode path =
739 case path of
740 Opt.Index index subPath ->
741 JS.Access (generatePath mode subPath) (JsName.fromIndex index)
743 Opt.Root name ->
744 JS.Ref (JsName.fromLocal name)
746 Opt.Field field subPath ->
747 JS.Access (generatePath mode subPath) (generateField mode field)
749 Opt.Unbox subPath ->
750 case mode of
751 Mode.Dev _ ->
752 JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first)
754 Mode.Prod _ ->
755 generatePath mode subPath
759-- GENERATE IFS
762generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
763generateIf mode givenBranches givenFinal =
764 let
765 (branches, final) =
766 crushIfs givenBranches givenFinal
768 convertBranch (condition, expr) =
769 ( generateJsExpr mode condition
770 , generate mode expr
771 )
773 branchExprs = map convertBranch branches
774 finalCode = generate mode final
775 in
776 if isBlock finalCode || any (isBlock . snd) branchExprs then
777 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
778 else
779 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
782addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
783addExprIf (condition, branch) final =
784 JS.If condition (codeToExpr branch) final
787addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
788addStmtIf (condition, branch) final =
789 JS.IfStmt condition (codeToStmt branch) final
792isBlock :: Code -> Bool
793isBlock code =
794 case code of
795 JsBlock _ -> True
796 JsExpr _ -> False
799crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
800crushIfs branches final =
801 crushIfsHelp [] branches final
804crushIfsHelp
805 :: [(Opt.Expr, Opt.Expr)]
806 -> [(Opt.Expr, Opt.Expr)]
807 -> Opt.Expr
808 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
809crushIfsHelp visitedBranches unvisitedBranches final =
810 case unvisitedBranches of
811 [] ->
812 case final of
813 Opt.If subBranches subFinal ->
814 crushIfsHelp visitedBranches subBranches subFinal
816 _ ->
817 (reverse visitedBranches, final)
819 visiting : unvisited ->
820 crushIfsHelp (visiting : visitedBranches) unvisited final
824-- CASE EXPRESSIONS
827generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
828generateCase mode label root decider jumps =
829 foldr (goto mode label) (generateDecider mode label root decider) jumps
832goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
833goto mode label (index, branch) stmts =
834 let
835 labeledDeciderStmt =
836 JS.Labelled
837 (JsName.makeLabel label index)
838 (JS.While (JS.Bool True) (JS.Block stmts))
839 in
840 labeledDeciderStmt : codeToStmtList (generate mode branch)
843generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
844generateDecider mode label root decisionTree =
845 case decisionTree of
846 Opt.Leaf (Opt.Inline branch) ->
847 codeToStmtList (generate mode branch)
849 Opt.Leaf (Opt.Jump index) ->
850 [ JS.Break (Just (JsName.makeLabel label index)) ]
852 Opt.Chain testChain success failure ->
853 [ JS.IfStmt
854 (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
855 (JS.Block $ generateDecider mode label root success)
856 (JS.Block $ generateDecider mode label root failure)
857 ]
859 Opt.FanOut path edges fallback ->
860 [ JS.Switch
861 (generateCaseTest mode root path (fst (head edges)))
862 ( foldr
863 (\edge cases -> generateCaseBranch mode label root edge : cases)
864 [ JS.Default (generateDecider mode label root fallback) ]
865 edges
866 )
867 ]
870generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr
871generateIfTest mode root (path, test) =
872 let
873 value = pathToJsExpr mode root path
874 in
875 case test of
876 DT.IsCtor home name index _ opts ->
877 let
878 tag =
879 case mode of
880 Mode.Dev _ -> JS.Access value JsName.dollar
881 Mode.Prod _ ->
882 case opts of
883 Can.Normal -> JS.Access value JsName.dollar
884 Can.Enum -> value
885 Can.Unbox -> value
886 in
887 strictEq tag $
888 case mode of
889 Mode.Dev _ -> JS.String (Name.toBuilder name)
890 Mode.Prod _ -> JS.Int (ctorToInt home name index)
892 DT.IsBool True ->
893 value
895 DT.IsBool False ->
896 JS.Prefix JS.PrefixNot value
898 DT.IsInt int ->
899 strictEq value (JS.Int int)
901 DT.IsChr char ->
902 strictEq (JS.String (Utf8.toBuilder char)) $
903 case mode of
904 Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
905 Mode.Prod _ -> value
907 DT.IsStr string ->
908 strictEq value (JS.String (Utf8.toBuilder string))
910 DT.IsCons ->
911 JS.Access value (JsName.fromLocal "b")
913 DT.IsNil ->
914 JS.Prefix JS.PrefixNot $
915 JS.Access value (JsName.fromLocal "b")
917 DT.IsTuple ->
918 error "COMPILER BUG - there should never be tests on a tuple"
922generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
923generateCaseBranch mode label root (test, subTree) =
924 JS.Case
925 (generateCaseValue mode test)
926 (generateDecider mode label root subTree)
929generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
930generateCaseValue mode test =
931 case test of
932 DT.IsCtor home name index _ _ ->
933 case mode of
934 Mode.Dev _ -> JS.String (Name.toBuilder name)
935 Mode.Prod _ -> JS.Int (ctorToInt home name index)
937 DT.IsInt int ->
938 JS.Int int
940 DT.IsChr char ->
941 JS.String (Utf8.toBuilder char)
943 DT.IsStr string ->
944 JS.String (Utf8.toBuilder string)
946 DT.IsBool _ ->
947 error "COMPILER BUG - there should never be three tests on a boolean"
949 DT.IsCons ->
950 error "COMPILER BUG - there should never be three tests on a list"
952 DT.IsNil ->
953 error "COMPILER BUG - there should never be three tests on a list"
955 DT.IsTuple ->
956 error "COMPILER BUG - there should never be three tests on a tuple"
959generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr
960generateCaseTest mode root path exampleTest =
961 let
962 value = pathToJsExpr mode root path
963 in
964 case exampleTest of
965 DT.IsCtor home name _ _ opts ->
966 if name == Name.bool && home == ModuleName.basics then
967 value
968 else
969 case mode of
970 Mode.Dev _ ->
971 JS.Access value JsName.dollar
973 Mode.Prod _ ->
974 case opts of
975 Can.Normal ->
976 JS.Access value JsName.dollar
978 Can.Enum ->
979 value
981 Can.Unbox ->
982 value
984 DT.IsInt _ ->
985 value
987 DT.IsStr _ ->
988 value
990 DT.IsChr _ ->
991 case mode of
992 Mode.Dev _ ->
993 JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
995 Mode.Prod _ ->
996 value
998 DT.IsBool _ ->
999 error "COMPILER BUG - there should never be three tests on a list"
1001 DT.IsCons ->
1002 error "COMPILER BUG - there should never be three tests on a list"
1004 DT.IsNil ->
1005 error "COMPILER BUG - there should never be three tests on a list"
1007 DT.IsTuple ->
1008 error "COMPILER BUG - there should never be three tests on a list"
1012-- PATTERN PATHS
1015pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr
1016pathToJsExpr mode root path =
1017 case path of
1018 DT.Index index subPath ->
1019 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index)
1021 DT.Unbox subPath ->
1022 case mode of
1023 Mode.Dev _ ->
1024 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first)
1026 Mode.Prod _ ->
1027 pathToJsExpr mode root subPath
1029 DT.Empty ->
1030 JS.Ref (JsName.fromLocal root)
1034-- GENERATE MAIN
1037generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1038generateMain mode home main =
1039 case main of
1040 Opt.Static ->
1041 JS.Ref (JsName.fromKernel Name.virtualDom "init")
1042 # JS.Ref (JsName.fromGlobal home "main")
1043 # JS.Int 0
1044 # JS.Int 0
1046 Opt.Dynamic msgType decoder ->
1047 JS.Ref (JsName.fromGlobal home "main")
1048 # generateJsExpr mode decoder
1049 # toDebugMetadata mode msgType
1052(#) :: JS.Expr -> JS.Expr -> JS.Expr
1053(#) func arg =
1054 JS.Call func [arg]
1057toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1058toDebugMetadata mode msgType =
1059 case mode of
1060 Mode.Prod _ ->
1061 JS.Int 0
1063 Mode.Dev Nothing ->
1064 JS.Int 0
1066 Mode.Dev (Just interfaces) ->
1067 JS.Json $ Encode.object $
1068 [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1069 , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)