git.iko.soy/elk
on 7b60982 help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1069 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 pathExpr = generatePath mode path
132 pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
133 in
134 JsBlock $ pathDef : codeToStmtList (generate mode body)
136 Opt.Case label root decider jumps ->
137 JsBlock $ generateCase mode label root decider jumps
139 Opt.Accessor field ->
140 JsExpr $ JS.Function Nothing [JsName.dollar]
141 [ JS.Return $ Just $
142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143 ]
145 Opt.Access record field ->
146 JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)
148 Opt.Update record fields ->
149 JsExpr $
150 JS.Call (JS.Ref (JsName.fromKernel Name.utils "update"))
151 [ generateJsExpr mode record
152 , generateRecord mode fields
153 ]
155 Opt.Record fields ->
156 JsExpr $ generateRecord mode fields
158 Opt.Unit ->
159 case mode of
160 Mode.Dev _ ->
161 JsExpr $ JS.Ref (JsName.fromKernel Name.utils "Tuple0")
163 Mode.Prod _ ->
164 JsExpr $ JS.Int 0
166 Opt.Tuple a b maybeC ->
167 JsExpr $
168 case maybeC of
169 Nothing ->
170 JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple2"))
171 [ generateJsExpr mode a
172 , generateJsExpr mode b
173 ]
175 Just c ->
176 JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3"))
177 [ generateJsExpr mode a
178 , generateJsExpr mode b
179 , generateJsExpr mode c
180 ]
182 Opt.Shader src attributes uniforms ->
183 let
184 toTranlation field =
185 ( JsName.fromLocal field
186 , JS.String (JsName.toBuilder (generateField mode field))
187 )
189 toTranslationObject fields =
190 JS.Object (map toTranlation (Set.toList fields))
191 in
192 JsExpr $ JS.Object $
193 [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 ]
200-- CODE CHUNKS
203data Code
204 = JsExpr JS.Expr
205 | JsBlock [JS.Stmt]
208codeToExpr :: Code -> JS.Expr
209codeToExpr code =
210 case code of
211 JsExpr expr ->
212 expr
214 JsBlock [ JS.Return (Just expr) ] ->
215 expr
217 JsBlock stmts ->
218 JS.Call (JS.Function Nothing [] stmts) []
221codeToStmtList :: Code -> [JS.Stmt]
222codeToStmtList code =
223 case code of
224 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
225 stmts
227 JsExpr expr ->
228 [ JS.Return (Just expr) ]
230 JsBlock stmts ->
231 stmts
234codeToStmt :: Code -> JS.Stmt
235codeToStmt code =
236 case code of
237 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
238 JS.Block stmts
240 JsExpr expr ->
241 JS.Return (Just expr)
243 JsBlock [stmt] ->
244 stmt
246 JsBlock stmts ->
247 JS.Block stmts
251-- CHARS
254{-# NOINLINE toChar #-}
255toChar :: JS.Expr
256toChar =
257 JS.Ref (JsName.fromKernel Name.utils "chr")
261-- CTOR
264generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
265generateCtor mode (Opt.Global home name) index arity =
266 let
267 argNames =
268 Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]
270 ctorTag =
271 case mode of
272 Mode.Dev _ -> JS.String (Name.toBuilder name)
273 Mode.Prod _ -> JS.Int (ctorToInt home name index)
274 in
275 generateFunction argNames $ JsExpr $ JS.Object $
276 (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
279ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int
280ctorToInt home name index =
281 if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
282 0 - Index.toHuman index
283 else
284 Index.toMachine index
288-- RECORDS
291generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr
292generateRecord mode fields =
293 let
294 toPair (field, value) =
295 (generateField mode field, generateJsExpr mode value)
296 in
297 JS.Object (map toPair (Map.toList fields))
300generateField :: Mode.Mode -> Name.Name -> JsName.Name
301generateField mode name =
302 case mode of
303 Mode.Dev _ ->
304 JsName.fromLocal name
306 Mode.Prod fields ->
307 fields ! name
312-- DEBUG
315generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr
316generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
317 if name /= "todo" then
318 JS.Ref (JsName.fromGlobal ModuleName.debug name)
319 else
320 case unhandledValueName of
321 Nothing ->
322 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $
323 [ JS.String (Name.toBuilder home)
324 , regionToJsExpr region
325 ]
327 Just valueName ->
328 JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $
329 [ JS.String (Name.toBuilder home)
330 , regionToJsExpr region
331 , JS.Ref (JsName.fromLocal valueName)
332 ]
335regionToJsExpr :: A.Region -> JS.Expr
336regionToJsExpr (A.Region start end) =
337 JS.Object
338 [ ( JsName.fromLocal "start", positionToJsExpr start )
339 , ( JsName.fromLocal "end", positionToJsExpr end )
340 ]
343positionToJsExpr :: A.Position -> JS.Expr
344positionToJsExpr (A.Position line column) =
345 JS.Object
346 [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) )
347 , ( JsName.fromLocal "column", JS.Int (fromIntegral column) )
348 ]
352-- FUNCTION
355generateFunction :: [JsName.Name] -> Code -> Code
356generateFunction args body =
357 case IntMap.lookup (length args) funcHelpers of
358 Just helper ->
359 JsExpr $
360 JS.Call helper
361 [ JS.Function Nothing args $
362 codeToStmtList body
363 ]
365 Nothing ->
366 let
367 addArg arg code =
368 JsExpr $ JS.Function Nothing [arg] $
369 codeToStmtList code
370 in
371 foldr addArg body args
374{-# NOINLINE funcHelpers #-}
375funcHelpers :: IntMap.IntMap JS.Expr
376funcHelpers =
377 IntMap.fromList $
378 map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9]
382-- CALLS
385generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
386generateCall mode func args =
387 case func of
388 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
389 generateCoreCall mode global args
391 Opt.VarBox _ ->
392 case mode of
393 Mode.Dev _ ->
394 generateCallHelp mode func args
396 Mode.Prod _ ->
397 case args of
398 [arg] ->
399 generateJsExpr mode arg
401 _ ->
402 generateCallHelp mode func args
404 _ ->
405 generateCallHelp mode func args
408generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
409generateCallHelp mode func args =
410 generateNormalCall
411 (generateJsExpr mode func)
412 (map (generateJsExpr mode) args)
415generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
416generateGlobalCall home name args =
417 generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args
420generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
421generateNormalCall func args =
422 case IntMap.lookup (length args) callHelpers of
423 Just helper ->
424 JS.Call helper (func:args)
426 Nothing ->
427 List.foldl' (\f a -> JS.Call f [a]) func args
430{-# NOINLINE callHelpers #-}
431callHelpers :: IntMap.IntMap JS.Expr
432callHelpers =
433 IntMap.fromList $
434 map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9]
438-- CORE CALLS
441generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
442generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
443 if moduleName == Name.basics then
444 generateBasicsCall mode home name args
446 else if moduleName == Name.bitwise then
447 generateBitwiseCall home name (map (generateJsExpr mode) args)
449 else if moduleName == Name.tuple then
450 generateTupleCall home name (map (generateJsExpr mode) args)
452 else if moduleName == Name.jsArray then
453 generateJsArrayCall home name (map (generateJsExpr mode) args)
455 else
456 generateGlobalCall home name (map (generateJsExpr mode) args)
459generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
460generateTupleCall home name args =
461 case args of
462 [value] ->
463 case name of
464 "first" -> JS.Access value (JsName.fromLocal "a")
465 "second" -> JS.Access value (JsName.fromLocal "b")
466 _ -> generateGlobalCall home name args
468 _ ->
469 generateGlobalCall home name args
472generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
473generateJsArrayCall home name args =
474 case args of
475 [entry] | name == "singleton" -> JS.Array [entry]
476 [index, array] | name == "unsafeGet" -> JS.Index array index
477 _ -> generateGlobalCall home name args
480generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
481generateBitwiseCall home name args =
482 case args of
483 [arg] ->
484 case name of
485 "complement" -> JS.Prefix JS.PrefixBNot arg
486 _ -> generateGlobalCall home name args
488 [left,right] ->
489 case name of
490 "and" -> JS.Infix JS.OpBAnd left right
491 "or" -> JS.Infix JS.OpBOr left right
492 "xor" -> JS.Infix JS.OpBXor left right
493 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496 _ -> generateGlobalCall home name args
498 _ ->
499 generateGlobalCall home name args
502generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr
503generateBasicsCall mode home name args =
504 case args of
505 [elmArg] ->
506 let arg = generateJsExpr mode elmArg in
507 case name of
508 "not" -> JS.Prefix JS.PrefixLNot arg
509 "negate" -> JS.Prefix JS.PrefixMinus arg
510 "toFloat" -> arg
511 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
512 _ -> generateGlobalCall home name [arg]
514 [elmLeft, elmRight] ->
515 case name of
516 -- NOTE: removed "composeL" and "composeR" because of this issue:
517 -- https://github.com/elm/compiler/issues/1722
518 "append" -> append mode elmLeft elmRight
519 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
520 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
521 _ ->
522 let
523 left = generateJsExpr mode elmLeft
524 right = generateJsExpr mode elmRight
525 in
526 case name of
527 "add" -> JS.Infix JS.OpAdd left right
528 "sub" -> JS.Infix JS.OpSub left right
529 "mul" -> JS.Infix JS.OpMul left right
530 "fdiv" -> JS.Infix JS.OpDiv left right
531 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532 "eq" -> equal left right
533 "neq" -> notEqual left right
534 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
535 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
536 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
537 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
538 "or" -> JS.Infix JS.OpLOr left right
539 "and" -> JS.Infix JS.OpLAnd left right
540 "xor" -> JS.Infix JS.OpStrictNEq left right
541 "remainderBy" -> JS.Infix JS.OpMod right left
542 _ -> generateGlobalCall home name [left, right]
544 _ ->
545 generateGlobalCall home name (map (generateJsExpr mode) args)
548equal :: JS.Expr -> JS.Expr -> JS.Expr
549equal left right =
550 if isLiteral left || isLiteral right then
551 strictEq left right
552 else
553 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
556notEqual :: JS.Expr -> JS.Expr -> JS.Expr
557notEqual left right =
558 if isLiteral left || isLiteral right then
559 strictNEq left right
560 else
561 JS.Prefix JS.PrefixLNot $
562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
565cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
566cmp idealOp backupOp backupInt left right =
567 if isLiteral left || isLiteral right then
568 JS.Infix idealOp left right
569 else
570 JS.Infix backupOp
571 (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right])
572 (JS.Int backupInt)
575isLiteral :: JS.Expr -> Bool
576isLiteral expr =
577 case expr of
578 JS.String _ ->
579 True
581 JS.Float _ ->
582 True
584 JS.Int _ ->
585 True
587 JS.Bool _ ->
588 True
590 _ ->
591 False
594apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
595apply func value =
596 case func of
597 Opt.Accessor field ->
598 Opt.Access value field
600 Opt.Call f args ->
601 Opt.Call f (args ++ [value])
603 _ ->
604 Opt.Call func [value]
607append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
608append mode left right =
609 let seqs = generateJsExpr mode left : toSeqs mode right in
610 if any isStringLiteral seqs then
611 foldr1 (JS.Infix JS.OpAdd) seqs
612 else
613 foldr1 jsAppend seqs
616jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
617jsAppend a b =
618 JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b]
621toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
622toSeqs mode expr =
623 case expr of
624 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
625 | home == ModuleName.basics ->
626 generateJsExpr mode left : toSeqs mode right
628 _ ->
629 [generateJsExpr mode expr]
632isStringLiteral :: JS.Expr -> Bool
633isStringLiteral expr =
634 case expr of
635 JS.String _ ->
636 True
638 _ ->
639 False
643-- SIMPLIFY INFIX OPERATORS
646strictEq :: JS.Expr -> JS.Expr -> JS.Expr
647strictEq left right =
648 case left of
649 JS.Int 0 ->
650 JS.Prefix JS.PrefixLNot right
652 JS.Bool bool ->
653 if bool then right else JS.Prefix JS.PrefixLNot right
655 _ ->
656 case right of
657 JS.Int 0 ->
658 JS.Prefix JS.PrefixLNot left
660 JS.Bool bool ->
661 if bool then left else JS.Prefix JS.PrefixLNot left
663 _ ->
664 JS.Infix JS.OpStrictEq left right
667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668strictNEq left right =
669 case left of
670 JS.Int 0 ->
671 JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
673 JS.Bool bool ->
674 if bool then JS.Prefix JS.PrefixLNot right else right
676 _ ->
677 case right of
678 JS.Int 0 ->
679 JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
681 JS.Bool bool ->
682 if bool then JS.Prefix JS.PrefixLNot left else left
684 _ ->
685 JS.Infix JS.OpStrictNEq left right
689-- TAIL CALL
692-- TODO check if JS minifiers collapse unnecessary temporary variables
693--
694generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt]
695generateTailCall mode name args =
696 let
697 toTempVars (argName, arg) =
698 ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
700 toRealVars (argName, _) =
701 JS.ExprStmt $
702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703 in
704 JS.Var (map toTempVars args)
705 : map toRealVars args
706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
710-- DEFINITIONS
713generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
714generateDef mode def =
715 case def of
716 Opt.Def name body ->
717 JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
719 Opt.TailDef name argNames body ->
720 JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
724generateTailDef mode name argNames body =
725 generateFunction (map JsName.fromLocal argNames) $ JsBlock $
726 [ JS.Labelled (JsName.fromLocal name) $
727 JS.While (JS.Bool True) $
728 codeToStmt $ generate mode body
729 ]
733-- PATHS
736generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
737generatePath mode path =
738 case path of
739 Opt.Index index subPath ->
740 JS.Access (generatePath mode subPath) (JsName.fromIndex index)
742 Opt.Root name ->
743 JS.Ref (JsName.fromLocal name)
745 Opt.Field field subPath ->
746 JS.Access (generatePath mode subPath) (generateField mode field)
748 Opt.Unbox subPath ->
749 case mode of
750 Mode.Dev _ ->
751 JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first)
753 Mode.Prod _ ->
754 generatePath mode subPath
758-- GENERATE IFS
761generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
762generateIf mode givenBranches givenFinal =
763 let
764 (branches, final) =
765 crushIfs givenBranches givenFinal
767 convertBranch (condition, expr) =
768 ( generateJsExpr mode condition
769 , generate mode expr
770 )
772 branchExprs = map convertBranch branches
773 finalCode = generate mode final
774 in
775 if isBlock finalCode || any (isBlock . snd) branchExprs then
776 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
777 else
778 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
781addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
782addExprIf (condition, branch) final =
783 JS.If condition (codeToExpr branch) final
786addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
787addStmtIf (condition, branch) final =
788 JS.IfStmt condition (codeToStmt branch) final
791isBlock :: Code -> Bool
792isBlock code =
793 case code of
794 JsBlock _ -> True
795 JsExpr _ -> False
798crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
799crushIfs branches final =
800 crushIfsHelp [] branches final
803crushIfsHelp
804 :: [(Opt.Expr, Opt.Expr)]
805 -> [(Opt.Expr, Opt.Expr)]
806 -> Opt.Expr
807 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
808crushIfsHelp visitedBranches unvisitedBranches final =
809 case unvisitedBranches of
810 [] ->
811 case final of
812 Opt.If subBranches subFinal ->
813 crushIfsHelp visitedBranches subBranches subFinal
815 _ ->
816 (reverse visitedBranches, final)
818 visiting : unvisited ->
819 crushIfsHelp (visiting : visitedBranches) unvisited final
823-- CASE EXPRESSIONS
826generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
827generateCase mode label root decider jumps =
828 foldr (goto mode label) (generateDecider mode label root decider) jumps
831goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
832goto mode label (index, branch) stmts =
833 let
834 labeledDeciderStmt =
835 JS.Labelled
836 (JsName.makeLabel label index)
837 (JS.While (JS.Bool True) (JS.Block stmts))
838 in
839 labeledDeciderStmt : codeToStmtList (generate mode branch)
842generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
843generateDecider mode label root decisionTree =
844 case decisionTree of
845 Opt.Leaf (Opt.Inline branch) ->
846 codeToStmtList (generate mode branch)
848 Opt.Leaf (Opt.Jump index) ->
849 [ JS.Break (Just (JsName.makeLabel label index)) ]
851 Opt.Chain testChain success failure ->
852 [ JS.IfStmt
853 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
854 (JS.Block $ generateDecider mode label root success)
855 (JS.Block $ generateDecider mode label root failure)
856 ]
858 Opt.FanOut path edges fallback ->
859 [ JS.Switch
860 (generateCaseTest mode root path (fst (head edges)))
861 ( foldr
862 (\edge cases -> generateCaseBranch mode label root edge : cases)
863 [ JS.Default (generateDecider mode label root fallback) ]
864 edges
865 )
866 ]
869generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr
870generateIfTest mode root (path, test) =
871 let
872 value = pathToJsExpr mode root path
873 in
874 case test of
875 DT.IsCtor home name index _ opts ->
876 let
877 tag =
878 case mode of
879 Mode.Dev _ -> JS.Access value JsName.dollar
880 Mode.Prod _ ->
881 case opts of
882 Can.Normal -> JS.Access value JsName.dollar
883 Can.Enum -> value
884 Can.Unbox -> value
885 in
886 strictEq tag $
887 case mode of
888 Mode.Dev _ -> JS.String (Name.toBuilder name)
889 Mode.Prod _ -> JS.Int (ctorToInt home name index)
891 DT.IsBool True ->
892 value
894 DT.IsBool False ->
895 JS.Prefix JS.PrefixLNot value
897 DT.IsInt int ->
898 strictEq value (JS.Int int)
900 DT.IsChr char ->
901 strictEq (JS.String (Utf8.toBuilder char)) $
902 case mode of
903 Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
904 Mode.Prod _ -> value
906 DT.IsStr string ->
907 strictEq value (JS.String (Utf8.toBuilder string))
909 DT.IsCons ->
910 JS.Access value (JsName.fromLocal "b")
912 DT.IsNil ->
913 JS.Prefix JS.PrefixLNot $
914 JS.Access value (JsName.fromLocal "b")
916 DT.IsTuple ->
917 error "COMPILER BUG - there should never be tests on a tuple"
921generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
922generateCaseBranch mode label root (test, subTree) =
923 JS.Case
924 (generateCaseValue mode test)
925 (generateDecider mode label root subTree)
928generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
929generateCaseValue mode test =
930 case test of
931 DT.IsCtor home name index _ _ ->
932 case mode of
933 Mode.Dev _ -> JS.String (Name.toBuilder name)
934 Mode.Prod _ -> JS.Int (ctorToInt home name index)
936 DT.IsInt int ->
937 JS.Int int
939 DT.IsChr char ->
940 JS.String (Utf8.toBuilder char)
942 DT.IsStr string ->
943 JS.String (Utf8.toBuilder string)
945 DT.IsBool _ ->
946 error "COMPILER BUG - there should never be three tests on a boolean"
948 DT.IsCons ->
949 error "COMPILER BUG - there should never be three tests on a list"
951 DT.IsNil ->
952 error "COMPILER BUG - there should never be three tests on a list"
954 DT.IsTuple ->
955 error "COMPILER BUG - there should never be three tests on a tuple"
958generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr
959generateCaseTest mode root path exampleTest =
960 let
961 value = pathToJsExpr mode root path
962 in
963 case exampleTest of
964 DT.IsCtor home name _ _ opts ->
965 if name == Name.bool && home == ModuleName.basics then
966 value
967 else
968 case mode of
969 Mode.Dev _ ->
970 JS.Access value JsName.dollar
972 Mode.Prod _ ->
973 case opts of
974 Can.Normal ->
975 JS.Access value JsName.dollar
977 Can.Enum ->
978 value
980 Can.Unbox ->
981 value
983 DT.IsInt _ ->
984 value
986 DT.IsStr _ ->
987 value
989 DT.IsChr _ ->
990 case mode of
991 Mode.Dev _ ->
992 JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
994 Mode.Prod _ ->
995 value
997 DT.IsBool _ ->
998 error "COMPILER BUG - there should never be three tests on a list"
1000 DT.IsCons ->
1001 error "COMPILER BUG - there should never be three tests on a list"
1003 DT.IsNil ->
1004 error "COMPILER BUG - there should never be three tests on a list"
1006 DT.IsTuple ->
1007 error "COMPILER BUG - there should never be three tests on a list"
1011-- PATTERN PATHS
1014pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr
1015pathToJsExpr mode root path =
1016 case path of
1017 DT.Index index subPath ->
1018 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index)
1020 DT.Unbox subPath ->
1021 case mode of
1022 Mode.Dev _ ->
1023 JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first)
1025 Mode.Prod _ ->
1026 pathToJsExpr mode root subPath
1028 DT.Empty ->
1029 JS.Ref (JsName.fromLocal root)
1033-- GENERATE MAIN
1036generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1037generateMain mode home main =
1038 case main of
1039 Opt.Static ->
1040 JS.Ref (JsName.fromKernel Name.virtualDom "init")
1041 # JS.Ref (JsName.fromGlobal home "main")
1042 # JS.Int 0
1043 # JS.Int 0
1045 Opt.Dynamic msgType decoder ->
1046 JS.Ref (JsName.fromGlobal home "main")
1047 # generateJsExpr mode decoder
1048 # toDebugMetadata mode msgType
1051(#) :: JS.Expr -> JS.Expr -> JS.Expr
1052(#) func arg =
1053 JS.Call func [arg]
1056toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1057toDebugMetadata mode msgType =
1058 case mode of
1059 Mode.Prod _ ->
1060 JS.Int 0
1062 Mode.Dev Nothing ->
1063 JS.Int 0
1065 Mode.Dev (Just interfaces) ->
1066 JS.Json $ Encode.object $
1067 [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))