git.iko.soy/elk
on ca94170 help sign in
elk/compiler/src/Generate/JavaScript/Expression.hs
1047 lines 27 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.Text.Encoding as Text
21import qualified AST.Canonical as Can
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Index as Index
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Name as N
28import qualified Elm.Package as Pkg
29import qualified Elm.Compiler.Version as Version
30import qualified Generate.JavaScript.Builder as JS
31import qualified Generate.JavaScript.Mode as Mode
32import qualified Generate.JavaScript.Name as Name
33import qualified Json.Encode as Encode
34import qualified Optimize.DecisionTree as DT
35import qualified Reporting.Region as R
39-- EXPRESSIONS
42generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
43generateJsExpr mode expression =
44 codeToExpr (generate mode expression)
47generate :: Mode.Mode -> Opt.Expr -> Code
48generate mode expression =
49 case expression of
50 Opt.Bool bool ->
51 JsExpr $ JS.Bool bool
53 Opt.Chr char ->
54 JsExpr $
55 case mode of
56 Mode.Dev _ _ ->
57 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
59 Mode.Prod _ _ ->
60 JS.String (Text.encodeUtf8Builder char)
62 Opt.Str string ->
63 JsExpr $ JS.String (Text.encodeUtf8Builder string)
65 Opt.Int int ->
66 JsExpr $ JS.Int int
68 Opt.Float float ->
69 JsExpr $ JS.Float float
71 Opt.VarLocal name ->
72 JsExpr $ JS.Ref (Name.fromLocal name)
74 Opt.VarGlobal (Opt.Global home name) ->
75 JsExpr $ JS.Ref (Name.fromGlobal home name)
77 Opt.VarEnum (Opt.Global home name) index ->
78 case mode of
79 Mode.Dev _ _ ->
80 JsExpr $ JS.Ref (Name.fromGlobal home name)
82 Mode.Prod _ _ ->
83 JsExpr $ JS.Int (Index.toMachine index)
85 Opt.VarBox (Opt.Global home name) ->
86 JsExpr $ JS.Ref $
87 case mode of
88 Mode.Dev _ _ -> Name.fromGlobal home name
89 Mode.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity
91 Opt.VarCycle home name ->
92 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
94 Opt.VarDebug name home region unhandledValueName ->
95 JsExpr $ generateDebug name home region unhandledValueName
97 Opt.VarKernel home name ->
98 JsExpr $ JS.Ref (Name.fromKernel home name)
100 Opt.List entries ->
101 case entries of
102 [] ->
103 JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")
105 _ ->
106 JsExpr $
107 JS.Call
108 (JS.Ref (Name.fromKernel N.list "fromArray"))
109 [ JS.Array $ map (generateJsExpr mode) entries
110 ]
112 Opt.Function args body ->
113 generateFunction (map Name.fromLocal args) (generate mode body)
115 Opt.Call func args ->
116 JsExpr $ generateCall mode func args
118 Opt.TailCall name args ->
119 JsBlock $ generateTailCall mode name args
121 Opt.If branches final ->
122 generateIf mode branches final
124 Opt.Let def body ->
125 JsBlock $
126 generateDef mode def : codeToStmtList (generate mode body)
128 Opt.Destruct (Opt.Destructor name path) body ->
129 let
130 pathExpr = generatePath mode path
131 pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]
132 in
133 JsBlock $ pathDef : codeToStmtList (generate mode body)
135 Opt.Case label root decider jumps ->
136 JsBlock $ generateCase mode label root decider jumps
138 Opt.Accessor field ->
139 JsExpr $ JS.Function Nothing [Name.dollar]
140 [ JS.Return $ Just $
141 JS.Access (JS.Ref Name.dollar) (generateField mode field)
142 ]
144 Opt.Access record field ->
145 JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)
147 Opt.Update record fields ->
148 JsExpr $
149 JS.Call (JS.Ref (Name.fromKernel N.utils "update"))
150 [ generateJsExpr mode record
151 , generateRecord mode fields
152 ]
154 Opt.Record fields ->
155 JsExpr $ generateRecord mode fields
157 Opt.Unit ->
158 case mode of
159 Mode.Dev _ _ ->
160 JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
162 Mode.Prod _ _ ->
163 JsExpr $ JS.Int 0
165 Opt.Tuple a b maybeC ->
166 JsExpr $
167 case maybeC of
168 Nothing ->
169 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))
170 [ generateJsExpr mode a
171 , generateJsExpr mode b
172 ]
174 Just c ->
175 JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))
176 [ generateJsExpr mode a
177 , generateJsExpr mode b
178 , generateJsExpr mode c
179 ]
181 Opt.Shader src ->
182 let string = JS.String (Text.encodeUtf8Builder src) in
183 JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]
187-- CODE CHUNKS
190data Code
191 = JsExpr JS.Expr
192 | JsBlock [JS.Stmt]
195codeToExpr :: Code -> JS.Expr
196codeToExpr code =
197 case code of
198 JsExpr expr ->
199 expr
201 JsBlock [ JS.Return (Just expr) ] ->
202 expr
204 JsBlock stmts ->
205 JS.Call (JS.Function Nothing [] stmts) []
208codeToStmtList :: Code -> [JS.Stmt]
209codeToStmtList code =
210 case code of
211 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
212 stmts
214 JsExpr expr ->
215 [ JS.Return (Just expr) ]
217 JsBlock stmts ->
218 stmts
221codeToStmt :: Code -> JS.Stmt
222codeToStmt code =
223 case code of
224 JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
225 JS.Block stmts
227 JsExpr expr ->
228 JS.Return (Just expr)
230 JsBlock [stmt] ->
231 stmt
233 JsBlock stmts ->
234 JS.Block stmts
238-- CHARS
241{-# NOINLINE toChar #-}
242toChar :: JS.Expr
243toChar =
244 JS.Ref (Name.fromKernel N.utils "chr")
248-- CTOR
251generateCtor :: Mode.Mode -> N.Name -> Index.ZeroBased -> Int -> Code
252generateCtor mode name index arity =
253 let
254 argNames =
255 Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
257 ctorTag =
258 case mode of
259 Mode.Dev _ _ -> JS.String (N.toBuilder name)
260 Mode.Prod _ _ -> JS.Int (Index.toMachine index)
261 in
262 generateFunction argNames $ JsExpr $ JS.Object $
263 (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
267-- RECORDS
270generateRecord :: Mode.Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
271generateRecord mode fields =
272 let
273 toPair (field, value) =
274 (generateField mode field, generateJsExpr mode value)
275 in
276 JS.Object (map toPair (Map.toList fields))
279generateField :: Mode.Mode -> N.Name -> Name.Name
280generateField mode name =
281 case mode of
282 Mode.Dev _ _ ->
283 Name.fromLocal name
285 Mode.Prod _ fields ->
286 fields ! name
291-- DEBUG
294generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
295generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
296 if name /= "todo" then
297 JS.Ref (Name.fromGlobal ModuleName.debug name)
298 else
299 case unhandledValueName of
300 Nothing ->
301 JS.Call (JS.Ref (Name.fromKernel N.debug "todo")) $
302 [ JS.String (N.toBuilder home)
303 , regionToJsExpr region
304 ]
306 Just valueName ->
307 JS.Call (JS.Ref (Name.fromKernel N.debug "todoCase")) $
308 [ JS.String (N.toBuilder home)
309 , regionToJsExpr region
310 , JS.Ref (Name.fromLocal valueName)
311 ]
314regionToJsExpr :: R.Region -> JS.Expr
315regionToJsExpr (R.Region start end) =
316 JS.Object
317 [ ( Name.fromLocal "start", positionToJsExpr start )
318 , ( Name.fromLocal "end", positionToJsExpr end )
319 ]
322positionToJsExpr :: R.Position -> JS.Expr
323positionToJsExpr (R.Position line column) =
324 JS.Object
325 [ ( Name.fromLocal "line", JS.Int line )
326 , ( Name.fromLocal "column", JS.Int column )
327 ]
331-- FUNCTION
334generateFunction :: [Name.Name] -> Code -> Code
335generateFunction args body =
336 case IntMap.lookup (length args) funcHelpers of
337 Just helper ->
338 JsExpr $
339 JS.Call helper
340 [ JS.Function Nothing args $
341 codeToStmtList body
342 ]
344 Nothing ->
345 let
346 addArg arg code =
347 JsExpr $ JS.Function Nothing [arg] $
348 codeToStmtList code
349 in
350 foldr addArg body args
353{-# NOINLINE funcHelpers #-}
354funcHelpers :: IntMap.IntMap JS.Expr
355funcHelpers =
356 IntMap.fromList $
357 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
361-- CALLS
364generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
365generateCall mode func args =
366 case func of
367 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
368 generateCoreCall mode global args
370 Opt.VarBox _ ->
371 case mode of
372 Mode.Dev _ _ ->
373 generateCallHelp mode func args
375 Mode.Prod _ _ ->
376 case args of
377 [arg] ->
378 generateJsExpr mode arg
380 _ ->
381 generateCallHelp mode func args
383 _ ->
384 generateCallHelp mode func args
387generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
388generateCallHelp mode func args =
389 generateNormalCall
390 (generateJsExpr mode func)
391 (map (generateJsExpr mode) args)
394generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
395generateGlobalCall home name args =
396 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
399generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
400generateNormalCall func args =
401 case IntMap.lookup (length args) callHelpers of
402 Just helper ->
403 JS.Call helper (func:args)
405 Nothing ->
406 List.foldl' (\f a -> JS.Call f [a]) func args
409{-# NOINLINE callHelpers #-}
410callHelpers :: IntMap.IntMap JS.Expr
411callHelpers =
412 IntMap.fromList $
413 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
417-- CORE CALLS
420generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
421generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
422 if moduleName == N.basics then
423 generateBasicsCall mode home name args
425 else if moduleName == N.bitwise then
426 generateBitwiseCall home name (map (generateJsExpr mode) args)
428 else if moduleName == N.tuple then
429 generateTupleCall home name (map (generateJsExpr mode) args)
431 else if moduleName == N.jsArray then
432 generateJsArrayCall home name (map (generateJsExpr mode) args)
434 else
435 generateGlobalCall home name (map (generateJsExpr mode) args)
438generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
439generateTupleCall home name args =
440 case args of
441 [value] ->
442 case name of
443 "first" -> JS.Access value (Name.fromLocal "a")
444 "second" -> JS.Access value (Name.fromLocal "b")
445 _ -> generateGlobalCall home name args
447 _ ->
448 generateGlobalCall home name args
451generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
452generateJsArrayCall home name args =
453 case args of
454 [entry] | name == "singleton" -> JS.Array [entry]
455 [index, array] | name == "unsafeGet" -> JS.Index array index
456 _ -> generateGlobalCall home name args
459generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
460generateBitwiseCall home name args =
461 case args of
462 [arg] ->
463 case name of
464 "complement" -> JS.Prefix JS.PrefixBNot arg
465 _ -> generateGlobalCall home name args
467 [left,right] ->
468 case name of
469 "and" -> JS.Infix JS.OpBAnd left right
470 "or" -> JS.Infix JS.OpBOr left right
471 "xor" -> JS.Infix JS.OpBXor left right
472 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
473 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
474 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
475 _ -> generateGlobalCall home name args
477 _ ->
478 generateGlobalCall home name args
481generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
482generateBasicsCall mode home name args =
483 case args of
484 [elmArg] ->
485 let arg = generateJsExpr mode elmArg in
486 case name of
487 "not" -> JS.Prefix JS.PrefixLNot arg
488 "negate" -> JS.Prefix JS.PrefixMinus arg
489 "toFloat" -> arg
490 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
491 _ -> generateGlobalCall home name [arg]
493 [elmLeft, elmRight] ->
494 case name of
495 "composeL" -> decomposeL mode elmLeft [elmRight]
496 "composeR" -> decomposeR mode [elmLeft] elmRight
497 "append" -> append mode elmLeft elmRight
498 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
499 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
500 _ ->
501 let
502 left = generateJsExpr mode elmLeft
503 right = generateJsExpr mode elmRight
504 in
505 case name of
506 "add" -> JS.Infix JS.OpAdd left right
507 "sub" -> JS.Infix JS.OpSub left right
508 "mul" -> JS.Infix JS.OpMul left right
509 "fdiv" -> JS.Infix JS.OpDiv left right
510 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
511 "eq" -> equal left right
512 "neq" -> notEqual left right
513 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
514 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
515 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
516 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
517 "or" -> JS.Infix JS.OpLOr left right
518 "and" -> JS.Infix JS.OpLAnd left right
519 "xor" -> JS.Infix JS.OpStrictNEq left right
520 "remainderBy" -> JS.Infix JS.OpMod right left
521 _ -> generateGlobalCall home name [left, right]
523 _ ->
524 generateGlobalCall home name (map (generateJsExpr mode) args)
527equal :: JS.Expr -> JS.Expr -> JS.Expr
528equal left right =
529 if isLiteral left || isLiteral right then
530 strictEq left right
531 else
532 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
535notEqual :: JS.Expr -> JS.Expr -> JS.Expr
536notEqual left right =
537 if isLiteral left || isLiteral right then
538 strictNEq left right
539 else
540 JS.Prefix JS.PrefixLNot $
541 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
544cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
545cmp idealOp backupOp backupInt left right =
546 if isLiteral left || isLiteral right then
547 JS.Infix idealOp left right
548 else
549 JS.Infix backupOp
550 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
551 (JS.Int backupInt)
554isLiteral :: JS.Expr -> Bool
555isLiteral expr =
556 case expr of
557 JS.String _ ->
558 True
560 JS.Float _ ->
561 True
563 JS.Int _ ->
564 True
566 JS.Bool _ ->
567 True
569 _ ->
570 False
573decomposeL :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
574decomposeL mode expr funcs =
575 case expr of
576 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
577 | home == ModuleName.basics ->
578 decomposeL mode left (func:funcs)
580 _ ->
581 generateJsExpr mode $
582 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
585decomposeR :: Mode.Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
586decomposeR mode funcs expr =
587 case expr of
588 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
589 | home == ModuleName.basics ->
590 decomposeR mode (func:funcs) right
592 _ ->
593 generateJsExpr mode $
594 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
597apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
598apply func value =
599 case func of
600 Opt.Accessor field ->
601 Opt.Access value field
603 Opt.Call f args ->
604 Opt.Call f (args ++ [value])
606 _ ->
607 Opt.Call func [value]
610append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
611append mode left right =
612 let seqs = generateJsExpr mode left : toSeqs mode right in
613 if any isStringLiteral seqs then
614 foldr1 (JS.Infix JS.OpAdd) seqs
615 else
616 foldr1 jsAppend seqs
619jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
620jsAppend a b =
621 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
624toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
625toSeqs mode expr =
626 case expr of
627 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
628 | home == ModuleName.basics ->
629 generateJsExpr mode left : toSeqs mode right
631 _ ->
632 [generateJsExpr mode expr]
635isStringLiteral :: JS.Expr -> Bool
636isStringLiteral expr =
637 case expr of
638 JS.String _ ->
639 True
641 _ ->
642 False
646-- SIMPLIFY INFIX OPERATORS
649strictEq :: JS.Expr -> JS.Expr -> JS.Expr
650strictEq left right =
651 case left of
652 JS.Int 0 ->
653 JS.Prefix JS.PrefixLNot right
655 JS.Bool bool ->
656 if bool then right else JS.Prefix JS.PrefixLNot right
658 _ ->
659 case right of
660 JS.Int 0 ->
661 JS.Prefix JS.PrefixLNot left
663 JS.Bool bool ->
664 if bool then left else JS.Prefix JS.PrefixLNot left
666 _ ->
667 JS.Infix JS.OpStrictEq left right
670strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
671strictNEq left right =
672 case left of
673 JS.Int 0 ->
674 right
676 JS.Bool bool ->
677 if bool then JS.Prefix JS.PrefixLNot right else right
679 _ ->
680 case right of
681 JS.Int 0 ->
682 left
684 JS.Bool bool ->
685 if bool then JS.Prefix JS.PrefixLNot left else left
687 _ ->
688 JS.Infix JS.OpStrictNEq left right
692-- TAIL CALL
695-- TODO check if JS minifiers collapse unnecessary temporary variables
696--
697generateTailCall :: Mode.Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
698generateTailCall mode name args =
699 let
700 toTempVars (argName, arg) =
701 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
703 toRealVars (argName, _) =
704 JS.ExprStmt $
705 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
706 in
707 JS.Var (map toTempVars args)
708 : map toRealVars args
709 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
713-- DEFINITIONS
716generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
717generateDef mode def =
718 case def of
719 Opt.Def name body ->
720 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
722 Opt.TailDef name argNames body ->
723 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
726generateTailDef :: Mode.Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
727generateTailDef mode name argNames body =
728 generateFunction (map Name.fromLocal argNames) $ JsBlock $
729 [ JS.Labelled (Name.fromLocal name) $
730 JS.While (JS.Bool True) $
731 codeToStmt $ generate mode body
732 ]
736-- PATHS
739generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
740generatePath mode path =
741 case path of
742 Opt.Index index subPath ->
743 JS.Access (generatePath mode subPath) (Name.fromIndex index)
745 Opt.Root name ->
746 JS.Ref (Name.fromLocal name)
748 Opt.Field field subPath ->
749 JS.Access (generatePath mode subPath) (generateField mode field)
751 Opt.Unbox subPath ->
752 case mode of
753 Mode.Dev _ _ ->
754 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
756 Mode.Prod _ _ ->
757 generatePath mode subPath
761-- GENERATE IFS
764generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
765generateIf mode givenBranches givenFinal =
766 let
767 (branches, final) =
768 crushIfs givenBranches givenFinal
770 convertBranch (condition, expr) =
771 ( generateJsExpr mode condition
772 , generate mode expr
773 )
775 branchExprs = map convertBranch branches
776 finalCode = generate mode final
777 in
778 if isBlock finalCode || any (isBlock . snd) branchExprs then
779 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
780 else
781 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
784addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
785addExprIf (condition, branch) final =
786 JS.If condition (codeToExpr branch) final
789addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
790addStmtIf (condition, branch) final =
791 JS.IfStmt condition (codeToStmt branch) final
794isBlock :: Code -> Bool
795isBlock code =
796 case code of
797 JsBlock _ -> True
798 JsExpr _ -> False
801crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
802crushIfs branches final =
803 crushIfsHelp [] branches final
806crushIfsHelp
807 :: [(Opt.Expr, Opt.Expr)]
808 -> [(Opt.Expr, Opt.Expr)]
809 -> Opt.Expr
810 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
811crushIfsHelp visitedBranches unvisitedBranches final =
812 case unvisitedBranches of
813 [] ->
814 case final of
815 Opt.If subBranches subFinal ->
816 crushIfsHelp visitedBranches subBranches subFinal
818 _ ->
819 (reverse visitedBranches, final)
821 visiting : unvisited ->
822 crushIfsHelp (visiting : visitedBranches) unvisited final
826-- CASE EXPRESSIONS
829generateCase :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
830generateCase mode label root decider jumps =
831 foldr (goto mode label) (generateDecider mode label root decider) jumps
834goto :: Mode.Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
835goto mode label (index, branch) stmts =
836 let
837 labeledDeciderStmt =
838 JS.Labelled
839 (Name.makeLabel label index)
840 (JS.While (JS.Bool True) (JS.Block stmts))
841 in
842 labeledDeciderStmt : codeToStmtList (generate mode branch)
845generateDecider :: Mode.Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
846generateDecider mode label root decisionTree =
847 case decisionTree of
848 Opt.Leaf (Opt.Inline branch) ->
849 codeToStmtList (generate mode branch)
851 Opt.Leaf (Opt.Jump index) ->
852 [ JS.Break (Just (Name.makeLabel label index)) ]
854 Opt.Chain testChain success failure ->
855 [ JS.IfStmt
856 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
857 (JS.Block $ generateDecider mode label root success)
858 (JS.Block $ generateDecider mode label root failure)
859 ]
861 Opt.FanOut path edges fallback ->
862 [ JS.Switch
863 (generateCaseTest mode root path (fst (head edges)))
864 ( foldr
865 (\edge cases -> generateCaseBranch mode label root edge : cases)
866 [ JS.Default (generateDecider mode label root fallback) ]
867 edges
868 )
869 ]
872generateIfTest :: Mode.Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
873generateIfTest mode root (path, test) =
874 let
875 value = pathToJsExpr mode root path
876 in
877 case test of
878 DT.IsCtor name index _ _ ->
879 strictEq (JS.Access value Name.dollar) $
880 case mode of
881 Mode.Dev _ _ -> JS.String (N.toBuilder name)
882 Mode.Prod _ _ -> JS.Int (Index.toMachine index)
884 DT.IsInt int ->
885 strictEq value (JS.Int int)
887 DT.IsChr char ->
888 strictEq (JS.String (Text.encodeUtf8Builder char)) $
889 case mode of
890 Mode.Dev _ _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
891 Mode.Prod _ _ -> value
893 DT.IsStr string ->
894 strictEq value (JS.String (Text.encodeUtf8Builder string))
896 DT.IsCons ->
897 JS.Access value (Name.fromLocal "b")
899 DT.IsNil ->
900 JS.Prefix JS.PrefixLNot $
901 JS.Access value (Name.fromLocal "b")
903 DT.IsTuple ->
904 error "COMPILER BUG - there should never be tests on a tuple"
908generateCaseBranch :: Mode.Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
909generateCaseBranch mode label root (test, subTree) =
910 JS.Case
911 (generateCaseValue mode test)
912 (generateDecider mode label root subTree)
915generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
916generateCaseValue mode test =
917 case test of
918 DT.IsCtor name index _ _ ->
919 case mode of
920 Mode.Dev _ _ -> JS.String (N.toBuilder name)
921 Mode.Prod _ _ -> JS.Int (Index.toMachine index)
923 DT.IsInt int ->
924 JS.Int int
926 DT.IsChr char ->
927 JS.String (Text.encodeUtf8Builder char)
929 DT.IsStr string ->
930 JS.String (Text.encodeUtf8Builder string)
932 DT.IsCons ->
933 error "COMPILER BUG - there should never be three tests on a list"
935 DT.IsNil ->
936 error "COMPILER BUG - there should never be three tests on a list"
938 DT.IsTuple ->
939 error "COMPILER BUG - there should never be three tests on a tuple"
942generateCaseTest :: Mode.Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
943generateCaseTest mode root path exampleTest =
944 let
945 value = pathToJsExpr mode root path
946 in
947 case exampleTest of
948 DT.IsCtor _ _ _ opts ->
949 case mode of
950 Mode.Dev _ _ ->
951 JS.Access value Name.dollar
953 Mode.Prod _ _ ->
954 case opts of
955 Can.Normal ->
956 JS.Access value Name.dollar
958 Can.Enum ->
959 value
961 Can.Unbox ->
962 value
964 DT.IsInt _ ->
965 value
967 DT.IsStr _ ->
968 value
970 DT.IsChr _ ->
971 case mode of
972 Mode.Dev _ _ ->
973 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
975 Mode.Prod _ _ ->
976 value
978 DT.IsCons ->
979 error "COMPILER BUG - there should never be three tests on a list"
981 DT.IsNil ->
982 error "COMPILER BUG - there should never be three tests on a list"
984 DT.IsTuple ->
985 error "COMPILER BUG - there should never be three tests on a list"
989-- PATTERN PATHS
992pathToJsExpr :: Mode.Mode -> N.Name -> DT.Path -> JS.Expr
993pathToJsExpr mode root path =
994 case path of
995 DT.Index index subPath ->
996 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
998 DT.Unbox subPath ->
999 case mode of
1000 Mode.Dev _ _ ->
1001 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
1003 Mode.Prod _ _ ->
1004 pathToJsExpr mode root subPath
1006 DT.Empty ->
1007 JS.Ref (Name.fromLocal root)
1011-- GENERATE MAIN
1014generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1015generateMain mode home main =
1016 case main of
1017 Opt.Static ->
1018 JS.Ref (Name.fromKernel N.virtualDom "init")
1019 # JS.Ref (Name.fromGlobal home "main")
1020 # JS.Int 0
1021 # JS.Int 0
1023 Opt.Dynamic msgType decoder ->
1024 JS.Ref (Name.fromGlobal home "main")
1025 # generateJsExpr mode decoder
1026 # toDebugMetadata mode msgType
1029(#) :: JS.Expr -> JS.Expr -> JS.Expr
1030(#) func arg =
1031 JS.Call func [arg]
1034toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
1035toDebugMetadata mode msgType =
1036 case mode of
1037 Mode.Prod _ _ ->
1038 JS.Int 0
1040 Mode.Dev _ Nothing ->
1041 JS.Int 0
1043 Mode.Dev _ (Just interfaces) ->
1044 JS.Json $ Encode.object $
1045 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1046 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))