git.iko.soy/elk
on bf63cb8 help sign in
elk/src/Generate/JavaScript/Expression.hs
1038 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.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 JS.Var [ (Name.fromLocal name, Just (generateTailDef mode name argNames body)) ]
720generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> JS.Expr
721generateTailDef mode name argNames body =
722 JS.Function Nothing (map Name.fromLocal argNames)
723 [ JS.Labelled (Name.fromLocal name) $
724 JS.While (JS.Bool True) $
725 codeToStmt $ generate mode body
726 ]
730-- PATHS
733generatePath :: Mode -> Opt.Path -> JS.Expr
734generatePath mode path =
735 case path of
736 Opt.Index index subPath ->
737 JS.Access (generatePath mode subPath) (Name.fromIndex index)
739 Opt.Root name ->
740 JS.Ref (Name.fromLocal name)
742 Opt.Field field subPath ->
743 JS.Access (generatePath mode subPath) (Name.fromField mode field)
745 Opt.Unbox subPath ->
746 case mode of
747 Name.Debug _ ->
748 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
750 Name.Prod _ _ ->
751 generatePath mode subPath
755-- GENERATE IFS
758generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
759generateIf mode givenBranches givenFinal =
760 let
761 (branches, final) =
762 crushIfs givenBranches givenFinal
764 convertBranch (condition, expr) =
765 ( generateJsExpr mode condition
766 , generate mode expr
767 )
769 branchExprs = map convertBranch branches
770 finalCode = generate mode final
771 in
772 if isBlock finalCode || any (isBlock . snd) branchExprs then
773 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
774 else
775 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
778addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
779addExprIf (condition, branch) final =
780 JS.If condition (codeToExpr branch) final
783addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
784addStmtIf (condition, branch) final =
785 JS.IfStmt condition (codeToStmt branch) final
788isBlock :: Code -> Bool
789isBlock code =
790 case code of
791 JsBlock _ -> True
792 JsExpr _ -> False
795crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
796crushIfs branches final =
797 crushIfsHelp [] branches final
800crushIfsHelp
801 :: [(Opt.Expr, Opt.Expr)]
802 -> [(Opt.Expr, Opt.Expr)]
803 -> Opt.Expr
804 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
805crushIfsHelp visitedBranches unvisitedBranches final =
806 case unvisitedBranches of
807 [] ->
808 case final of
809 Opt.If subBranches subFinal ->
810 crushIfsHelp visitedBranches subBranches subFinal
812 _ ->
813 (reverse visitedBranches, final)
815 visiting : unvisited ->
816 crushIfsHelp (visiting : visitedBranches) unvisited final
820-- CASE EXPRESSIONS
823generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
824generateCase mode label root decider jumps =
825 foldr (goto mode label) (generateDecider mode label root decider) jumps
828goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
829goto mode label (index, branch) stmts =
830 let
831 labeledDeciderStmt =
832 JS.Labelled
833 (Name.makeLabel label index)
834 (JS.While (JS.Bool True) (JS.Block stmts))
835 in
836 labeledDeciderStmt : codeToStmtList (generate mode branch)
839generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
840generateDecider mode label root decisionTree =
841 case decisionTree of
842 Opt.Leaf (Opt.Inline branch) ->
843 codeToStmtList (generate mode branch)
845 Opt.Leaf (Opt.Jump index) ->
846 [ JS.Break (Just (Name.makeLabel label index)) ]
848 Opt.Chain testChain success failure ->
849 [ JS.IfStmt
850 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
851 (JS.Block $ generateDecider mode label root success)
852 (JS.Block $ generateDecider mode label root failure)
853 ]
855 Opt.FanOut path edges fallback ->
856 [ JS.Switch
857 (generateCaseTest mode root path (fst (head edges)))
858 ( foldr
859 (\edge cases -> generateCaseBranch mode label root edge : cases)
860 [ JS.Default (generateDecider mode label root fallback) ]
861 edges
862 )
863 ]
866generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
867generateIfTest mode root (path, test) =
868 let
869 value = pathToJsExpr mode root path
870 in
871 case test of
872 DT.IsCtor name index _ _ ->
873 strictEq (JS.Access value Name.dollar) $
874 case mode of
875 Name.Debug _ -> JS.String (N.toBuilder name)
876 Name.Prod _ _ -> JS.Int (Index.toMachine index)
878 DT.IsInt int ->
879 strictEq value (JS.Int int)
881 DT.IsChr char ->
882 strictEq (JS.String (Text.encodeUtf8Builder char)) $
883 case mode of
884 Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
885 Name.Prod _ _ -> value
887 DT.IsStr string ->
888 strictEq value (JS.String (Text.encodeUtf8Builder string))
890 DT.IsCons ->
891 JS.Access value (Name.fromLocal "b")
893 DT.IsNil ->
894 JS.Prefix JS.PrefixLNot $
895 JS.Access value (Name.fromLocal "b")
897 DT.IsTuple ->
898 error "COMPILER BUG - there should never be tests on a tuple"
902generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
903generateCaseBranch mode label root (test, subTree) =
904 JS.Case
905 (generateCaseValue mode test)
906 (generateDecider mode label root subTree)
909generateCaseValue :: Mode -> DT.Test -> JS.Expr
910generateCaseValue mode test =
911 case test of
912 DT.IsCtor name index _ _ ->
913 case mode of
914 Name.Debug _ -> JS.String (N.toBuilder name)
915 Name.Prod _ _ -> JS.Int (Index.toMachine index)
917 DT.IsInt int ->
918 JS.Int int
920 DT.IsChr char ->
921 JS.String (Text.encodeUtf8Builder char)
923 DT.IsStr string ->
924 JS.String (Text.encodeUtf8Builder string)
926 DT.IsCons ->
927 error "COMPILER BUG - there should never be three tests on a list"
929 DT.IsNil ->
930 error "COMPILER BUG - there should never be three tests on a list"
932 DT.IsTuple ->
933 error "COMPILER BUG - there should never be three tests on a tuple"
936generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
937generateCaseTest mode root path exampleTest =
938 let
939 value = pathToJsExpr mode root path
940 in
941 case exampleTest of
942 DT.IsCtor _ _ _ opts ->
943 case mode of
944 Name.Debug _ ->
945 JS.Access value Name.dollar
947 Name.Prod _ _ ->
948 case opts of
949 Can.Normal ->
950 JS.Access value Name.dollar
952 Can.Enum ->
953 value
955 Can.Unbox ->
956 value
958 DT.IsInt _ ->
959 value
961 DT.IsStr _ ->
962 value
964 DT.IsChr _ ->
965 case mode of
966 Name.Debug _ ->
967 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
969 Name.Prod _ _ ->
970 value
972 DT.IsCons ->
973 error "COMPILER BUG - there should never be three tests on a list"
975 DT.IsNil ->
976 error "COMPILER BUG - there should never be three tests on a list"
978 DT.IsTuple ->
979 error "COMPILER BUG - there should never be three tests on a list"
983-- PATTERN PATHS
986pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
987pathToJsExpr mode root path =
988 case path of
989 DT.Index index subPath ->
990 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
992 DT.Unbox subPath ->
993 case mode of
994 Name.Debug _ ->
995 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
997 Name.Prod _ _ ->
998 pathToJsExpr mode root subPath
1000 DT.Empty ->
1001 JS.Ref (Name.fromLocal root)
1005-- GENERATE MAIN
1008generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1009generateMain mode interfaces home main =
1010 case main of
1011 Opt.Static ->
1012 JS.Ref (Name.fromKernel N.browser "staticPage")
1013 # JS.Ref (Name.fromGlobal home "main")
1014 # JS.Int 0
1015 # JS.Int 0
1017 Opt.Dynamic decoder msgType ->
1018 JS.Ref (Name.fromGlobal home "main")
1019 # generateJsExpr mode decoder
1020 # toDebugMetadata mode interfaces msgType
1023(#) :: JS.Expr -> JS.Expr -> JS.Expr
1024(#) func arg =
1025 JS.Call func [arg]
1028toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1029toDebugMetadata mode interfaces msgType =
1030 case mode of
1031 Name.Prod _ _ ->
1032 JS.Int 0
1034 Name.Debug _ ->
1035 JS.Json $ Encode.object $
1036 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1037 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))