git.iko.soy/elk
on c84d2f5 help sign in
elk/src/Generate/JavaScript/Expression.hs
1036 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 "toFloat" -> arg
483 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
484 _ -> generateGlobalCall home name [arg]
486 [elmLeft, elmRight] ->
487 case name of
488 "composeL" -> decomposeL mode elmLeft [elmRight]
489 "composeR" -> decomposeR mode [elmLeft] elmRight
490 "append" -> append mode elmLeft elmRight
491 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
492 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
493 _ ->
494 let
495 left = generateJsExpr mode elmLeft
496 right = generateJsExpr mode elmRight
497 in
498 case name of
499 "add" -> JS.Infix JS.OpAdd left right
500 "sub" -> JS.Infix JS.OpSub left right
501 "mul" -> JS.Infix JS.OpMul left right
502 "fdiv" -> JS.Infix JS.OpDiv left right
503 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
504 "eq" -> equal left right
505 "neq" -> notEqual left right
506 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
507 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
508 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
509 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
510 "or" -> JS.Infix JS.OpLOr left right
511 "and" -> JS.Infix JS.OpLAnd left right
512 "xor" -> JS.Infix JS.OpStrictNEq left right
513 _ -> generateGlobalCall home name [left, right]
515 _ ->
516 generateGlobalCall home name (map (generateJsExpr mode) args)
519equal :: JS.Expr -> JS.Expr -> JS.Expr
520equal left right =
521 if isLiteral left || isLiteral right then
522 strictEq left right
523 else
524 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
527notEqual :: JS.Expr -> JS.Expr -> JS.Expr
528notEqual left right =
529 if isLiteral left || isLiteral right then
530 strictNEq left right
531 else
532 JS.Prefix JS.PrefixLNot $
533 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
536cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
537cmp idealOp backupOp backupInt left right =
538 if isLiteral left || isLiteral right then
539 JS.Infix idealOp left right
540 else
541 JS.Infix backupOp
542 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
543 (JS.Int backupInt)
546isLiteral :: JS.Expr -> Bool
547isLiteral expr =
548 case expr of
549 JS.String _ ->
550 True
552 JS.Float _ ->
553 True
555 JS.Int _ ->
556 True
558 JS.Bool _ ->
559 True
561 _ ->
562 False
565decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
566decomposeL mode expr funcs =
567 case expr of
568 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
569 | home == ModuleName.basics ->
570 decomposeL mode left (func:funcs)
572 _ ->
573 generateJsExpr mode $
574 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
577decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
578decomposeR mode funcs expr =
579 case expr of
580 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
581 | home == ModuleName.basics ->
582 decomposeR mode (func:funcs) right
584 _ ->
585 generateJsExpr mode $
586 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
589apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
590apply func value =
591 case func of
592 Opt.Accessor field ->
593 Opt.Access value field
595 Opt.Call f args ->
596 Opt.Call f (args ++ [value])
598 _ ->
599 Opt.Call func [value]
602append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
603append mode left right =
604 let seqs = generateJsExpr mode left : toSeqs mode right in
605 if any isStringLiteral seqs then
606 foldr1 (JS.Infix JS.OpAdd) seqs
607 else
608 foldr1 jsAppend seqs
611jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
612jsAppend a b =
613 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
616toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
617toSeqs mode expr =
618 case expr of
619 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
620 | home == ModuleName.basics ->
621 generateJsExpr mode left : toSeqs mode right
623 _ ->
624 [generateJsExpr mode expr]
627isStringLiteral :: JS.Expr -> Bool
628isStringLiteral expr =
629 case expr of
630 JS.String _ ->
631 True
633 _ ->
634 False
638-- SIMPLIFY INFIX OPERATORS
641strictEq :: JS.Expr -> JS.Expr -> JS.Expr
642strictEq left right =
643 case left of
644 JS.Int 0 ->
645 JS.Prefix JS.PrefixLNot right
647 JS.Bool bool ->
648 if bool then right else JS.Prefix JS.PrefixLNot right
650 _ ->
651 case right of
652 JS.Int 0 ->
653 JS.Prefix JS.PrefixLNot left
655 JS.Bool bool ->
656 if bool then left else JS.Prefix JS.PrefixLNot left
658 _ ->
659 JS.Infix JS.OpStrictEq left right
662strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
663strictNEq left right =
664 case left of
665 JS.Int 0 ->
666 right
668 JS.Bool bool ->
669 if bool then JS.Prefix JS.PrefixLNot right else right
671 _ ->
672 case right of
673 JS.Int 0 ->
674 left
676 JS.Bool bool ->
677 if bool then JS.Prefix JS.PrefixLNot left else left
679 _ ->
680 JS.Infix JS.OpStrictNEq left right
684-- TAIL CALL
687-- TODO check if JS minifiers collapse unnecessary temporary variables
688--
689generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
690generateTailCall mode name args =
691 let
692 toTempVars (argName, arg) =
693 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
695 toRealVars (argName, _) =
696 JS.ExprStmt $
697 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
698 in
699 JS.Var (map toTempVars args)
700 : map toRealVars args
701 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
705-- DEFINITIONS
708generateDef :: Mode -> Opt.Def -> JS.Stmt
709generateDef mode def =
710 case def of
711 Opt.Def name body ->
712 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
714 Opt.TailDef name argNames body ->
715 JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
718generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code
719generateTailDef mode name argNames body =
720 generateFunction (map Name.fromLocal argNames) $ JsBlock $
721 [ JS.Labelled (Name.fromLocal name) $
722 JS.While (JS.Bool True) $
723 codeToStmt $ generate mode body
724 ]
728-- PATHS
731generatePath :: Mode -> Opt.Path -> JS.Expr
732generatePath mode path =
733 case path of
734 Opt.Index index subPath ->
735 JS.Access (generatePath mode subPath) (Name.fromIndex index)
737 Opt.Root name ->
738 JS.Ref (Name.fromLocal name)
740 Opt.Field field subPath ->
741 JS.Access (generatePath mode subPath) (Name.fromField mode field)
743 Opt.Unbox subPath ->
744 case mode of
745 Name.Debug _ ->
746 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
748 Name.Prod _ _ ->
749 generatePath mode subPath
753-- GENERATE IFS
756generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
757generateIf mode givenBranches givenFinal =
758 let
759 (branches, final) =
760 crushIfs givenBranches givenFinal
762 convertBranch (condition, expr) =
763 ( generateJsExpr mode condition
764 , generate mode expr
765 )
767 branchExprs = map convertBranch branches
768 finalCode = generate mode final
769 in
770 if isBlock finalCode || any (isBlock . snd) branchExprs then
771 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
772 else
773 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
776addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
777addExprIf (condition, branch) final =
778 JS.If condition (codeToExpr branch) final
781addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
782addStmtIf (condition, branch) final =
783 JS.IfStmt condition (codeToStmt branch) final
786isBlock :: Code -> Bool
787isBlock code =
788 case code of
789 JsBlock _ -> True
790 JsExpr _ -> False
793crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
794crushIfs branches final =
795 crushIfsHelp [] branches final
798crushIfsHelp
799 :: [(Opt.Expr, Opt.Expr)]
800 -> [(Opt.Expr, Opt.Expr)]
801 -> Opt.Expr
802 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
803crushIfsHelp visitedBranches unvisitedBranches final =
804 case unvisitedBranches of
805 [] ->
806 case final of
807 Opt.If subBranches subFinal ->
808 crushIfsHelp visitedBranches subBranches subFinal
810 _ ->
811 (reverse visitedBranches, final)
813 visiting : unvisited ->
814 crushIfsHelp (visiting : visitedBranches) unvisited final
818-- CASE EXPRESSIONS
821generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
822generateCase mode label root decider jumps =
823 foldr (goto mode label) (generateDecider mode label root decider) jumps
826goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
827goto mode label (index, branch) stmts =
828 let
829 labeledDeciderStmt =
830 JS.Labelled
831 (Name.makeLabel label index)
832 (JS.While (JS.Bool True) (JS.Block stmts))
833 in
834 labeledDeciderStmt : codeToStmtList (generate mode branch)
837generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
838generateDecider mode label root decisionTree =
839 case decisionTree of
840 Opt.Leaf (Opt.Inline branch) ->
841 codeToStmtList (generate mode branch)
843 Opt.Leaf (Opt.Jump index) ->
844 [ JS.Break (Just (Name.makeLabel label index)) ]
846 Opt.Chain testChain success failure ->
847 [ JS.IfStmt
848 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
849 (JS.Block $ generateDecider mode label root success)
850 (JS.Block $ generateDecider mode label root failure)
851 ]
853 Opt.FanOut path edges fallback ->
854 [ JS.Switch
855 (generateCaseTest mode root path (fst (head edges)))
856 ( foldr
857 (\edge cases -> generateCaseBranch mode label root edge : cases)
858 [ JS.Default (generateDecider mode label root fallback) ]
859 edges
860 )
861 ]
864generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
865generateIfTest mode root (path, test) =
866 let
867 value = pathToJsExpr mode root path
868 in
869 case test of
870 DT.IsCtor name index _ _ ->
871 strictEq (JS.Access value Name.dollar) $
872 case mode of
873 Name.Debug _ -> JS.String (N.toBuilder name)
874 Name.Prod _ _ -> JS.Int (Index.toMachine index)
876 DT.IsInt int ->
877 strictEq value (JS.Int int)
879 DT.IsChr char ->
880 strictEq (JS.String (Text.encodeUtf8Builder char)) $
881 case mode of
882 Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
883 Name.Prod _ _ -> value
885 DT.IsStr string ->
886 strictEq value (JS.String (Text.encodeUtf8Builder string))
888 DT.IsCons ->
889 JS.Access value (Name.fromLocal "b")
891 DT.IsNil ->
892 JS.Prefix JS.PrefixLNot $
893 JS.Access value (Name.fromLocal "b")
895 DT.IsTuple ->
896 error "COMPILER BUG - there should never be tests on a tuple"
900generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
901generateCaseBranch mode label root (test, subTree) =
902 JS.Case
903 (generateCaseValue mode test)
904 (generateDecider mode label root subTree)
907generateCaseValue :: Mode -> DT.Test -> JS.Expr
908generateCaseValue mode test =
909 case test of
910 DT.IsCtor name index _ _ ->
911 case mode of
912 Name.Debug _ -> JS.String (N.toBuilder name)
913 Name.Prod _ _ -> JS.Int (Index.toMachine index)
915 DT.IsInt int ->
916 JS.Int int
918 DT.IsChr char ->
919 JS.String (Text.encodeUtf8Builder char)
921 DT.IsStr string ->
922 JS.String (Text.encodeUtf8Builder string)
924 DT.IsCons ->
925 error "COMPILER BUG - there should never be three tests on a list"
927 DT.IsNil ->
928 error "COMPILER BUG - there should never be three tests on a list"
930 DT.IsTuple ->
931 error "COMPILER BUG - there should never be three tests on a tuple"
934generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
935generateCaseTest mode root path exampleTest =
936 let
937 value = pathToJsExpr mode root path
938 in
939 case exampleTest of
940 DT.IsCtor _ _ _ opts ->
941 case mode of
942 Name.Debug _ ->
943 JS.Access value Name.dollar
945 Name.Prod _ _ ->
946 case opts of
947 Can.Normal ->
948 JS.Access value Name.dollar
950 Can.Enum ->
951 value
953 Can.Unbox ->
954 value
956 DT.IsInt _ ->
957 value
959 DT.IsStr _ ->
960 value
962 DT.IsChr _ ->
963 case mode of
964 Name.Debug _ ->
965 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
967 Name.Prod _ _ ->
968 value
970 DT.IsCons ->
971 error "COMPILER BUG - there should never be three tests on a list"
973 DT.IsNil ->
974 error "COMPILER BUG - there should never be three tests on a list"
976 DT.IsTuple ->
977 error "COMPILER BUG - there should never be three tests on a list"
981-- PATTERN PATHS
984pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
985pathToJsExpr mode root path =
986 case path of
987 DT.Index index subPath ->
988 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
990 DT.Unbox subPath ->
991 case mode of
992 Name.Debug _ ->
993 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
995 Name.Prod _ _ ->
996 pathToJsExpr mode root subPath
998 DT.Empty ->
999 JS.Ref (Name.fromLocal root)
1003-- GENERATE MAIN
1006generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
1007generateMain mode interfaces home main =
1008 case main of
1009 Opt.Static ->
1010 JS.Ref (Name.fromKernel N.browser "staticPage")
1011 # JS.Ref (Name.fromGlobal home "main")
1012 # JS.Int 0
1013 # JS.Int 0
1015 Opt.Dynamic msgType decoder ->
1016 JS.Ref (Name.fromGlobal home "main")
1017 # generateJsExpr mode decoder
1018 # toDebugMetadata mode interfaces msgType
1021(#) :: JS.Expr -> JS.Expr -> JS.Expr
1022(#) func arg =
1023 JS.Call func [arg]
1026toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1027toDebugMetadata mode interfaces msgType =
1028 case mode of
1029 Name.Prod _ _ ->
1030 JS.Int 0
1032 Name.Debug _ ->
1033 JS.Json $ Encode.object $
1034 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1035 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))