git.iko.soy/elk
on master help sign in
Generate JS to handle enums and unboxing
a2e92ddEvan Czaplicki
src/Data/Index.hs+24−22
compare with master
unifiedsplit
@@ -1,10 +1,11 @@
1module Data.Index
1module Data.Index
2 ( ZeroBased
2 ( ZeroBased
3 , first
3 , first
4− , unsafe
4+ , second
5+ , third
5 , next
6 , next
6− , toZeroBased
7+ , toMachine
7− , toOneBased
8+ , toHuman
8 , indexedMap
9 , indexedMap
9 , indexedTraverse
10 , indexedTraverse
10 , indexedForA
11 , indexedForA
@@ -32,12 +33,14 @@ first =
32 ZeroBased 0
33 ZeroBased 0
33
34
34
35
35−unsafe :: Int -> ZeroBased
36+second :: ZeroBased
36−unsafe n =
37+second =
37− if n < 0 then
38− ZeroBased n
38+ ZeroBased 1
39− else
39+
40− error "Compiler error, unacceptable call of Index.unsafe"
40+
41+third :: ZeroBased
42+third =
43+ ZeroBased 2
41
44
42
45
43{-# INLINE next #-}
46{-# INLINE next #-}
@@ -50,13 +53,13 @@ next (ZeroBased i) =
50-- DESTRUCT
53-- DESTRUCT
51
54
52
55
53−toZeroBased :: ZeroBased -> Int
56+toMachine :: ZeroBased -> Int
54−toZeroBased (ZeroBased index) =
57+toMachine (ZeroBased index) =
55 index
58 index
56
59
57
60
58−toOneBased :: ZeroBased -> Int
61+toHuman :: ZeroBased -> Int
59−toOneBased (ZeroBased index) =
62+toHuman (ZeroBased index) =
60 index + 1
63 index + 1
61
64
62
65
@@ -66,20 +69,20 @@ toOneBased (ZeroBased index) =
66
69
67{-# INLINE indexedMap #-}
70{-# INLINE indexedMap #-}
68indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b]
71indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b]
69−indexedMap func list =
72+indexedMap func xs =
70− zipWith func (map ZeroBased [0 .. length list]) list
73+ zipWith func (map ZeroBased [0 .. length xs]) xs
71
74
72
75
73{-# INLINE indexedTraverse #-}
76{-# INLINE indexedTraverse #-}
74indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b]
77indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b]
75−indexedTraverse func list =
78+indexedTraverse func xs =
76− sequenceA (indexedMap func list)
79+ sequenceA (indexedMap func xs)
77
80
78
81
79{-# INLINE indexedForA #-}
82{-# INLINE indexedForA #-}
80indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b]
83indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b]
81−indexedForA list func =
84+indexedForA xs func =
82− sequenceA (indexedMap func list)
85+ sequenceA (indexedMap func xs)
83
86
84
87
85
88
@@ -113,8 +116,8 @@ indexedZipWithHelp func index listX listY revListZ =
113indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c)
116indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c)
114indexedZipWithA func listX listY =
117indexedZipWithA func listX listY =
115 case indexedZipWith func listX listY of
118 case indexedZipWith func listX listY of
116− LengthMatch list ->
119+ LengthMatch xs ->
117− LengthMatch <$> sequenceA list
120+ LengthMatch <$> sequenceA xs
118
121
119 LengthMismatch x y ->
122 LengthMismatch x y ->
120 pure (LengthMismatch x y)
123 pure (LengthMismatch x y)
@@ -127,4 +130,3 @@ indexedZipWithA func listX listY =
127instance Binary ZeroBased where
130instance Binary ZeroBased where
128 get = liftM ZeroBased get
131 get = liftM ZeroBased get
129 put (ZeroBased n) = put n
132 put (ZeroBased n) = put n
130−
src/Generate/JavaScript.hs+49−4
@@ -19,6 +19,7 @@ import qualified Data.Text as Text
19
19
20import qualified AST.Optimized as Opt
20import qualified AST.Optimized as Opt
21import qualified AST.Module.Name as ModuleName
21import qualified AST.Module.Name as ModuleName
22+import qualified Data.Index as Index
22import qualified Elm.Compiler.Type as Type
23import qualified Elm.Compiler.Type as Type
23import qualified Elm.Compiler.Type.Extract as Extract
24import qualified Elm.Compiler.Type.Extract as Extract
24import qualified Elm.Interface as I
25import qualified Elm.Interface as I
@@ -153,9 +154,8 @@ addGlobalHelp mode graph global state =
153 )
154 )
154
155
155 Opt.Ctor name index arity ->
156 Opt.Ctor name index arity ->
156− let (args, ctor) = Expr.generateCtor mode name index arity in
157 addStmt state (
157 addStmt state (
158− var global (Expr.generateFunction args ctor)
158+ var global (Expr.generateCtor mode name index arity)
159 )
159 )
160
160
161 Opt.Link linkedGlobal ->
161 Opt.Link linkedGlobal ->
@@ -177,6 +177,16 @@ addGlobalHelp mode graph global state =
177 _ ->
177 _ ->
178 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
178 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
179
179
180+ Opt.Enum name index ->
181+ addStmt state (
182+ generateEnum mode global name index
183+ )
184+
185+ Opt.Box name ->
186+ addStmt state (
187+ generateBox mode global name
188+ )
189+
180 Opt.PortIncoming decoder deps ->
190 Opt.PortIncoming decoder deps ->
181 addStmt (addDeps deps state) (
191 addStmt (addDeps deps state) (
182 generatePort mode global "incomingPort" decoder
192 generatePort mode global "incomingPort" decoder
@@ -263,7 +273,7 @@ addChunk mode builder chunk =
263 Opt.JsField int ->
273 Opt.JsField int ->
264 Name.toBuilder (Name.fromInt int) <> builder
274 Name.toBuilder (Name.fromInt int) <> builder
265
275
266− Opt.Enum int ->
276+ Opt.JsEnum int ->
267 Name.toBuilder (Name.fromInt int) <> builder
277 Name.toBuilder (Name.fromInt int) <> builder
268
278
269 Opt.Debug ->
279 Opt.Debug ->
@@ -284,6 +294,42 @@ addChunk mode builder chunk =
284
294
285
295
286
296
297+-- GENERATE ENUM
298+
299+
300+generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
301+generateEnum mode (Opt.Global home name) ctorName index =
302+ let
303+ definition =
304+ case mode of
305+ Name.Debug _ ->
306+ JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]
307+
308+ Name.Prod _ _ ->
309+ JS.Int (Index.toMachine index)
310+ in
311+ JS.Var [ (Name.fromGlobal home name, Just definition) ]
312+
313+
314+
315+-- GENERATE BOX
316+
317+
318+generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
319+generateBox mode (Opt.Global home name) ctorName =
320+ let
321+ definition =
322+ case mode of
323+ Name.Debug _ ->
324+ Expr.codeToExpr $ Expr.generateCtor mode ctorName Index.first 1
325+
326+ Name.Prod _ _ ->
327+ JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
328+ in
329+ JS.Var [ (Name.fromGlobal home name, Just definition) ]
330+
331+
332+
287-- GENERATE PORTS
333-- GENERATE PORTS
288
334
289
335
@@ -303,7 +349,6 @@ generatePort mode (Opt.Global home name) makePort converter =
303-- GENERATE MANAGER
349-- GENERATE MANAGER
304
350
305
351
306−
307generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
352generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
308generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
353generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
309 let
354 let
src/Generate/JavaScript/Expression.hs+198−69
@@ -76,6 +76,20 @@ generate mode expression =
76 Opt.VarGlobal (Opt.Global home name) ->
76 Opt.VarGlobal (Opt.Global home name) ->
77 JsExpr $ JS.Ref (Name.fromGlobal home name)
77 JsExpr $ JS.Ref (Name.fromGlobal home name)
78
78
79+ Opt.VarEnum (Opt.Global home name) index ->
80+ case mode of
81+ Name.Debug _ ->
82+ JsExpr $ JS.Ref (Name.fromGlobal home name)
83+
84+ Name.Prod _ _ ->
85+ JsExpr $ JS.Int (Index.toMachine index)
86+
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
92+
79 Opt.VarCycle home name ->
93 Opt.VarCycle home name ->
80 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
94 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
81
95
@@ -108,12 +122,16 @@ generate mode expression =
108 JsBlock $
122 JsBlock $
109 generateDef mode def : codeToStmtList (generate mode body)
123 generateDef mode def : codeToStmtList (generate mode body)
110
124
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)
131+
111 Opt.Case label root decider jumps ->
132 Opt.Case label root decider jumps ->
112 JsBlock $ generateCase mode label root decider jumps
133 JsBlock $ generateCase mode label root decider jumps
113
134
114− Opt.Index expr index ->
115− JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)
116−
117 Opt.Accessor field ->
135 Opt.Accessor field ->
118 JsExpr $ JS.Function Nothing [Name.dollar]
136 JsExpr $ JS.Function Nothing [Name.dollar]
119 [ JS.Return $ Just $
137 [ JS.Return $ Just $
@@ -134,7 +152,12 @@ generate mode expression =
134 JsExpr $ generateRecord mode fields
152 JsExpr $ generateRecord mode fields
135
153
136 Opt.Unit ->
154 Opt.Unit ->
155+ case mode of
156+ Name.Debug _ ->
137− JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
157+ JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")
158+
159+ Name.Prod _ _ ->
160+ JsExpr $ JS.Int 0
138
161
139 Opt.Tuple a b maybeC ->
162 Opt.Tuple a b maybeC ->
140 JsExpr $
163 JsExpr $
@@ -216,21 +239,19 @@ toChar =
216-- CTOR
239-- CTOR
217
240
218
241
219−generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
242+generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code
220generateCtor mode name index arity =
243generateCtor mode name index arity =
221 let
244 let
222− argNames = map Name.fromInt [1 .. arity]
245+ argNames =
223− argFields = map (\n -> (n, JS.Ref n)) argNames
246+ Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]
224
247
225− tag =
248+ ctorTag =
226 case mode of
249 case mode of
227− Name.Debug _ ->
228− ( Name.dollar, JS.String (N.toBuilder name) )
250+ Name.Debug _ -> JS.String (N.toBuilder name)
229−
230− Name.Prod _ _ ->
251+ Name.Prod _ _ -> JS.Int (Index.toMachine index)
231− ( Name.dollar, JS.Int (Index.toZeroBased index) )
232 in
252 in
233− ( argNames, JsExpr (JS.Object (tag:argFields)) )
253+ generateFunction argNames $ JsExpr $ JS.Object $
254+ (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames
234
255
235
256
236
257
@@ -334,14 +355,32 @@ generateCall mode func args =
334 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
355 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
335 generateCoreCall mode global args
356 generateCoreCall mode global args
336
357
358+ Opt.VarBox _ ->
359+ case mode of
360+ Name.Debug _ ->
361+ generateCallHelp mode func args
362+
363+ Name.Prod _ _ ->
364+ case args of
365+ [arg] ->
366+ generateJsExpr mode arg
367+
368+ _ ->
369+ generateCallHelp mode func args
370+
337 _ ->
371 _ ->
338− generateNormalCall
372+ generateCallHelp mode func args
339− (generateJsExpr mode func)
340− (map (generateJsExpr mode) args)
341
373
342
374
375+generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
376+generateCallHelp mode func args =
377+ generateNormalCall
378+ (generateJsExpr mode func)
379+ (map (generateJsExpr mode) args)
380+
381+
343−generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
382+generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
344−generateNormalCall' home name args =
383+generateGlobalCall home name args =
345 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
384 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args
346
385
347
386
@@ -385,8 +424,11 @@ generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name)
385 else if moduleName == N.tuple then
424 else if moduleName == N.tuple then
386 generateTupleCall home name (map (generateJsExpr mode) args)
425 generateTupleCall home name (map (generateJsExpr mode) args)
387
426
427+ else if moduleName == N.jsArray then
428+ generateJsArrayCall home name (map (generateJsExpr mode) args)
429+
388 else
430 else
389− generateNormalCall' home name (map (generateJsExpr mode) args)
431+ generateGlobalCall home name (map (generateJsExpr mode) args)
390
432
391
433
392generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
434generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
@@ -396,10 +438,18 @@ generateTupleCall home name args =
396 case name of
438 case name of
397 "first" -> JS.Access value (Name.fromLocal "a")
439 "first" -> JS.Access value (Name.fromLocal "a")
398 "second" -> JS.Access value (Name.fromLocal "b")
440 "second" -> JS.Access value (Name.fromLocal "b")
399− _ -> generateNormalCall' home name args
441+ _ -> generateGlobalCall home name args
400
442
401 _ ->
443 _ ->
402− generateNormalCall' home name args
444+ generateGlobalCall home name args
445+
446+
447+generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
448+generateJsArrayCall 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
403
453
404
454
405generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
455generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr
@@ -408,7 +458,7 @@ generateBitwiseCall home name args =
408 [arg] ->
458 [arg] ->
409 case name of
459 case name of
410 "complement" -> JS.Prefix JS.PrefixBNot arg
460 "complement" -> JS.Prefix JS.PrefixBNot arg
411− _ -> generateNormalCall' home name args
461+ _ -> generateGlobalCall home name args
412
462
413 [left,right] ->
463 [left,right] ->
414 case name of
464 case name of
@@ -418,10 +468,10 @@ generateBitwiseCall home name args =
418 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
468 "shiftLeftBy" -> JS.Infix JS.OpLShift right left
419 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
469 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
420 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
470 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
421− _ -> generateNormalCall' home name args
471+ _ -> generateGlobalCall home name args
422
472
423 _ ->
473 _ ->
424− generateNormalCall' home name args
474+ generateGlobalCall home name args
425
475
426
476
427generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
477generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
@@ -433,7 +483,7 @@ generateBasicsCall mode home name args =
433 "not" -> JS.Prefix JS.PrefixLNot arg
483 "not" -> JS.Prefix JS.PrefixLNot arg
434 "toFloat" -> arg
484 "toFloat" -> arg
435 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
485 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
436− _ -> generateNormalCall' home name [arg]
486+ _ -> generateGlobalCall home name [arg]
437
487
438 [elmLeft, elmRight] ->
488 [elmLeft, elmRight] ->
439 case name of
489 case name of
@@ -462,10 +512,10 @@ generateBasicsCall mode home name args =
462 "or" -> JS.Infix JS.OpLOr left right
512 "or" -> JS.Infix JS.OpLOr left right
463 "and" -> JS.Infix JS.OpLAnd left right
513 "and" -> JS.Infix JS.OpLAnd left right
464 "xor" -> JS.Infix JS.OpStrictNEq left right
514 "xor" -> JS.Infix JS.OpStrictNEq left right
465− _ -> generateNormalCall' home name [left, right]
515+ _ -> generateGlobalCall home name [left, right]
466
516
467 _ ->
517 _ ->
468− generateNormalCall' home name (map (generateJsExpr mode) args)
518+ generateGlobalCall home name (map (generateJsExpr mode) args)
469
519
470
520
471equal :: JS.Expr -> JS.Expr -> JS.Expr
521equal :: JS.Expr -> JS.Expr -> JS.Expr
@@ -676,6 +726,31 @@ generateDef mode def =
676
726
677
727
678
728
729+-- PATHS
730+
731+
732+generatePath :: Mode -> Opt.Path -> JS.Expr
733+generatePath mode path =
734+ case path of
735+ Opt.Index index subPath ->
736+ JS.Access (generatePath mode subPath) (Name.fromIndex index)
737+
738+ Opt.Root name ->
739+ JS.Ref (Name.fromLocal name)
740+
741+ Opt.Field field subPath ->
742+ JS.Access (generatePath mode subPath) (Name.fromField mode field)
743+
744+ Opt.Unbox subPath ->
745+ case mode of
746+ Name.Debug _ ->
747+ JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)
748+
749+ Name.Prod _ _ ->
750+ generatePath mode subPath
751+
752+
753+
679-- GENERATE IFS
754-- GENERATE IFS
680
755
681
756
@@ -770,45 +845,69 @@ generateDecider mode label root decisionTree =
770 [ JS.Break (Just (Name.makeLabel label index)) ]
845 [ JS.Break (Just (Name.makeLabel label index)) ]
771
846
772 Opt.Chain testChain success failure ->
847 Opt.Chain testChain success failure ->
773− let
774− makeTest (path, test) =
775− strictEq
776− (pathToTestableExpr mode root path test)
777− (testToExpr mode test)
778− in
779 [ JS.IfStmt
848 [ JS.IfStmt
780− (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))
849+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
781 (JS.Block $ generateDecider mode label root success)
850 (JS.Block $ generateDecider mode label root success)
782 (JS.Block $ generateDecider mode label root failure)
851 (JS.Block $ generateDecider mode label root failure)
783 ]
852 ]
784
853
785 Opt.FanOut path edges fallback ->
854 Opt.FanOut path edges fallback ->
786 [ JS.Switch
855 [ JS.Switch
787− (pathToTestableExpr mode root path (fst (head edges)))
856+ (generateCaseTest mode root path (fst (head edges)))
788 ( foldr
857 ( foldr
789− (addCase mode label root)
858+ (\edge cases -> generateCaseBranch mode label root edge : cases)
790 [ JS.Default (generateDecider mode label root fallback) ]
859 [ JS.Default (generateDecider mode label root fallback) ]
791 edges
860 edges
792 )
861 )
793 ]
862 ]
794
863
795
864
796−addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
865+generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr
797−addCase mode label root (test, subTree) cases =
866+generateIfTest mode root (path, test) =
798− let stmts = generateDecider mode label root subTree in
867+ let
799− JS.Case (testToExpr mode test) stmts : cases
868+ value = pathToJsExpr mode root path
869+ in
870+ case test of
871+ DT.IsCtor name index _ _ ->
872+ strictEq (JS.Access value Name.dollar) $
873+ case mode of
874+ Name.Debug _ -> JS.String (N.toBuilder name)
875+ Name.Prod _ _ -> JS.Int (Index.toMachine index)
876+
877+ DT.IsInt int ->
878+ strictEq value (JS.Int int)
800
879
880+ DT.IsChr char ->
881+ strictEq (JS.String (Text.encodeUtf8Builder char)) $
882+ case mode of
883+ Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
884+ Name.Prod _ _ -> value
801
885
886+ DT.IsStr string ->
887+ strictEq value (JS.String (Text.encodeUtf8Builder string))
888+
889+ DT.IsCons ->
890+ JS.Access value (Name.fromLocal "b")
891+
892+ DT.IsNil ->
893+ JS.Prefix JS.PrefixLNot $
894+ JS.Access value (Name.fromLocal "b")
895+
896+
897+generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
898+generateCaseBranch mode label root (test, subTree) =
899+ JS.Case
900+ (generateCaseValue mode test)
901+ (generateDecider mode label root subTree)
902+
903+
802−testToExpr :: Mode -> DT.Test -> JS.Expr
904+generateCaseValue :: Mode -> DT.Test -> JS.Expr
803−testToExpr mode test =
905+generateCaseValue mode test =
804 case test of
906 case test of
805− DT.IsCtor _ tag index ->
907+ DT.IsCtor name index _ _ ->
806 case mode of
908 case mode of
807− Name.Debug _ ->
808− JS.String (N.toBuilder tag)
909+ Name.Debug _ -> JS.String (N.toBuilder name)
809−
810− Name.Prod _ _ ->
811− JS.Int (Index.toZeroBased index)
910+ Name.Prod _ _ -> JS.Int (Index.toMachine index)
812
911
813 DT.IsInt int ->
912 DT.IsInt int ->
814 JS.Int int
913 JS.Int int
@@ -819,46 +918,76 @@ testToExpr mode test =
819 DT.IsStr string ->
918 DT.IsStr string ->
820 JS.String (Text.encodeUtf8Builder string)
919 JS.String (Text.encodeUtf8Builder string)
821
920
921+ DT.IsCons ->
922+ error "COMPILER BUG - there should never be three tests on a list"
822
923
924+ DT.IsNil ->
925+ error "COMPILER BUG - there should never be three tests on a list"
926+
927+
823−pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
928+generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
824−pathToTestableExpr mode root path exampleTest =
929+generateCaseTest mode root path exampleTest =
825 let
930 let
826− expr =
827− pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path
931+ value = pathToJsExpr mode root path
828 in
932 in
829 case exampleTest of
933 case exampleTest of
830− DT.IsCtor _ _ _ ->
934+ DT.IsCtor _ _ _ opts ->
935+ case mode of
936+ Name.Debug _ ->
831− JS.Access expr Name.dollar
937+ JS.Access value Name.dollar
938+
939+ Name.Prod _ _ ->
940+ case opts of
941+ Can.Normal ->
942+ JS.Access value Name.dollar
943+
944+ Can.Enum ->
945+ value
946+
947+ Can.Unbox ->
948+ value
832
949
833 DT.IsInt _ ->
950 DT.IsInt _ ->
834− expr
951+ value
835
952
836 DT.IsStr _ ->
953 DT.IsStr _ ->
837− expr
954+ value
838
955
839 DT.IsChr _ ->
956 DT.IsChr _ ->
840 case mode of
957 case mode of
841 Name.Debug _ ->
958 Name.Debug _ ->
842− JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
959+ JS.Call (JS.Access value (Name.fromLocal "valueOf")) []
843
960
844 Name.Prod _ _ ->
961 Name.Prod _ _ ->
845− expr
962+ value
846
963
964+ DT.IsCons ->
965+ error "COMPILER BUG - there should never be three tests on a list"
847
966
967+ DT.IsNil ->
968+ error "COMPILER BUG - there should never be three tests on a list"
969+
970+
971+
972+-- PATTERN PATHS
973+
974+
848−pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr
975+pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr
849−pathToJsExpr mode expr path =
976+pathToJsExpr mode root path =
850 case path of
977 case path of
851− DT.Index index subpath ->
978+ DT.Index index subPath ->
852− pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath
979+ JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)
853
980
854− DT.Field field subpath ->
981+ DT.Unbox subPath ->
855− pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
982+ case mode of
983+ Name.Debug _ ->
984+ JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)
856
985
857− DT.Empty ->
986+ Name.Prod _ _ ->
858− expr
987+ pathToJsExpr mode root subPath
859
988
860− DT.Alias ->
989+ DT.Empty ->
861− expr
990+ JS.Ref (Name.fromLocal root)
862
991
863
992
864
993
src/Generate/JavaScript/Name.hs+7
@@ -6,6 +6,7 @@ module Generate.JavaScript.Name
6 , Target(..)
6 , Target(..)
7 , isServer
7 , isServer
8 , toBuilder
8 , toBuilder
9+ , fromIndex
9 , fromInt
10 , fromInt
10 , fromLocal
11 , fromLocal
11 , fromGlobal
12 , fromGlobal
@@ -32,6 +33,7 @@ import qualified Data.Text.Encoding as Text
32import Data.Word (Word8)
33import Data.Word (Word8)
33
34
34import qualified AST.Module.Name as ModuleName
35import qualified AST.Module.Name as ModuleName
36+import qualified Data.Index as Index
35import qualified Elm.Name as N
37import qualified Elm.Name as N
36import qualified Elm.Package as Pkg
38import qualified Elm.Package as Pkg
37
39
@@ -76,6 +78,11 @@ isServerHelp target =
76-- CONSTRUCTORS
78-- CONSTRUCTORS
77
79
78
80
81+fromIndex :: Index.ZeroBased -> Name
82+fromIndex index =
83+ fromInt (Index.toMachine index)
84+
85+
79fromInt :: Int -> Name
86fromInt :: Int -> Name
80fromInt n =
87fromInt n =
81 Name (B.shortByteString (intToAscii n))
88 Name (B.shortByteString (intToAscii n))