git.iko.soy/elk
on 69a4366 help sign in
elk/src/Generate/JavaScript/Ports.hs
232 lines 6.9 kB history raw
1module Generate.JavaScript.Ports (incoming, outgoing) where
3import qualified Data.List as List
4import Generate.JavaScript.Helpers
5import AST.Type as T
6import qualified AST.Variable as Var
7import Language.ECMAScript3.Syntax
10data JSType
11 = JSNumber
12 | JSBoolean
13 | JSString
14 | JSArray
15 | JSObject [String]
18typeToString :: JSType -> String
19typeToString tipe =
20 case tipe of
21 JSNumber -> "a number"
22 JSBoolean -> "a boolean (true or false)"
23 JSString -> "a string"
24 JSArray -> "an array"
25 JSObject fields ->
26 "an object with fields '" ++ List.intercalate "', '" fields ++ "'"
29_Array :: String -> Expression ()
30_Array functionName =
31 useLazy ["Elm","Native","Array"] functionName
34_List :: String -> Expression ()
35_List functionName =
36 useLazy ["Elm","Native","List"] functionName
39_Maybe :: String -> Expression ()
40_Maybe functionName =
41 useLazy ["Elm","Maybe"] functionName
44check :: Expression () -> JSType -> Expression () -> Expression ()
45check x jsType continue =
46 CondExpr () (jsFold OpLOr checks x) continue throw
47 where
48 jsFold op checks value =
49 foldl1 (InfixExpr () op) (map ($ value) checks)
51 throw =
52 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
54 checks =
55 case jsType of
56 JSNumber -> [typeof "number"]
57 JSBoolean -> [typeof "boolean"]
58 JSString -> [typeof "string", instanceof "String"]
59 JSArray -> [instanceof "Array"]
60 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
63incoming :: CanonicalType -> Expression ()
64incoming tipe =
65 case tipe of
66 Aliased _ t -> incoming t
68 App (Type v) [t]
69 | Var.isSignal v ->
70 obj ["_P","incomingSignal"] <| incoming t
72 _ -> ["v"] ==> inc tipe (ref "v")
75inc :: CanonicalType -> Expression () -> Expression ()
76inc tipe x =
77 case tipe of
78 Lambda _ _ -> error "functions should not be allowed through input ports"
79 Var _ -> error "type variables should not be allowed through input ports"
80 Aliased _ t ->
81 inc t x
83 Type (Var.Canonical Var.BuiltIn name)
84 | name == "Int" -> from JSNumber
85 | name == "Float" -> from JSNumber
86 | name == "Bool" -> from JSBoolean
87 | name == "String" -> from JSString
88 where
89 from checks = check x checks x
91 Type name
92 | Var.isJson name ->
93 x
95 | Var.isTuple name ->
96 incomingTuple [] x
98 | otherwise ->
99 error "bad type got to incoming port generation code"
101 App f args ->
102 case f : args of
103 Type name : [t]
104 | Var.isMaybe name ->
105 CondExpr ()
106 (equal x (NullLit ()))
107 (_Maybe "Nothing")
108 (_Maybe "Just" <| inc t x)
110 | Var.isList name ->
111 check x JSArray (_List "fromArray" <| array)
113 | Var.isArray name ->
114 check x JSArray (_Array "fromJSArray" <| array)
115 where
116 array = DotRef () x (var "map") <| incoming t
118 Type name : ts
119 | Var.isTuple name -> incomingTuple ts x
121 _ -> error "bad ADT got to incoming port generation code"
123 Record _ (Just _) ->
124 error "bad record got to incoming port generation code"
126 Record fields Nothing ->
127 check x (JSObject (map fst fields)) object
128 where
129 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
130 keys = map convert fields
131 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
134incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
135incomingTuple types x =
136 check x JSArray (ObjectLit () fields)
137 where
138 fields = (prop "ctor", ctor) : zipWith convert [0..] types
140 ctor = string ("_Tuple" ++ show (length types))
142 convert n t =
143 ( prop ('_':show n)
144 , inc t (BracketRef () x (IntLit () n))
145 )
148outgoing :: CanonicalType -> Expression ()
149outgoing tipe =
150 case T.dealias tipe of
151 App (Type signal) [ App (Type promise) [_,_] ]
152 | Var.isSignal signal && Var.isPromise promise ->
153 obj ["_P","promiseStream"]
155 App (Type promise) [_,_]
156 | Var.isPromise promise ->
157 obj ["_P","promise"]
159 _ ->
160 outgoingFunc tipe
163outgoingFunc :: CanonicalType -> Expression ()
164outgoingFunc tipe =
165 case tipe of
166 App (Type v) [t]
167 | Var.isSignal v ->
168 obj ["_P","outgoingSignal"] <| outgoingFunc t
170 _ -> ["v"] ==> out tipe (ref "v")
173out :: CanonicalType -> Expression () -> Expression ()
174out tipe x =
175 case tipe of
176 Aliased _ t -> out t x
178 Lambda _ _
179 | numArgs > 1 && numArgs < 10 ->
180 func (ref ('A':show numArgs) `call` (x:values))
181 | otherwise -> func (foldl (<|) x values)
182 where
183 ts = T.collectLambdas tipe
184 numArgs = length ts - 1
185 args = map (\n -> '_' : show n) [0..]
186 values = zipWith inc (init ts) (map ref args)
187 func body =
188 function (take numArgs args)
189 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
190 , ret (out (last ts) (ref "_r"))
191 ]
193 Var _ -> error "type variables should not be allowed through input ports"
195 Type (Var.Canonical Var.BuiltIn name)
196 | name `elem` ["Int","Float","Bool","String"] -> x
198 Type name
199 | Var.isJson name -> x
200 | Var.isTuple name -> ArrayLit () []
201 | otherwise -> error "bad type got to outgoing port generation code"
203 App f args ->
204 case f : args of
205 Type name : [t]
206 | Var.isMaybe name ->
207 CondExpr ()
208 (equal (DotRef () x (var "ctor")) (string "Nothing"))
209 (NullLit ())
210 (out t (DotRef () x (var "_0")))
212 | Var.isArray name ->
213 DotRef () (_Array "toJSArray" <| x) (var "map") <| outgoingFunc t
215 | Var.isList name ->
216 DotRef () (_List "toArray" <| x) (var "map") <| outgoingFunc t
218 Type name : ts
219 | Var.isTuple name ->
220 let convert n t = out t $ DotRef () x $ var ('_':show n)
221 in ArrayLit () $ zipWith convert [0..] ts
223 _ -> error "bad ADT got to outgoing port generation code"
225 Record _ (Just _) ->
226 error "bad record got to outgoing port generation code"
228 Record fields Nothing ->
229 ObjectLit () keys
230 where
231 keys = map convert fields
232 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))