git.iko.soy/elk
on 19ff114 help sign in
elk/src/Generate/JavaScript/Expression.hs
1022 lines 26 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 map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]
341-- CALLS
344generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
345generateCall mode func args =
346 case func of
347 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
348 generateCoreCall mode global args
350 Opt.VarBox _ ->
351 case mode of
352 Name.Debug _ ->
353 generateCallHelp mode func args
355 Name.Prod _ _ ->
356 case args of
357 [arg] ->
358 generateJsExpr mode arg
360 _ ->
361 generateCallHelp mode func args
363 _ ->
364 generateCallHelp mode func args
367generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
368generateCallHelp mode func args =
369 generateNormalCall
370 (generateJsExpr mode func)
371 (map (generateJsExpr mode) args)
374generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
375generateGlobalCall home name args =
376 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
379generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
380generateNormalCall func args =
381 case IntMap.lookup (length args) callHelpers of
382 Just helper ->
383 JS.Call helper (func:args)
385 Nothing ->
386 List.foldl' (\f a -> JS.Call f [a]) func args
389{-# NOINLINE callHelpers #-}
390callHelpers :: IntMap.IntMap JS.Expr
391callHelpers =
392 IntMap.fromList $
393 map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]
397-- CORE CALLS
400generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
401generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
402 if moduleName == N.basics then
403 generateBasicsCall mode home name args
405 else if moduleName == N.bitwise then
406 generateBitwiseCall home name (map (generateJsExpr mode) args)
408 else if moduleName == N.tuple then
409 generateTupleCall home name (map (generateJsExpr mode) args)
411 else if moduleName == N.jsArray then
412 generateJsArrayCall home name (map (generateJsExpr mode) args)
414 else
415 generateGlobalCall home name (map (generateJsExpr mode) args)
418generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
419generateTupleCall home name args =
420 case args of
421 [value] ->
422 case name of
423 "first" -> JS.Access value (Name.fromLocal "a")
424 "second" -> JS.Access value (Name.fromLocal "b")
425 _ -> generateGlobalCall home name args
427 _ ->
428 generateGlobalCall home name args
431generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
432generateJsArrayCall home name args =
433 case args of
434 [entry] | name == "singleton" -> JS.Array [entry]
435 [index, array] | name == "unsafeGet" -> JS.Index array index
436 _ -> generateGlobalCall home name args
439generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
440generateBitwiseCall home name args =
441 case args of
442 [arg] ->
443 case name of
444 "complement" -> JS.Prefix JS.PrefixBNot arg
445 _ -> generateGlobalCall home name args
447 [left,right] ->
448 case name of
449 "and" -> JS.Infix JS.OpBAnd left right
450 "or" -> JS.Infix JS.OpBOr left right
451 "xor" -> JS.Infix JS.OpBXor left right
452 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
453 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
454 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
455 _ -> generateGlobalCall home name args
457 _ ->
458 generateGlobalCall home name args
461generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
462generateBasicsCall mode home name args =
463 case args of
464 [elmArg] ->
465 let arg = generateJsExpr mode elmArg in
466 case name of
467 "not" -> JS.Prefix JS.PrefixLNot arg
468 "toFloat" -> arg
469 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
470 _ -> generateGlobalCall home name [arg]
472 [elmLeft, elmRight] ->
473 case name of
474 "composeL" -> decomposeL mode elmLeft [elmRight]
475 "composeR" -> decomposeR mode [elmLeft] elmRight
476 "append" -> append mode elmLeft elmRight
477 "apL" -> generateJsExpr mode $ apply elmLeft elmRight
478 "apR" -> generateJsExpr mode $ apply elmRight elmLeft
479 _ ->
480 let
481 left = generateJsExpr mode elmLeft
482 right = generateJsExpr mode elmRight
483 in
484 case name of
485 "add" -> JS.Infix JS.OpAdd left right
486 "sub" -> JS.Infix JS.OpSub left right
487 "mul" -> JS.Infix JS.OpMul left right
488 "fdiv" -> JS.Infix JS.OpDiv left right
489 "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
490 "eq" -> equal left right
491 "neq" -> notEqual left right
492 "lt" -> cmp JS.OpLT JS.OpLT 0 left right
493 "gt" -> cmp JS.OpGT JS.OpGT 0 left right
494 "le" -> cmp JS.OpLEq JS.OpLT 1 left right
495 "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
496 "or" -> JS.Infix JS.OpLOr left right
497 "and" -> JS.Infix JS.OpLAnd left right
498 "xor" -> JS.Infix JS.OpStrictNEq left right
499 _ -> generateGlobalCall home name [left, right]
501 _ ->
502 generateGlobalCall home name (map (generateJsExpr mode) args)
505equal :: JS.Expr -> JS.Expr -> JS.Expr
506equal left right =
507 if isLiteral left || isLiteral right then
508 strictEq left right
509 else
510 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
513notEqual :: JS.Expr -> JS.Expr -> JS.Expr
514notEqual left right =
515 if isLiteral left || isLiteral right then
516 strictNEq left right
517 else
518 JS.Prefix JS.PrefixLNot $
519 JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]
522cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
523cmp idealOp backupOp backupInt left right =
524 if isLiteral left || isLiteral right then
525 JS.Infix idealOp left right
526 else
527 JS.Infix backupOp
528 (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])
529 (JS.Int backupInt)
532isLiteral :: JS.Expr -> Bool
533isLiteral expr =
534 case expr of
535 JS.String _ ->
536 True
538 JS.Float _ ->
539 True
541 JS.Int _ ->
542 True
544 JS.Bool _ ->
545 True
547 _ ->
548 False
551decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
552decomposeL mode expr funcs =
553 case expr of
554 Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
555 | home == ModuleName.basics ->
556 decomposeL mode left (func:funcs)
558 _ ->
559 generateJsExpr mode $
560 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
563decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr
564decomposeR mode funcs expr =
565 case expr of
566 Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]
567 | home == ModuleName.basics ->
568 decomposeR mode (func:funcs) right
570 _ ->
571 generateJsExpr mode $
572 Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
575apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
576apply func value =
577 case func of
578 Opt.Accessor field ->
579 Opt.Access value field
581 Opt.Call f args ->
582 Opt.Call f (args ++ [value])
584 _ ->
585 Opt.Call func [value]
588append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
589append mode left right =
590 let seqs = generateJsExpr mode left : toSeqs mode right in
591 if any isStringLiteral seqs then
592 foldr1 (JS.Infix JS.OpAdd) seqs
593 else
594 foldr1 jsAppend seqs
597jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
598jsAppend a b =
599 JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]
602toSeqs :: Mode -> Opt.Expr -> [JS.Expr]
603toSeqs mode expr =
604 case expr of
605 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
606 | home == ModuleName.basics ->
607 generateJsExpr mode left : toSeqs mode right
609 _ ->
610 [generateJsExpr mode expr]
613isStringLiteral :: JS.Expr -> Bool
614isStringLiteral expr =
615 case expr of
616 JS.String _ ->
617 True
619 _ ->
620 False
624-- SIMPLIFY INFIX OPERATORS
627strictEq :: JS.Expr -> JS.Expr -> JS.Expr
628strictEq left right =
629 case left of
630 JS.Int 0 ->
631 JS.Prefix JS.PrefixLNot right
633 JS.Bool bool ->
634 if bool then right else JS.Prefix JS.PrefixLNot right
636 _ ->
637 case right of
638 JS.Int 0 ->
639 JS.Prefix JS.PrefixLNot left
641 JS.Bool bool ->
642 if bool then left else JS.Prefix JS.PrefixLNot left
644 _ ->
645 JS.Infix JS.OpStrictEq left right
648strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
649strictNEq left right =
650 case left of
651 JS.Int 0 ->
652 right
654 JS.Bool bool ->
655 if bool then JS.Prefix JS.PrefixLNot right else right
657 _ ->
658 case right of
659 JS.Int 0 ->
660 left
662 JS.Bool bool ->
663 if bool then JS.Prefix JS.PrefixLNot left else left
665 _ ->
666 JS.Infix JS.OpStrictNEq left right
670-- TAIL CALL
673-- TODO check if JS minifiers collapse unnecessary temporary variables
674--
675generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]
676generateTailCall mode name args =
677 let
678 toTempVars (argName, arg) =
679 ( Name.makeTemp argName, Just (generateJsExpr mode arg) )
681 toRealVars (argName, _) =
682 JS.ExprStmt $
683 JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
684 in
685 JS.Var (map toTempVars args)
686 : map toRealVars args
687 ++ [ JS.Continue (Just (Name.fromLocal name)) ]
691-- DEFINITIONS
694generateDef :: Mode -> Opt.Def -> JS.Stmt
695generateDef mode def =
696 case def of
697 Opt.Def name body ->
698 JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]
700 Opt.TailDef name argNames body ->
701 JS.Var [ (Name.fromLocal name, Just (generateTailDef mode name argNames body)) ]
704generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> JS.Expr
705generateTailDef mode name argNames body =
706 JS.Function Nothing (map Name.fromLocal argNames)
707 [ JS.Labelled (Name.fromLocal name) $
708 JS.While (JS.Bool True) $
709 codeToStmt $ generate mode body
710 ]
714-- PATHS
717generatePath :: Mode -> Opt.Path -> JS.Expr
718generatePath mode path =
719 case path of
720 Opt.Index index subPath ->
721 JS.Access (generatePath mode subPath) (Name.fromIndex index)
723 Opt.Root name ->
724 JS.Ref (Name.fromLocal name)
726 Opt.Field field subPath ->
727 JS.Access (generatePath mode subPath) (Name.fromField mode field)
729 Opt.Unbox subPath ->
730 case mode of
731 Name.Debug _ ->
732 JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
734 Name.Prod _ _ ->
735 generatePath mode subPath
739-- GENERATE IFS
742generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
743generateIf mode givenBranches givenFinal =
744 let
745 (branches, final) =
746 crushIfs givenBranches givenFinal
748 convertBranch (condition, expr) =
749 ( generateJsExpr mode condition
750 , generate mode expr
751 )
753 branchExprs = map convertBranch branches
754 finalCode = generate mode final
755 in
756 if isBlock finalCode || any (isBlock . snd) branchExprs then
757 JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
758 else
759 JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
762addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
763addExprIf (condition, branch) final =
764 JS.If condition (codeToExpr branch) final
767addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
768addStmtIf (condition, branch) final =
769 JS.IfStmt condition (codeToStmt branch) final
772isBlock :: Code -> Bool
773isBlock code =
774 case code of
775 JsBlock _ -> True
776 JsExpr _ -> False
779crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
780crushIfs branches final =
781 crushIfsHelp [] branches final
784crushIfsHelp
785 :: [(Opt.Expr, Opt.Expr)]
786 -> [(Opt.Expr, Opt.Expr)]
787 -> Opt.Expr
788 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
789crushIfsHelp visitedBranches unvisitedBranches final =
790 case unvisitedBranches of
791 [] ->
792 case final of
793 Opt.If subBranches subFinal ->
794 crushIfsHelp visitedBranches subBranches subFinal
796 _ ->
797 (reverse visitedBranches, final)
799 visiting : unvisited ->
800 crushIfsHelp (visiting : visitedBranches) unvisited final
804-- CASE EXPRESSIONS
807generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
808generateCase mode label root decider jumps =
809 foldr (goto mode label) (generateDecider mode label root decider) jumps
812goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
813goto mode label (index, branch) stmts =
814 let
815 labeledDeciderStmt =
816 JS.Labelled
817 (Name.makeLabel label index)
818 (JS.While (JS.Bool True) (JS.Block stmts))
819 in
820 labeledDeciderStmt : codeToStmtList (generate mode branch)
823generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
824generateDecider mode label root decisionTree =
825 case decisionTree of
826 Opt.Leaf (Opt.Inline branch) ->
827 codeToStmtList (generate mode branch)
829 Opt.Leaf (Opt.Jump index) ->
830 [ JS.Break (Just (Name.makeLabel label index)) ]
832 Opt.Chain testChain success failure ->
833 [ JS.IfStmt
834 (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
835 (JS.Block $ generateDecider mode label root success)
836 (JS.Block $ generateDecider mode label root failure)
837 ]
839 Opt.FanOut path edges fallback ->
840 [ JS.Switch
841 (generateCaseTest mode root path (fst (head edges)))
842 ( foldr
843 (\edge cases -> generateCaseBranch mode label root edge : cases)
844 [ JS.Default (generateDecider mode label root fallback) ]
845 edges
846 )
847 ]
850generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
851generateIfTest mode root (path, test) =
852 let
853 value = pathToJsExpr mode root path
854 in
855 case test of
856 DT.IsCtor name index _ _ ->
857 strictEq (JS.Access value Name.dollar) $
858 case mode of
859 Name.Debug _ -> JS.String (N.toBuilder name)
860 Name.Prod _ _ -> JS.Int (Index.toMachine index)
862 DT.IsInt int ->
863 strictEq value (JS.Int int)
865 DT.IsChr char ->
866 strictEq (JS.String (Text.encodeUtf8Builder char)) $
867 case mode of
868 Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
869 Name.Prod _ _ -> value
871 DT.IsStr string ->
872 strictEq value (JS.String (Text.encodeUtf8Builder string))
874 DT.IsCons ->
875 JS.Access value (Name.fromLocal "b")
877 DT.IsNil ->
878 JS.Prefix JS.PrefixLNot $
879 JS.Access value (Name.fromLocal "b")
881 DT.IsTuple ->
882 error "COMPILER BUG - there should never be tests on a tuple"
886generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
887generateCaseBranch mode label root (test, subTree) =
888 JS.Case
889 (generateCaseValue mode test)
890 (generateDecider mode label root subTree)
893generateCaseValue :: Mode -> DT.Test -> JS.Expr
894generateCaseValue mode test =
895 case test of
896 DT.IsCtor name index _ _ ->
897 case mode of
898 Name.Debug _ -> JS.String (N.toBuilder name)
899 Name.Prod _ _ -> JS.Int (Index.toMachine index)
901 DT.IsInt int ->
902 JS.Int int
904 DT.IsChr char ->
905 JS.String (Text.encodeUtf8Builder char)
907 DT.IsStr string ->
908 JS.String (Text.encodeUtf8Builder string)
910 DT.IsCons ->
911 error "COMPILER BUG - there should never be three tests on a list"
913 DT.IsNil ->
914 error "COMPILER BUG - there should never be three tests on a list"
916 DT.IsTuple ->
917 error "COMPILER BUG - there should never be three tests on a tuple"
920generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
921generateCaseTest mode root path exampleTest =
922 let
923 value = pathToJsExpr mode root path
924 in
925 case exampleTest of
926 DT.IsCtor _ _ _ opts ->
927 case mode of
928 Name.Debug _ ->
929 JS.Access value Name.dollar
931 Name.Prod _ _ ->
932 case opts of
933 Can.Normal ->
934 JS.Access value Name.dollar
936 Can.Enum ->
937 value
939 Can.Unbox ->
940 value
942 DT.IsInt _ ->
943 value
945 DT.IsStr _ ->
946 value
948 DT.IsChr _ ->
949 case mode of
950 Name.Debug _ ->
951 JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
953 Name.Prod _ _ ->
954 value
956 DT.IsCons ->
957 error "COMPILER BUG - there should never be three tests on a list"
959 DT.IsNil ->
960 error "COMPILER BUG - there should never be three tests on a list"
962 DT.IsTuple ->
963 error "COMPILER BUG - there should never be three tests on a list"
967-- PATTERN PATHS
970pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
971pathToJsExpr mode root path =
972 case path of
973 DT.Index index subPath ->
974 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
976 DT.Unbox subPath ->
977 case mode of
978 Name.Debug _ ->
979 JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
981 Name.Prod _ _ ->
982 pathToJsExpr mode root subPath
984 DT.Empty ->
985 JS.Ref (Name.fromLocal root)
989-- GENERATE MAIN
992generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr
993generateMain mode interfaces home main =
994 case main of
995 Opt.Static ->
996 JS.Ref (Name.fromKernel N.browser "staticPage")
997 # JS.Ref (Name.fromGlobal home "main")
998 # JS.Int 0
999 # JS.Int 0
1001 Opt.Dynamic decoder msgType ->
1002 JS.Ref (Name.fromGlobal home "main")
1003 # generateJsExpr mode decoder
1004 # toDebugMetadata mode interfaces msgType
1007(#) :: JS.Expr -> JS.Expr -> JS.Expr
1008(#) func arg =
1009 JS.Call func [arg]
1012toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr
1013toDebugMetadata mode interfaces msgType =
1014 case mode of
1015 Name.Prod _ _ ->
1016 JS.Int 0
1018 Name.Debug _ ->
1019 JS.Json $ Encode.object $
1020 [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])
1021 , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))