git.iko.soy/elk
on 51e95e8 help sign in
elk/src/Generate/JavaScript/Expression.hs
1027 lines 26 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generate
4 , generateCtor
5 , generateFunction
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.Chr char ->
56 JsExpr $
57 case mode of
58 Name.Debug _ ->
59 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
61 Name.Prod _ _ ->
62 JS.String (Text.encodeUtf8Builder char)
64 Opt.Str string ->
65 JsExpr $ JS.String (Text.encodeUtf8Builder string)
67 Opt.Int int ->
68 JsExpr $ JS.Int int
70 Opt.Float float ->
71 JsExpr $ JS.Float float
73 Opt.VarLocal name ->
74 JsExpr $ JS.Ref (Name.fromLocal name)
76 Opt.VarGlobal (Opt.Global home name) ->
77 JsExpr $ JS.Ref (Name.fromGlobal home name)
79 Opt.VarEnum (Opt.Global home name) index ->
80 case mode of
81 Name.Debug _ ->
82 JsExpr $ JS.Ref (Name.fromGlobal home name)
84 Name.Prod _ _ ->
85 JsExpr $ JS.Int (Index.toMachine index)
87 Opt.VarBox (Opt.Global home name) ->
88 JsExpr $ JS.Ref $
89 case mode of
90 Name.Debug _ -> Name.fromGlobal home name
91 Name.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
93 Opt.VarCycle home name ->
94 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
96 Opt.VarDebug name home region unhandledValueName ->
97 JsExpr $ generateDebug name home region unhandledValueName
99 Opt.VarKernel home name ->
100 JsExpr $ JS.Ref (Name.fromKernel home name)
102 Opt.List entries ->
103 JsExpr $
104 JS.Call
105 (JS.Ref (Name.fromKernel N.list "fromArray"))
106 [ JS.Array $ map (generateJsExpr mode) entries
107 ]
109 Opt.Function args body ->
110 generateFunction (map Name.fromLocal args) (generate mode body)
112 Opt.Call func args ->
113 JsExpr $ generateCall mode func args
115 Opt.TailCall name args ->
116 JsBlock $ generateTailCall mode name args
118 Opt.If branches final ->
119 generateIf mode branches final
121 Opt.Let def body ->
122 JsBlock $
123 generateDef mode def : codeToStmtList (generate mode body)
125 Opt.Destruct (Opt.Destructor name path) body ->
126 let
127 pathExpr = generatePath mode path
128 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
129 in
130 JsBlock $ pathDef : codeToStmtList (generate mode body)
132 Opt.Case label root decider jumps ->
133 JsBlock $ generateCase mode label root decider jumps
135 Opt.Accessor field ->
136 JsExpr $ JS.Function Nothing [Name.dollar]
137 [ JS.Return $ Just $
138 JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)
139 ]
141 Opt.Access record field ->
142 JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)
144 Opt.Update record fields ->
145 JsExpr $
146 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
147 [ generateJsExpr mode record
148 , generateRecord mode fields
149 ]
151 Opt.Record fields ->
152 JsExpr $ generateRecord mode fields
154 Opt.Unit ->
155 case mode of
156 Name.Debug _ ->
157 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
159 Name.Prod _ _ ->
160 JsExpr $ JS.Int 0
162 Opt.Tuple a b maybeC ->
163 JsExpr $
164 case maybeC of
165 Nothing ->
166 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
167 [ generateJsExpr mode a
168 , generateJsExpr mode b
169 ]
171 Just c ->
172 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
173 [ generateJsExpr mode a
174 , generateJsExpr mode b
175 , generateJsExpr mode c
176 ]
178 Opt.Shader src ->
179 let string = JS.String (Text.encodeUtf8Builder src) in
180 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
184-- CODE CHUNKS
187data Code
188 = JsExpr JS.Expr
189 | JsBlock [JS.Stmt]
192codeToExpr :: Code -> JS.Expr
193codeToExpr code =
194 case code of
195 JsExpr expr ->
196 expr
198 JsBlock [ JS.Return (Just expr) ] ->
199 expr
201 JsBlock stmts ->
202 JS.Call (JS.Function Nothing [] stmts) []
205codeToStmtList :: Code -> [JS.Stmt]
206codeToStmtList code =
207 case code of
208 JsExpr expr ->
209 [ JS.Return (Just expr) ]
211 JsBlock stmts ->
212 stmts
215codeToStmt :: Code -> JS.Stmt
216codeToStmt code =
217 case code of
218 JsExpr expr ->
219 JS.Return (Just expr)
221 JsBlock [stmt] ->
222 stmt
224 JsBlock stmts ->
225 JS.Block stmts
229-- CHARS
232{-# NOINLINE toChar #-}
233toChar :: JS.Expr
234toChar =
235 JS.Ref (Name.fromKernel N.utils "chr")
239-- CTOR
242generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code
243generateCtor mode name index arity =
244 let
245 argNames =
246 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
248 ctorTag =
249 case mode of
250 Name.Debug _ -> JS.String (N.toBuilder name)
251 Name.Prod _ _ -> JS.Int (Index.toMachine index)
252 in
253 generateFunction argNames $ JsExpr $ JS.Object $
254 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
258-- RECORDS
261generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
262generateRecord mode fields =
263 let
264 toPair (field, value) =
265 (Name.fromField mode field, generateJsExpr mode value)
266 in
267 JS.Object (map toPair (Map.toList fields))
271-- DEBUG
274generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
275generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
276 if name /= "crash" then
277 JS.Ref (Name.fromGlobal ModuleName.debug name)
278 else
279 case unhandledValueName of
280 Nothing ->
281 JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $
282 [ JS.String (N.toBuilder home)
283 , regionToJsExpr region
284 ]
286 Just valueName ->
287 JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $
288 [ JS.String (N.toBuilder home)
289 , regionToJsExpr region
290 , JS.Ref (Name.fromLocal valueName)
291 ]
294regionToJsExpr :: R.Region -> JS.Expr
295regionToJsExpr (R.Region start end) =
296 JS.Object
297 [ ( Name.fromLocal "start", positionToJsExpr start )
298 , ( Name.fromLocal "end", positionToJsExpr end )
299 ]
302positionToJsExpr :: R.Position -> JS.Expr
303positionToJsExpr (R.Position line column) =
304 JS.Object
305 [ ( Name.fromLocal "line", JS.Int line )
306 , ( Name.fromLocal "column", JS.Int column )
307 ]
311-- FUNCTION
314generateFunction :: [Name.Name] -> Code -> Code
315generateFunction args body =
316 case IntMap.lookup (length args) funcHelpers of
317 Just helper ->
318 JsExpr $
319 JS.Call helper
320 [ JS.Function Nothing args $
321 codeToStmtList body
322 ]
324 Nothing ->
325 let
326 addArg arg code =
327 JsExpr $ JS.Function Nothing [arg] $
328 codeToStmtList code
329 in
330 foldr addArg body args
333{-# NOINLINE funcHelpers #-}
334funcHelpers :: IntMap.IntMap JS.Expr
335funcHelpers =
336 IntMap.fromList
337 [ (2, JS.Ref (Name.fromLocal "F2"))
338 , (3, JS.Ref (Name.fromLocal "F3"))
339 , (4, JS.Ref (Name.fromLocal "F4"))
340 , (5, JS.Ref (Name.fromLocal "F5"))
341 , (6, JS.Ref (Name.fromLocal "F6"))
342 , (7, JS.Ref (Name.fromLocal "F7"))
343 , (8, JS.Ref (Name.fromLocal "F8"))
344 , (9, JS.Ref (Name.fromLocal "F9"))
345 ]
349-- CALLS
352generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
353generateCall mode func args =
354 case func of
355 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
356 generateCoreCall mode global args
358 Opt.VarBox _ ->
359 case mode of
360 Name.Debug _ ->
361 generateCallHelp mode func args
363 Name.Prod _ _ ->
364 case args of
365 [arg] ->
366 generateJsExpr mode arg
368 _ ->
369 generateCallHelp mode func args
371 _ ->
372 generateCallHelp mode func args
375generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
376generateCallHelp mode func args =
377 generateNormalCall
378 (generateJsExpr mode func)
379 (map (generateJsExpr mode) args)
382generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
383generateGlobalCall home name args =
384 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
387generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
388generateNormalCall func args =
389 case IntMap.lookup (length args) callHelpers of
390 Just helper ->
391 JS.Call helper (func:args)
393 Nothing ->
394 List.foldl' (\f a -> JS.Call f [a]) func args
397{-# NOINLINE callHelpers #-}
398callHelpers :: IntMap.IntMap JS.Expr
399callHelpers =
400 IntMap.fromList
401 [ (2, JS.Ref (Name.fromLocal "A2"))
402 , (3, JS.Ref (Name.fromLocal "A3"))
403 , (4, JS.Ref (Name.fromLocal "A4"))
404 , (5, JS.Ref (Name.fromLocal "A5"))
405 , (6, JS.Ref (Name.fromLocal "A6"))
406 , (7, JS.Ref (Name.fromLocal "A7"))
407 , (8, JS.Ref (Name.fromLocal "A8"))
408 , (9, JS.Ref (Name.fromLocal "A9"))
409 ]
413-- CORE CALLS
416generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
417generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
418 if moduleName == N.basics then
419 generateBasicsCall mode home name args
421 else if moduleName == N.bitwise then
422 generateBitwiseCall home name (map (generateJsExpr mode) args)
424 else if moduleName == N.tuple then
425 generateTupleCall home name (map (generateJsExpr mode) args)
427 else if moduleName == N.jsArray then
428 generateJsArrayCall home name (map (generateJsExpr mode) args)
430 else
431 generateGlobalCall home name (map (generateJsExpr mode) args)
434generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
435generateTupleCall home name args =
436 case args of
437 [value] ->
438 case name of
439 "first" -> JS.Access value (Name.fromLocal "a")
440 "second" -> JS.Access value (Name.fromLocal "b")
441 _ -> generateGlobalCall home name args
443 _ ->
444 generateGlobalCall home name args
447generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
448generateJsArrayCall home name args =
449 case args of
450 [entry] | name == "singleton" -> JS.Array [entry]
451 [index, array] | name == "unsafeGet" -> JS.Index array index
452 _ -> generateGlobalCall home name args
455generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
456generateBitwiseCall home name args =
457 case args of
458 [arg] ->
459 case name of
460 "complement" -> JS.Prefix JS.PrefixBNot arg
461 _ -> generateGlobalCall home name args
463 [left,right] ->
464 case name of
465 "and" -> JS.Infix JS.OpBAnd left right
466 "or" -> JS.Infix JS.OpBOr left right
467 "xor" -> JS.Infix JS.OpBXor left right
468 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
469 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
470 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
471 _ -> generateGlobalCall home name args
473 _ ->
474 generateGlobalCall home name args
477generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
478generateBasicsCall mode home name args =
479 case args of
480 [elmArg] ->
481 let arg = generateJsExpr mode elmArg in
482 case name of
483 "not" -> JS.Prefix JS.PrefixLNot arg
484 "toFloat" -> arg
485 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
486 _ -> generateGlobalCall home name [arg]
488 [elmLeft, elmRight] ->
489 case name of
490 "composeL" -> decomposeL mode elmLeft [elmRight]
491 "composeR" -> decomposeR mode [elmLeft] elmRight
492 "append" -> append mode elmLeft elmRight
493 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
494 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
495 _ ->
496 let
497 left = generateJsExpr mode elmLeft
498 right = generateJsExpr mode elmRight
499 in
500 case name of
501 "add" -> JS.Infix JS.OpAdd left right
502 "sub" -> JS.Infix JS.OpSub left right
503 "mul" -> JS.Infix JS.OpMul left right
504 "fdiv" -> JS.Infix JS.OpDiv left right
505 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
506 "eq" -> equal left right
507 "neq" -> notEqual left right
508 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
509 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
510 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
511 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
512 "or" -> JS.Infix JS.OpLOr left right
513 "and" -> JS.Infix JS.OpLAnd left right
514 "xor" -> JS.Infix JS.OpStrictNEq left right
515 _ -> generateGlobalCall home name [left, right]
517 _ ->
518 generateGlobalCall home name (map (generateJsExpr mode) args)
521equal :: JS.Expr -> JS.Expr -> JS.Expr
522equal left right =
523 if isLiteral left || isLiteral right then
524 strictEq left right
525 else
526 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
529notEqual :: JS.Expr -> JS.Expr -> JS.Expr
530notEqual left right =
531 if isLiteral left || isLiteral right then
532 strictNEq left right
533 else
534 JS.Prefix JS.PrefixLNot $
535 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
538cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
539cmp idealOp backupOp backupInt left right =
540 if isLiteral left || isLiteral right then
541 JS.Infix idealOp left right
542 else
543 JS.Infix backupOp
544 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
545 (JS.Int backupInt)
548isLiteral :: JS.Expr -> Bool
549isLiteral expr =
550 case expr of
551 JS.String _ ->
552 True
554 JS.Float _ ->
555 True
557 JS.Int _ ->
558 True
560 JS.Bool _ ->
561 True
563 _ ->
564 False
567decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
568decomposeL mode expr funcs =
569 case expr of
570 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
571 | home == ModuleName.basics ->
572 decomposeL mode left (func:funcs)
574 _ ->
575 generateJsExpr mode $
576 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
579decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
580decomposeR mode funcs expr =
581 case expr of
582 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
583 | home == ModuleName.basics ->
584 decomposeR mode (func:funcs) right
586 _ ->
587 generateJsExpr mode $
588 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
591apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
592apply func value =
593 case func of
594 Opt.Accessor field ->
595 Opt.Access value field
597 Opt.Call f args ->
598 Opt.Call f (args ++ [value])
600 _ ->
601 Opt.Call func [value]
604append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
605append mode left right =
606 let seqs = generateJsExpr mode left : toSeqs mode right in
607 if any isStringLiteral seqs then
608 foldr1 (JS.Infix JS.OpAdd) seqs
609 else
610 foldr1 jsAppend seqs
613jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
614jsAppend a b =
615 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
618toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
619toSeqs mode expr =
620 case expr of
621 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
622 | home == ModuleName.basics ->
623 generateJsExpr mode left : toSeqs mode right
625 _ ->
626 [generateJsExpr mode expr]
629isStringLiteral :: JS.Expr -> Bool
630isStringLiteral expr =
631 case expr of
632 JS.String _ ->
633 True
635 _ ->
636 False
640-- SIMPLIFY INFIX OPERATORS
643strictEq :: JS.Expr -> JS.Expr -> JS.Expr
644strictEq left right =
645 case left of
646 JS.Int 0 ->
647 JS.Prefix JS.PrefixLNot right
649 JS.Bool bool ->
650 if bool then right else JS.Prefix JS.PrefixLNot right
652 _ ->
653 case right of
654 JS.Int 0 ->
655 JS.Prefix JS.PrefixLNot left
657 JS.Bool bool ->
658 if bool then left else JS.Prefix JS.PrefixLNot left
660 _ ->
661 JS.Infix JS.OpStrictEq left right
664strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
665strictNEq left right =
666 case left of
667 JS.Int 0 ->
668 right
670 JS.Bool bool ->
671 if bool then JS.Prefix JS.PrefixLNot right else right
673 _ ->
674 case right of
675 JS.Int 0 ->
676 left
678 JS.Bool bool ->
679 if bool then JS.Prefix JS.PrefixLNot left else left
681 _ ->
682 JS.Infix JS.OpStrictNEq left right
686-- TAIL CALL
689-- TODO check if JS minifiers collapse unnecessary temporary variables
690--
691generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
692generateTailCall mode name args =
693 let
694 toTempVars (argName, arg) =
695 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
697 toRealVars (argName, _) =
698 JS.ExprStmt $
699 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
700 in
701 JS.Var (map toTempVars args)
702 : map toRealVars args
703 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
707-- DEFINITIONS
710generateDef :: Mode -> Opt.Def -> JS.Stmt
711generateDef mode def =
712 case def of
713 Opt.Def name body ->
714 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
716 Opt.TailDef name argNames body ->
717 let
718 function =
719 JS.Function Nothing (map Name.fromLocal argNames)
720 [ JS.Labelled (Name.fromLocal name) $
721 JS.While (JS.Bool True) $
722 codeToStmt $ generate mode body
723 ]
724 in
725 JS.Var [ (Name.fromLocal name, Just function) ]
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")
897generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
898generateCaseBranch mode label root (test, subTree) =
899 JS.Case
900 (generateCaseValue mode test)
901 (generateDecider mode label root subTree)
904generateCaseValue :: Mode -> DT.Test -> JS.Expr
905generateCaseValue mode test =
906 case test of
907 DT.IsCtor name index _ _ ->
908 case mode of
909 Name.Debug _ -> JS.String (N.toBuilder name)
910 Name.Prod _ _ -> JS.Int (Index.toMachine index)
912 DT.IsInt int ->
913 JS.Int int
915 DT.IsChr char ->
916 JS.String (Text.encodeUtf8Builder char)
918 DT.IsStr string ->
919 JS.String (Text.encodeUtf8Builder string)
921 DT.IsCons ->
922 error "COMPILER BUG - there should never be three tests on a list"
924 DT.IsNil ->
925 error "COMPILER BUG - there should never be three tests on a list"
928generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
929generateCaseTest mode root path exampleTest =
930 let
931 value = pathToJsExpr mode root path
932 in
933 case exampleTest of
934 DT.IsCtor _ _ _ opts ->
935 case mode of
936 Name.Debug _ ->
937 JS.Access value Name.dollar
939 Name.Prod _ _ ->
940 case opts of
941 Can.Normal ->
942 JS.Access value Name.dollar
944 Can.Enum ->
945 value
947 Can.Unbox ->
948 value
950 DT.IsInt _ ->
951 value
953 DT.IsStr _ ->
954 value
956 DT.IsChr _ ->
957 case mode of
958 Name.Debug _ ->
959 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
961 Name.Prod _ _ ->
962 value
964 DT.IsCons ->
965 error "COMPILER BUG - there should never be three tests on a list"
967 DT.IsNil ->
968 error "COMPILER BUG - there should never be three tests on a list"
972-- PATTERN PATHS
975pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
976pathToJsExpr mode root path =
977 case path of
978 DT.Index index subPath ->
979 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
981 DT.Unbox subPath ->
982 case mode of
983 Name.Debug _ ->
984 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
986 Name.Prod _ _ ->
987 pathToJsExpr mode root subPath
989 DT.Empty ->
990 JS.Ref (Name.fromLocal root)
994-- GENERATE MAIN
997generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
998generateMain mode interfaces home main =
999 case main of
1000 Opt.Static ->
1001 JS.Ref (Name.fromKernel N.browser "staticPage")
1002 # JS.Ref (Name.fromGlobal home "main")
1003 # JS.Int 0
1004 # JS.Int 0
1006 Opt.Dynamic decoder msgType ->
1007 JS.Ref (Name.fromGlobal home "main")
1008 # generateJsExpr mode decoder
1009 # toDebugMetadata mode interfaces msgType
1012(#) :: JS.Expr -> JS.Expr -> JS.Expr
1013(#) func arg =
1014 JS.Call func [arg]
1017toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1018toDebugMetadata mode interfaces msgType =
1019 case mode of
1020 Name.Prod _ _ ->
1021 JS.Int 0
1023 Name.Debug _ ->
1024 JS.Json $ Encode.object $
1025 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1026 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))