git.iko.soy/elk
on master help sign in
Allow promises through ports
6775458Evan Czaplicki
src/AST/Type.hs+27−1
compare with master
unifiedsplit
@@ -1,6 +1,7 @@
1module AST.Type where
1module AST.Type where
2
2
3import Control.Applicative ((<$>), (<*>))
3import Control.Applicative ((<$>), (<*>))
4+import Control.Arrow (second)
4import Data.Binary
5import Data.Binary
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6
7
@@ -30,7 +31,10 @@ type CanonicalType =
30
31
31fieldMap :: [(String,a)] -> Map.Map String [a]
32fieldMap :: [(String,a)] -> Map.Map String [a]
32fieldMap fields =
33fieldMap fields =
34+ let add r (field,tipe) =
33− foldl (\r (field,tipe) -> Map.insertWith (++) field [tipe] r) Map.empty fields
35+ Map.insertWith (++) field [tipe] r
36+ in
37+ foldl add Map.empty fields
34
38
35
39
36recordOf :: [(String, Type var)] -> Type var
40recordOf :: [(String, Type var)] -> Type var
@@ -50,6 +54,28 @@ tupleOf types =
50 App (Type name) types
54 App (Type name) types
51
55
52
56
57+dealias :: Type v -> Type v
58+dealias tipe =
59+ case tipe of
60+ Lambda arg body ->
61+ Lambda (dealias arg) (dealias body)
62+
63+ Var _ ->
64+ tipe
65+
66+ Type _ ->
67+ tipe
68+
69+ App f args ->
70+ App (dealias f) (map dealias args)
71+
72+ Record fields ext ->
73+ Record (map (second dealias) fields) (fmap dealias ext)
74+
75+ Aliased _ t ->
76+ dealias t
77+
78+
53instance (Var.ToString var, Pretty var) => Pretty (Type var) where
79instance (Var.ToString var, Pretty var) => Pretty (Type var) where
54 pretty tipe =
80 pretty tipe =
55 case tipe of
81 case tipe of
src/AST/Variable.hs+5
@@ -63,6 +63,11 @@ isSignal =
63 is ["Signal"] "Signal"
63 is ["Signal"] "Signal"
64
64
65
65
66+isPromise :: Canonical -> Bool
67+isPromise =
68+ is ["Promise"] "Promise"
69+
70+
66isList :: Canonical -> Bool
71isList :: Canonical -> Bool
67isList v =
72isList v =
68 v == Canonical BuiltIn "List"
73 v == Canonical BuiltIn "List"
src/Generate/JavaScript/Ports.hs+25−10
@@ -66,7 +66,8 @@ incoming tipe =
66 Aliased _ t -> incoming t
66 Aliased _ t -> incoming t
67
67
68 App (Type v) [t]
68 App (Type v) [t]
69+ | Var.isSignal v ->
69− | Var.isSignal v -> obj ["_P","incomingSignal"] <| incoming t
70+ obj ["_P","incomingSignal"] <| incoming t
70
71
71 _ -> ["v"] ==> inc tipe (ref "v")
72 _ -> ["v"] ==> inc tipe (ref "v")
72
73
@@ -124,10 +125,10 @@ inc tipe x =
124
125
125 Record fields Nothing ->
126 Record fields Nothing ->
126 check x (JSObject (map fst fields)) object
127 check x (JSObject (map fst fields)) object
127− where
128+ where
128− object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
129+ object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
129− keys = map convert fields
130+ keys = map convert fields
130− convert (f,t) = (prop f, inc t (DotRef () x (var f)))
131+ convert (f,t) = (prop f, inc t (DotRef () x (var f)))
131
132
132
133
133incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
134incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
@@ -146,11 +147,25 @@ incomingTuple types x =
146
147
147outgoing :: CanonicalType -> Expression ()
148outgoing :: CanonicalType -> Expression ()
148outgoing tipe =
149outgoing tipe =
149− case tipe of
150+ case T.dealias tipe of
150− Aliased _ t -> outgoing t
151+ App (Type signal) [ App (Type promise) [_,_] ]
152+ | Var.isSignal signal && Var.isPromise promise ->
153+ obj ["_P","promiseStream"]
154+
155+ App (Type promise) [_,_]
156+ | Var.isPromise promise ->
157+ obj ["_P","promise"]
151
158
159+ _ ->
160+ outgoingFunc tipe
161+
162+
163+outgoingFunc :: CanonicalType -> Expression ()
164+outgoingFunc tipe =
165+ case tipe of
152 App (Type v) [t]
166 App (Type v) [t]
167+ | Var.isSignal v ->
153− | Var.isSignal v -> obj ["_P","outgoingSignal"] <| outgoing t
168+ obj ["_P","outgoingSignal"] <| outgoingFunc t
154
169
155 _ -> ["v"] ==> out tipe (ref "v")
170 _ -> ["v"] ==> out tipe (ref "v")
156
171
@@ -195,10 +210,10 @@ out tipe x =
195 (out t (DotRef () x (var "_0")))
210 (out t (DotRef () x (var "_0")))
196
211
197 | Var.isArray name ->
212 | Var.isArray name ->
198− DotRef () (_Array "toJSArray" <| x) (var "map") <| outgoing t
213+ DotRef () (_Array "toJSArray" <| x) (var "map") <| outgoingFunc t
199
214
200 | Var.isList name ->
215 | Var.isList name ->
201− DotRef () (_List "toArray" <| x) (var "map") <| outgoing t
216+ DotRef () (_List "toArray" <| x) (var "map") <| outgoingFunc t
202
217
203 Type name : ts
218 Type name : ts
204 | Var.isTuple name ->
219 | Var.isTuple name ->
src/Type/ExtraChecks.hs+7−1
@@ -93,6 +93,12 @@ portTypes expr =
93 | V.isArray v -> valid t
93 | V.isArray v -> valid t
94 | V.isList v -> valid t
94 | V.isList v -> valid t
95
95
96+ ST.App (ST.Type v) [_, _]
97+ | V.isPromise v ->
98+ case direction of
99+ In -> err "promises"
100+ Out -> return ()
101+
96 ST.App (ST.Type v) ts
102 ST.App (ST.Type v) ts
97 | V.isTuple v -> mapM_ valid ts
103 | V.isTuple v -> mapM_ valid ts
98
104
@@ -135,7 +141,7 @@ portTypes expr =
135 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
141 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
136 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
142 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
137 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
143 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
138− , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
144+ , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
139 ]
145 ]
140
146
141
147