git.iko.soy/elk
on fdf2d75 help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1037 lines 27 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateTailDef
6 , generateMain
7 , Code
8 , codeToExpr
9 , codeToStmtList
10 )
11 where
14import qualified Data.IntMap as IntMap
15import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Text.Encoding as Text
19import qualified AST.Canonical as Can
20import qualified AST.Optimized as Opt
21import qualified AST.Module.Name as ModuleName
22import qualified Data.Index as Index
23import qualified Elm.Compiler.Type as Type
24import qualified Elm.Compiler.Type.Extract as Extract
25import qualified Elm.Interface as I
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
28import qualified Elm.Compiler.Version as Version
29import qualified Generate.JavaScript.Builder as JS
30import qualified Generate.JavaScript.Name as Name
31import qualified Json.Encode as Encode
32import qualified Optimize.DecisionTree as DT
33import qualified Reporting.Region as R
37-- ENVIRONMENT
40type Mode = Name.Mode
44-- EXPRESSIONS
47generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
48generateJsExpr mode expression =
49 codeToExpr (generate mode expression)
52generate :: Mode -> Opt.Expr -> Code
53generate mode expression =
54 case expression of
55 Opt.Bool bool ->
56 JsExpr $ JS.Bool bool
58 Opt.Chr char ->
59 JsExpr $
60 case mode of
61 Name.Debug _ ->
62 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
64 Name.Prod _ _ ->
65 JS.String (Text.encodeUtf8Builder char)
67 Opt.Str string ->
68 JsExpr $ JS.String (Text.encodeUtf8Builder string)
70 Opt.Int int ->
71 JsExpr $ JS.Int int
73 Opt.Float float ->
74 JsExpr $ JS.Float float
76 Opt.VarLocal name ->
77 JsExpr $ JS.Ref (Name.fromLocal name)
79 Opt.VarGlobal (Opt.Global home name) ->
80 JsExpr $ JS.Ref (Name.fromGlobal home name)
82 Opt.VarEnum (Opt.Global home name) index ->
83 case mode of
84 Name.Debug _ ->
85 JsExpr $ JS.Ref (Name.fromGlobal home name)
87 Name.Prod _ _ ->
88 JsExpr $ JS.Int (Index.toMachine index)
90 Opt.VarBox (Opt.Global home name) ->
91 JsExpr $ JS.Ref $
92 case mode of
93 Name.Debug _ -> Name.fromGlobal home name
94 Name.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
96 Opt.VarCycle home name ->
97 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
99 Opt.VarDebug name home region unhandledValueName ->
100 JsExpr $ generateDebug name home region unhandledValueName
102 Opt.VarKernel home name ->
103 JsExpr $ JS.Ref (Name.fromKernel home name)
105 Opt.List entries ->
106 case entries of
107 [] ->
108 JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")
110 _ ->
111 JsExpr $
112 JS.Call
113 (JS.Ref (Name.fromKernel N.list "fromArray"))
114 [ JS.Array $ map (generateJsExpr mode) entries
115 ]
117 Opt.Function args body ->
118 generateFunction (map Name.fromLocal args) (generate mode body)
120 Opt.Call func args ->
121 JsExpr $ generateCall mode func args
123 Opt.TailCall name args ->
124 JsBlock $ generateTailCall mode name args
126 Opt.If branches final ->
127 generateIf mode branches final
129 Opt.Let def body ->
130 JsBlock $
131 generateDef mode def : codeToStmtList (generate mode body)
133 Opt.Destruct (Opt.Destructor name path) body ->
134 let
135 pathExpr = generatePath mode path
136 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
137 in
138 JsBlock $ pathDef : codeToStmtList (generate mode body)
140 Opt.Case label root decider jumps ->
141 JsBlock $ generateCase mode label root decider jumps
143 Opt.Accessor field ->
144 JsExpr $ JS.Function Nothing [Name.dollar]
145 [ JS.Return $ Just $
146 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
147 ]
149 Opt.Access record field ->
150 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
152 Opt.Update record fields ->
153 JsExpr $
154 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
155 [ generateJsExpr mode record
156 , generateRecord mode fields
157 ]
159 Opt.Record fields ->
160 JsExpr $ generateRecord mode fields
162 Opt.Unit ->
163 case mode of
164 Name.Debug _ ->
165 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
167 Name.Prod _ _ ->
168 JsExpr $ JS.Int 0
170 Opt.Tuple a b maybeC ->
171 JsExpr $
172 case maybeC of
173 Nothing ->
174 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
175 [ generateJsExpr mode a
176 , generateJsExpr mode b
177 ]
179 Just c ->
180 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
181 [ generateJsExpr mode a
182 , generateJsExpr mode b
183 , generateJsExpr mode c
184 ]
186 Opt.Shader src ->
187 let string = JS.String (Text.encodeUtf8Builder src) in
188 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
192-- CODE CHUNKS
195data Code
196 = JsExpr JS.Expr
197 | JsBlock [JS.Stmt]
200codeToExpr :: Code -> JS.Expr
201codeToExpr code =
202 case code of
203 JsExpr expr ->
204 expr
206 JsBlock [ JS.Return (Just expr) ] ->
207 expr
209 JsBlock stmts ->
210 JS.Call (JS.Function Nothing [] stmts) []
213codeToStmtList :: Code -> [JS.Stmt]
214codeToStmtList code =
215 case code of
216 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
217 stmts
219 JsExpr expr ->
220 [ JS.Return (Just expr) ]
222 JsBlock stmts ->
223 stmts
226codeToStmt :: Code -> JS.Stmt
227codeToStmt code =
228 case code of
229 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
230 JS.Block stmts
232 JsExpr expr ->
233 JS.Return (Just expr)
235 JsBlock [stmt] ->
236 stmt
238 JsBlock stmts ->
239 JS.Block stmts
243-- CHARS
246{-# NOINLINE toChar #-}
247toChar :: JS.Expr
248toChar =
249 JS.Ref (Name.fromKernel N.utils "chr")
253-- CTOR
256generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code
257generateCtor mode name index arity =
258 let
259 argNames =
260 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
262 ctorTag =
263 case mode of
264 Name.Debug _ -> JS.String (N.toBuilder name)
265 Name.Prod _ _ -> JS.Int (Index.toMachine index)
266 in
267 generateFunction argNames $ JsExpr $ JS.Object $
268 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
272-- RECORDS
275generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
276generateRecord mode fields =
277 let
278 toPair (field, value) =
279 (Name.fromField mode field, generateJsExpr mode value)
280 in
281 JS.Object (map toPair (Map.toList fields))
285-- DEBUG
288generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
289generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
290 if name /= "crash" then
291 JS.Ref (Name.fromGlobal ModuleName.debug name)
292 else
293 case unhandledValueName of
294 Nothing ->
295 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
296 [ JS.String (N.toBuilder home)
297 , regionToJsExpr region
298 ]
300 Just valueName ->
301 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
302 [ JS.String (N.toBuilder home)
303 , regionToJsExpr region
304 , JS.Ref (Name.fromLocal valueName)
305 ]
308regionToJsExpr :: R.Region -> JS.Expr
309regionToJsExpr (R.Region start end) =
310 JS.Object
311 [ ( Name.fromLocal "start", positionToJsExpr start )
312 , ( Name.fromLocal "end", positionToJsExpr end )
313 ]
316positionToJsExpr :: R.Position -> JS.Expr
317positionToJsExpr (R.Position line column) =
318 JS.Object
319 [ ( Name.fromLocal "line", JS.Int line )
320 , ( Name.fromLocal "column", JS.Int column )
321 ]
325-- FUNCTION
328generateFunction :: [Name.Name] -> Code -> Code
329generateFunction args body =
330 case IntMap.lookup (length args) funcHelpers of
331 Just helper ->
332 JsExpr $
333 JS.Call helper
334 [ JS.Function Nothing args $
335 codeToStmtList body
336 ]
338 Nothing ->
339 let
340 addArg arg code =
341 JsExpr $ JS.Function Nothing [arg] $
342 codeToStmtList code
343 in
344 foldr addArg body args
347{-# NOINLINE funcHelpers #-}
348funcHelpers :: IntMap.IntMap JS.Expr
349funcHelpers =
350 IntMap.fromList $
351 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
355-- CALLS
358generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
359generateCall mode func args =
360 case func of
361 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
362 generateCoreCall mode global args
364 Opt.VarBox _ ->
365 case mode of
366 Name.Debug _ ->
367 generateCallHelp mode func args
369 Name.Prod _ _ ->
370 case args of
371 [arg] ->
372 generateJsExpr mode arg
374 _ ->
375 generateCallHelp mode func args
377 _ ->
378 generateCallHelp mode func args
381generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
382generateCallHelp mode func args =
383 generateNormalCall
384 (generateJsExpr mode func)
385 (map (generateJsExpr mode) args)
388generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
389generateGlobalCall home name args =
390 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
393generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
394generateNormalCall func args =
395 case IntMap.lookup (length args) callHelpers of
396 Just helper ->
397 JS.Call helper (func:args)
399 Nothing ->
400 List.foldl' (\f a -> JS.Call f [a]) func args
403{-# NOINLINE callHelpers #-}
404callHelpers :: IntMap.IntMap JS.Expr
405callHelpers =
406 IntMap.fromList $
407 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
411-- CORE CALLS
414generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
415generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
416 if moduleName == N.basics then
417 generateBasicsCall mode home name args
419 else if moduleName == N.bitwise then
420 generateBitwiseCall home name (map (generateJsExpr mode) args)
422 else if moduleName == N.tuple then
423 generateTupleCall home name (map (generateJsExpr mode) args)
425 else if moduleName == N.jsArray then
426 generateJsArrayCall home name (map (generateJsExpr mode) args)
428 else
429 generateGlobalCall home name (map (generateJsExpr mode) args)
432generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
433generateTupleCall home name args =
434 case args of
435 [value] ->
436 case name of
437 "first" -> JS.Access value (Name.fromLocal "a")
438 "second" -> JS.Access value (Name.fromLocal "b")
439 _ -> generateGlobalCall home name args
441 _ ->
442 generateGlobalCall home name args
445generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
446generateJsArrayCall home name args =
447 case args of
448 [entry] | name == "singleton" -> JS.Array [entry]
449 [index, array] | name == "unsafeGet" -> JS.Index array index
450 _ -> generateGlobalCall home name args
453generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
454generateBitwiseCall home name args =
455 case args of
456 [arg] ->
457 case name of
458 "complement" -> JS.Prefix JS.PrefixBNot arg
459 _ -> generateGlobalCall home name args
461 [left,right] ->
462 case name of
463 "and" -> JS.Infix JS.OpBAnd left right
464 "or" -> JS.Infix JS.OpBOr left right
465 "xor" -> JS.Infix JS.OpBXor left right
466 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
467 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
468 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
469 _ -> generateGlobalCall home name args
471 _ ->
472 generateGlobalCall home name args
475generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
476generateBasicsCall mode home name args =
477 case args of
478 [elmArg] ->
479 let arg = generateJsExpr mode elmArg in
480 case name of
481 "not" -> JS.Prefix JS.PrefixLNot arg
482 "negate" -> JS.Prefix JS.PrefixMinus arg
483 "toFloat" -> arg
484 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
485 _ -> generateGlobalCall home name [arg]
487 [elmLeft, elmRight] ->
488 case name of
489 "composeL" -> decomposeL mode elmLeft [elmRight]
490 "composeR" -> decomposeR mode [elmLeft] elmRight
491 "append" -> append mode elmLeft elmRight
492 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
493 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
494 _ ->
495 let
496 left = generateJsExpr mode elmLeft
497 right = generateJsExpr mode elmRight
498 in
499 case name of
500 "add" -> JS.Infix JS.OpAdd left right
501 "sub" -> JS.Infix JS.OpSub left right
502 "mul" -> JS.Infix JS.OpMul left right
503 "fdiv" -> JS.Infix JS.OpDiv left right
504 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
505 "eq" -> equal left right
506 "neq" -> notEqual left right
507 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
508 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
509 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
510 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
511 "or" -> JS.Infix JS.OpLOr left right
512 "and" -> JS.Infix JS.OpLAnd left right
513 "xor" -> JS.Infix JS.OpStrictNEq left right
514 _ -> generateGlobalCall home name [left, right]
516 _ ->
517 generateGlobalCall home name (map (generateJsExpr mode) args)
520equal :: JS.Expr -> JS.Expr -> JS.Expr
521equal left right =
522 if isLiteral left || isLiteral right then
523 strictEq left right
524 else
525 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
528notEqual :: JS.Expr -> JS.Expr -> JS.Expr
529notEqual left right =
530 if isLiteral left || isLiteral right then
531 strictNEq left right
532 else
533 JS.Prefix JS.PrefixLNot $
534 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
537cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
538cmp idealOp backupOp backupInt left right =
539 if isLiteral left || isLiteral right then
540 JS.Infix idealOp left right
541 else
542 JS.Infix backupOp
543 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
544 (JS.Int backupInt)
547isLiteral :: JS.Expr -> Bool
548isLiteral expr =
549 case expr of
550 JS.String _ ->
551 True
553 JS.Float _ ->
554 True
556 JS.Int _ ->
557 True
559 JS.Bool _ ->
560 True
562 _ ->
563 False
566decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
567decomposeL mode expr funcs =
568 case expr of
569 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
570 | home == ModuleName.basics ->
571 decomposeL mode left (func:funcs)
573 _ ->
574 generateJsExpr mode $
575 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
578decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
579decomposeR mode funcs expr =
580 case expr of
581 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
582 | home == ModuleName.basics ->
583 decomposeR mode (func:funcs) right
585 _ ->
586 generateJsExpr mode $
587 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
590apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
591apply func value =
592 case func of
593 Opt.Accessor field ->
594 Opt.Access value field
596 Opt.Call f args ->
597 Opt.Call f (args ++ [value])
599 _ ->
600 Opt.Call func [value]
603append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
604append mode left right =
605 let seqs = generateJsExpr mode left : toSeqs mode right in
606 if any isStringLiteral seqs then
607 foldr1 (JS.Infix JS.OpAdd) seqs
608 else
609 foldr1 jsAppend seqs
612jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
613jsAppend a b =
614 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
617toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
618toSeqs mode expr =
619 case expr of
620 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
621 | home == ModuleName.basics ->
622 generateJsExpr mode left : toSeqs mode right
624 _ ->
625 [generateJsExpr mode expr]
628isStringLiteral :: JS.Expr -> Bool
629isStringLiteral expr =
630 case expr of
631 JS.String _ ->
632 True
634 _ ->
635 False
639-- SIMPLIFY INFIX OPERATORS
642strictEq :: JS.Expr -> JS.Expr -> JS.Expr
643strictEq left right =
644 case left of
645 JS.Int 0 ->
646 JS.Prefix JS.PrefixLNot right
648 JS.Bool bool ->
649 if bool then right else JS.Prefix JS.PrefixLNot right
651 _ ->
652 case right of
653 JS.Int 0 ->
654 JS.Prefix JS.PrefixLNot left
656 JS.Bool bool ->
657 if bool then left else JS.Prefix JS.PrefixLNot left
659 _ ->
660 JS.Infix JS.OpStrictEq left right
663strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
664strictNEq left right =
665 case left of
666 JS.Int 0 ->
667 right
669 JS.Bool bool ->
670 if bool then JS.Prefix JS.PrefixLNot right else right
672 _ ->
673 case right of
674 JS.Int 0 ->
675 left
677 JS.Bool bool ->
678 if bool then JS.Prefix JS.PrefixLNot left else left
680 _ ->
681 JS.Infix JS.OpStrictNEq left right
685-- TAIL CALL
688-- TODO check if JS minifiers collapse unnecessary temporary variables
689--
690generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
691generateTailCall mode name args =
692 let
693 toTempVars (argName, arg) =
694 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
696 toRealVars (argName, _) =
697 JS.ExprStmt $
698 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
699 in
700 JS.Var (map toTempVars args)
701 : map toRealVars args
702 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
706-- DEFINITIONS
709generateDef :: Mode -> Opt.Def -> JS.Stmt
710generateDef mode def =
711 case def of
712 Opt.Def name body ->
713 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
715 Opt.TailDef name argNames body ->
716 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
719generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
720generateTailDef mode name argNames body =
721 generateFunction (map Name.fromLocal argNames) $ JsBlock $
722 [ JS.Labelled (Name.fromLocal name) $
723 JS.While (JS.Bool True) $
724 codeToStmt $ generate mode body
725 ]
729-- PATHS
732generatePath :: Mode -> Opt.Path -> JS.Expr
733generatePath mode path =
734 case path of
735 Opt.Index index subPath ->
736 JS.Access (generatePath mode subPath) (Name.fromIndex index)
738 Opt.Root name ->
739 JS.Ref (Name.fromLocal name)
741 Opt.Field field subPath ->
742 JS.Access (generatePath mode subPath) (Name.fromField mode field)
744 Opt.Unbox subPath ->
745 case mode of
746 Name.Debug _ ->
747 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
749 Name.Prod _ _ ->
750 generatePath mode subPath
754-- GENERATE IFS
757generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
758generateIf mode givenBranches givenFinal =
759 let
760 (branches, final) =
761 crushIfs givenBranches givenFinal
763 convertBranch (condition, expr) =
764 ( generateJsExpr mode condition
765 , generate mode expr
766 )
768 branchExprs = map convertBranch branches
769 finalCode = generate mode final
770 in
771 if isBlock finalCode || any (isBlock . snd) branchExprs then
772 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
773 else
774 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
777addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
778addExprIf (condition, branch) final =
779 JS.If condition (codeToExpr branch) final
782addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
783addStmtIf (condition, branch) final =
784 JS.IfStmt condition (codeToStmt branch) final
787isBlock :: Code -> Bool
788isBlock code =
789 case code of
790 JsBlock _ -> True
791 JsExpr _ -> False
794crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
795crushIfs branches final =
796 crushIfsHelp [] branches final
799crushIfsHelp
800 :: [(Opt.Expr, Opt.Expr)]
801 -> [(Opt.Expr, Opt.Expr)]
802 -> Opt.Expr
803 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
804crushIfsHelp visitedBranches unvisitedBranches final =
805 case unvisitedBranches of
806 [] ->
807 case final of
808 Opt.If subBranches subFinal ->
809 crushIfsHelp visitedBranches subBranches subFinal
811 _ ->
812 (reverse visitedBranches, final)
814 visiting : unvisited ->
815 crushIfsHelp (visiting : visitedBranches) unvisited final
819-- CASE EXPRESSIONS
822generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
823generateCase mode label root decider jumps =
824 foldr (goto mode label) (generateDecider mode label root decider) jumps
827goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
828goto mode label (index, branch) stmts =
829 let
830 labeledDeciderStmt =
831 JS.Labelled
832 (Name.makeLabel label index)
833 (JS.While (JS.Bool True) (JS.Block stmts))
834 in
835 labeledDeciderStmt : codeToStmtList (generate mode branch)
838generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
839generateDecider mode label root decisionTree =
840 case decisionTree of
841 Opt.Leaf (Opt.Inline branch) ->
842 codeToStmtList (generate mode branch)
844 Opt.Leaf (Opt.Jump index) ->
845 [ JS.Break (Just (Name.makeLabel label index)) ]
847 Opt.Chain testChain success failure ->
848 [ JS.IfStmt
849 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
850 (JS.Block $ generateDecider mode label root success)
851 (JS.Block $ generateDecider mode label root failure)
852 ]
854 Opt.FanOut path edges fallback ->
855 [ JS.Switch
856 (generateCaseTest mode root path (fst (head edges)))
857 ( foldr
858 (\edge cases -> generateCaseBranch mode label root edge : cases)
859 [ JS.Default (generateDecider mode label root fallback) ]
860 edges
861 )
862 ]
865generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
866generateIfTest mode root (path, test) =
867 let
868 value = pathToJsExpr mode root path
869 in
870 case test of
871 DT.IsCtor name index _ _ ->
872 strictEq (JS.Access value Name.dollar) $
873 case mode of
874 Name.Debug _ -> JS.String (N.toBuilder name)
875 Name.Prod _ _ -> JS.Int (Index.toMachine index)
877 DT.IsInt int ->
878 strictEq value (JS.Int int)
880 DT.IsChr char ->
881 strictEq (JS.String (Text.encodeUtf8Builder char)) $
882 case mode of
883 Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
884 Name.Prod _ _ -> value
886 DT.IsStr string ->
887 strictEq value (JS.String (Text.encodeUtf8Builder string))
889 DT.IsCons ->
890 JS.Access value (Name.fromLocal "b")
892 DT.IsNil ->
893 JS.Prefix JS.PrefixLNot $
894 JS.Access value (Name.fromLocal "b")
896 DT.IsTuple ->
897 error "COMPILER BUG - there should never be tests on a tuple"
901generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
902generateCaseBranch mode label root (test, subTree) =
903 JS.Case
904 (generateCaseValue mode test)
905 (generateDecider mode label root subTree)
908generateCaseValue :: Mode -> DT.Test -> JS.Expr
909generateCaseValue mode test =
910 case test of
911 DT.IsCtor name index _ _ ->
912 case mode of
913 Name.Debug _ -> JS.String (N.toBuilder name)
914 Name.Prod _ _ -> JS.Int (Index.toMachine index)
916 DT.IsInt int ->
917 JS.Int int
919 DT.IsChr char ->
920 JS.String (Text.encodeUtf8Builder char)
922 DT.IsStr string ->
923 JS.String (Text.encodeUtf8Builder string)
925 DT.IsCons ->
926 error "COMPILER BUG - there should never be three tests on a list"
928 DT.IsNil ->
929 error "COMPILER BUG - there should never be three tests on a list"
931 DT.IsTuple ->
932 error "COMPILER BUG - there should never be three tests on a tuple"
935generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
936generateCaseTest mode root path exampleTest =
937 let
938 value = pathToJsExpr mode root path
939 in
940 case exampleTest of
941 DT.IsCtor _ _ _ opts ->
942 case mode of
943 Name.Debug _ ->
944 JS.Access value Name.dollar
946 Name.Prod _ _ ->
947 case opts of
948 Can.Normal ->
949 JS.Access value Name.dollar
951 Can.Enum ->
952 value
954 Can.Unbox ->
955 value
957 DT.IsInt _ ->
958 value
960 DT.IsStr _ ->
961 value
963 DT.IsChr _ ->
964 case mode of
965 Name.Debug _ ->
966 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
968 Name.Prod _ _ ->
969 value
971 DT.IsCons ->
972 error "COMPILER BUG - there should never be three tests on a list"
974 DT.IsNil ->
975 error "COMPILER BUG - there should never be three tests on a list"
977 DT.IsTuple ->
978 error "COMPILER BUG - there should never be three tests on a list"
982-- PATTERN PATHS
985pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
986pathToJsExpr mode root path =
987 case path of
988 DT.Index index subPath ->
989 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
991 DT.Unbox subPath ->
992 case mode of
993 Name.Debug _ ->
994 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
996 Name.Prod _ _ ->
997 pathToJsExpr mode root subPath
999 DT.Empty ->
1000 JS.Ref (Name.fromLocal root)
1004-- GENERATE MAIN
1007generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1008generateMain mode interfaces home main =
1009 case main of
1010 Opt.Static ->
1011 JS.Ref (Name.fromKernel "VirtualDom" "init")
1012 # JS.Ref (Name.fromGlobal home "main")
1013 # JS.Int 0
1014 # JS.Int 0
1016 Opt.Dynamic msgType decoder ->
1017 JS.Ref (Name.fromGlobal home "main")
1018 # generateJsExpr mode decoder
1019 # toDebugMetadata mode interfaces msgType
1022(#) :: JS.Expr -> JS.Expr -> JS.Expr
1023(#) func arg =
1024 JS.Call func [arg]
1027toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1028toDebugMetadata mode interfaces msgType =
1029 case mode of
1030 Name.Prod _ _ ->
1031 JS.Int 0
1033 Name.Debug _ ->
1034 JS.Json $ Encode.object $
1035 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1036 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))