git.iko.soy/elk
on 2d29699 help sign in
elk/src/Generate/JavaScript/Port.hs
278 lines 7.8 kB history raw
1module Generate.JavaScript.Port (inbound, outbound, task) where
3import qualified Data.List as List
4import qualified Data.Map as Map
5import Language.ECMAScript3.Syntax
7import qualified AST.Type as T
8import qualified AST.Variable as Var
9import Generate.JavaScript.Helpers
10import qualified Reporting.PrettyPrint as P
13-- TASK
15task :: String -> Expression () -> T.Port t -> Expression ()
16task name expr portType =
17 case portType of
18 T.Normal _ ->
19 _Task "perform" `call` [ expr ]
21 T.Signal _ _ ->
22 _Task "performSignal" `call` [ string name, expr ]
26-- HELPERS
28data JSType
29 = JSNumber
30 | JSBoolean
31 | JSString
32 | JSArray
33 | JSObject [String]
36typeToString :: JSType -> String
37typeToString tipe =
38 case tipe of
39 JSNumber -> "a number"
40 JSBoolean -> "a boolean (true or false)"
41 JSString -> "a string"
42 JSArray -> "an array"
43 JSObject fields ->
44 "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"
47_Array :: String -> Expression ()
48_Array functionName =
49 useLazy ["Elm","Native","Array"] functionName
52_List :: String -> Expression ()
53_List functionName =
54 useLazy ["Elm","Native","List"] functionName
57_Maybe :: String -> Expression ()
58_Maybe functionName =
59 useLazy ["Elm","Maybe"] functionName
62_Port :: String -> Expression ()
63_Port functionName =
64 useLazy ["Elm","Native","Port"] functionName
67_Task :: String -> Expression ()
68_Task functionName =
69 useLazy ["Elm","Native","Task"] functionName
72check :: Expression () -> JSType -> Expression () -> Expression ()
73check x jsType continue =
74 CondExpr () (jsFold OpLOr checks x) continue throw
75 where
76 jsFold op checks value =
77 foldl1 (InfixExpr () op) (map ($ value) checks)
79 throw =
80 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
82 checks =
83 case jsType of
84 JSNumber -> [typeof "number"]
85 JSBoolean -> [typeof "boolean"]
86 JSString -> [typeof "string", instanceof "String"]
87 JSArray -> [instanceof "Array"]
88 JSObject fields ->
89 [jsFold OpLAnd (typeof "object" : map member fields)]
92-- INBOUND
94inbound :: String -> T.Port T.Canonical -> Expression ()
95inbound name portType =
96 case portType of
97 T.Normal tipe ->
98 _Port "inbound" `call`
99 [ string name
100 , string (show (P.pretty Map.empty False tipe))
101 , toTypeFunction tipe
102 ]
104 T.Signal _root arg ->
105 _Port "inboundSignal" `call`
106 [ string name
107 , string (show (P.pretty Map.empty False arg))
108 , toTypeFunction arg
109 ]
112toTypeFunction :: T.Canonical -> Expression ()
113toTypeFunction tipe =
114 ["v"] ==> toType tipe (ref "v")
117toType :: T.Canonical -> Expression () -> Expression ()
118toType tipe x =
119 case tipe of
120 T.Lambda _ _ ->
121 error "functions should not be allowed through input ports"
123 T.Var _ ->
124 error "type variables should not be allowed through input ports"
126 T.Aliased _ args t ->
127 toType (T.dealias args t) x
129 T.Type (Var.Canonical Var.BuiltIn name)
130 | name == "Int" -> from JSNumber
131 | name == "Float" -> from JSNumber
132 | name == "Bool" -> from JSBoolean
133 | name == "String" -> from JSString
134 where
135 from checks = check x checks x
137 T.Type name
138 | Var.isJson name ->
139 x
141 | Var.isTuple name ->
142 toTuple [] x
144 | otherwise ->
145 error "bad type got to foreign input conversion"
147 T.App f args ->
148 case f : args of
149 T.Type name : [t]
150 | Var.isMaybe name ->
151 CondExpr ()
152 (equal x (NullLit ()))
153 (_Maybe "Nothing")
154 (_Maybe "Just" <| toType t x)
156 | Var.isList name ->
157 check x JSArray (_List "fromArray" <| array)
159 | Var.isArray name ->
160 check x JSArray (_Array "fromJSArray" <| array)
161 where
162 array = DotRef () x (var "map") <| toTypeFunction t
164 T.Type name : ts
165 | Var.isTuple name ->
166 toTuple ts x
168 _ -> error "bad ADT got to foreign input conversion"
170 T.Record _ (Just _) ->
171 error "bad record got to foreign input conversion"
173 T.Record fields Nothing ->
174 check x (JSObject (map fst fields)) object
175 where
176 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
177 keys = map convert fields
178 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
181toTuple :: [T.Canonical] -> Expression () -> Expression ()
182toTuple types x =
183 check x JSArray (ObjectLit () fields)
184 where
185 fields =
186 (prop "ctor", ctor) : zipWith convert [0..] types
188 ctor =
189 string ("_Tuple" ++ show (length types))
191 convert n t =
192 ( prop ('_':show n)
193 , toType t (BracketRef () x (IntLit () n))
194 )
197-- OUTBOUND
199outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
200outbound name expr portType =
201 case portType of
202 T.Normal tipe ->
203 _Port "outbound" `call` [ string name, fromTypeFunction tipe, expr ]
205 T.Signal _ arg ->
206 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]
209fromTypeFunction :: T.Canonical -> Expression ()
210fromTypeFunction tipe =
211 ["v"] ==> fromType tipe (ref "v")
214fromType :: T.Canonical -> Expression () -> Expression ()
215fromType tipe x =
216 case tipe of
217 T.Aliased _ args t ->
218 fromType (T.dealias args t) x
220 T.Lambda _ _
221 | numArgs > 1 && numArgs < 10 ->
222 func (ref ('A':show numArgs) `call` (x:values))
223 | otherwise ->
224 func (foldl (<|) x values)
225 where
226 ts = T.collectLambdas tipe
227 numArgs = length ts - 1
228 args = map (\n -> '_' : show n) [0..]
229 values = zipWith toType (init ts) (map ref args)
230 func body =
231 function (take numArgs args)
232 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
233 , ret (fromType (last ts) (ref "_r"))
234 ]
236 T.Var _ ->
237 error "type variables should not be allowed through outputs"
239 T.Type (Var.Canonical Var.BuiltIn name)
240 | name `elem` ["Int","Float","Bool","String"] ->
241 x
243 T.Type name
244 | Var.isJson name -> x
245 | Var.isTuple name -> ArrayLit () []
246 | otherwise -> error "bad type got to an output"
248 T.App f args ->
249 case f : args of
250 T.Type name : [t]
251 | Var.isMaybe name ->
252 CondExpr ()
253 (equal (DotRef () x (var "ctor")) (string "Nothing"))
254 (NullLit ())
255 (fromType t (DotRef () x (var "_0")))
257 | Var.isArray name ->
258 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
260 | Var.isList name ->
261 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
263 T.Type name : ts
264 | Var.isTuple name ->
265 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
266 in ArrayLit () $ zipWith convert [0..] ts
268 _ -> error "bad ADT got to an output"
270 T.Record _ (Just _) ->
271 error "bad record got to an output"
273 T.Record fields Nothing ->
274 ObjectLit () keys
275 where
276 keys = map convert fields
277 convert (f,t) =
278 (PropId () (var f), fromType t (DotRef () x (var f)))