git.iko.soy/elk
on master help sign in
Handle signals properly, fix outgoing lists, improve errors for missing fields
36a5c1dEvan Czaplicki
compiler/Generate/JavaScript/Ports.hs+37−25
compare with master
unifiedsplit
@@ -6,14 +6,29 @@ import qualified SourceSyntax.Helpers as Help
6import SourceSyntax.Type
6import SourceSyntax.Type
7import Language.ECMAScript3.Syntax
7import Language.ECMAScript3.Syntax
8
8
9+data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
10+ deriving Show
11+
9−check :: a -> [a -> Expression ()] -> Expression () -> Expression ()
12+check :: Expression () -> JSType -> Expression () -> Expression ()
10−check x checks continue =
13+check x jsType continue =
11− CondExpr () (foldl1 (InfixExpr () OpLOr) (map ($x) checks)) continue throw
14+ CondExpr () (jsFold OpLOr checks x) continue throw
12 where
15 where
16+ jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)
17+ throw = obj "_E.raise" <| InfixExpr () OpAdd msg x
13− throw = obj "_E.raise" <| string "invalid input to port"
18+ msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")
19+ checks = case jsType of
20+ JSNumber -> [typeof "number"]
21+ JSBoolean -> [typeof "boolean"]
22+ JSString -> [typeof "string", instanceof "String"]
23+ JSArray -> [instanceof "Array"]
24+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
14
25
15incoming :: Type -> Expression ()
26incoming :: Type -> Expression ()
16−incoming t = ["v"] ==> go t (ref "v")
27+incoming tipe =
28+ case tipe of
29+ Data "Signal.Signal" [t] ->
30+ obj "Native.Ports.incomingSignal" <| incoming t
31+ _ -> ["v"] ==> go tipe (ref "v")
17 where
32 where
18 go :: Type -> Expression () -> Expression ()
33 go :: Type -> Expression () -> Expression ()
19 go tipe x =
34 go tipe x =
@@ -21,15 +36,15 @@ incoming t = ["v"] ==> go t (ref "v")
21 Lambda _ _ -> error "functions should not be allowed through input ports"
36 Lambda _ _ -> error "functions should not be allowed through input ports"
22 Var _ -> error "type variables should not be allowed through input ports"
37 Var _ -> error "type variables should not be allowed through input ports"
23 Data ctor []
38 Data ctor []
24− | ctor == "Int" -> elm "Int" [typeof "number"]
39+ | ctor == "Int" -> elm JSNumber
25− | ctor == "Float" -> elm "Float" [typeof "number"]
40+ | ctor == "Float" -> elm JSNumber
26− | ctor == "Bool" -> elm "Bool" [typeof "boolean"]
41+ | ctor == "Bool" -> elm JSBoolean
27− | ctor == "String" -> elm "String" [typeof "string", instanceof "String"]
42+ | ctor == "String" -> elm JSString
28− | ctor == "JavaScript.JSNumber" -> js [typeof "number"]
43+ | ctor == "JavaScript.JSNumber" -> js JSNumber
29− | ctor == "JavaScript.JSBool" -> js [typeof "boolean"]
44+ | ctor == "JavaScript.JSBool" -> js JSBoolean
30− | ctor == "JavaScript.JSString" -> js [typeof "string", instanceof "String"]
45+ | ctor == "JavaScript.JSString" -> js JSString
31 where
46 where
32− elm out checks = check x checks (obj ("_J.to" ++ out) <| x)
47+ elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)
33 js checks = check x checks x
48 js checks = check x checks x
34
49
35 Data ctor [t]
50 Data ctor [t]
@@ -38,15 +53,12 @@ incoming t = ["v"] ==> go t (ref "v")
38 (obj "Maybe.Nothing")
53 (obj "Maybe.Nothing")
39 (obj "Maybe.Just" <| go t x)
54 (obj "Maybe.Just" <| go t x)
40
55
41− | ctor == "Signal.Signal" ->
42− obj "Native.Ports.incomingSignal" <| incoming t
43−
44 | ctor == "_List" ->
56 | ctor == "_List" ->
45− check x [instanceof "Array"] (obj "_J.toList" <| array)
57+ check x JSArray (obj "_J.toList" <| array)
46 where
58 where
47 array = DotRef () x (var "map") <| incoming t
59 array = DotRef () x (var "map") <| incoming t
48
60
49− Data ctor ts | Help.isTuple ctor -> check x [instanceof "Array"] tuple
61+ Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
50 where
62 where
51 tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
63 tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
52 values = zipWith convert [0..] ts
64 values = zipWith convert [0..] ts
@@ -57,14 +69,17 @@ incoming t = ["v"] ==> go t (ref "v")
57
69
58 Record _ (Just _) -> error "bad record got to port generation code"
70 Record _ (Just _) -> error "bad record got to port generation code"
59
71
60− Record fields Nothing ->
72+ Record fields Nothing -> check x (JSObject (map fst fields)) object
61− check x (typeof "object" : map (member . fst) fields) object
62 where
73 where
63 object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
74 object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
64 keys = map convert fields
75 keys = map convert fields
65 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
76 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
66
77
67−outgoing t = ["v"] ==> go t (ref "v")
78+outgoing tipe =
79+ case tipe of
80+ Data "Signal.Signal" [t] ->
81+ obj "Native.Ports.outgoingSignal" <| outgoing t
82+ _ -> ["v"] ==> go tipe (ref "v")
68 where
83 where
69 go :: Type -> Expression () -> Expression ()
84 go :: Type -> Expression () -> Expression ()
70 go tipe x =
85 go tipe x =
@@ -83,11 +98,8 @@ outgoing t = ["v"] ==> go t (ref "v")
83 (NullLit ())
98 (NullLit ())
84 (DotRef () x (var "_0"))
99 (DotRef () x (var "_0"))
85
100
86− | ctor == "Signal.Signal" ->
87− obj "Native.Ports.outgoingSignal" <| incoming t
88−
89 | ctor == "_List" ->
101 | ctor == "_List" ->
90− DotRef () (obj "_J.fromList" <| x) (var "map") <| incoming t
102+ DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
91
103
92 Data ctor ts | Help.isTuple ctor ->
104 Data ctor ts | Help.isTuple ctor ->
93 ArrayLit () $ zipWith convert [0..] ts
105 ArrayLit () $ zipWith convert [0..] ts