git.iko.soy/elk
on d163289 help sign in
elk/src/Generate/JavaScript/Port.hs
299 lines 8.3 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.Render.Type as RenderType
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` [ StringLit () name, expr ]
26-- HELPERS
28data JSType
29 = JSNumber
30 | JSInt
31 | JSBoolean
32 | JSString
33 | JSArray
34 | JSObject [String]
37typeToString :: JSType -> String
38typeToString tipe =
39 case tipe of
40 JSNumber -> "a number"
41 JSInt -> "an integer"
42 JSBoolean -> "a boolean (true or false)"
43 JSString -> "a string"
44 JSArray -> "an array"
45 JSObject fields ->
46 "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"
49_Array :: String -> Expression ()
50_Array functionName =
51 useLazy ["Elm","Native","Array"] functionName
54_List :: String -> Expression ()
55_List functionName =
56 useLazy ["Elm","Native","List"] functionName
59_Maybe :: String -> Expression ()
60_Maybe functionName =
61 useLazy ["Elm","Maybe"] functionName
64_Port :: String -> Expression ()
65_Port functionName =
66 useLazy ["Elm","Native","Port"] functionName
69_Task :: String -> Expression ()
70_Task functionName =
71 useLazy ["Elm","Native","Task"] functionName
74check :: Expression () -> JSType -> Expression () -> Expression ()
75check x jsType continue =
76 CondExpr () (jsFold OpLOr checks x) continue throw
77 where
78 jsFold op checks value =
79 foldl1 (InfixExpr () op) (map ($ value) checks)
81 throw =
82 obj ["_U","badPort"] `call` [ StringLit () (typeToString jsType), x ]
84 checks =
85 case jsType of
86 JSNumber ->
87 [typeof "number"]
89 JSInt ->
90 [jsFold OpLAnd intChecks]
92 JSBoolean ->
93 [typeof "boolean"]
95 JSString ->
96 [typeof "string", instanceof "String"]
98 JSArray ->
99 [instanceof "Array"]
101 JSObject fields ->
102 [jsFold OpLAnd (typeof "object" : map member fields)]
105intChecks :: [Expression () -> Expression ()]
106intChecks =
107 [ typeof "number"
108 , \x -> ref "isFinite" <| x
109 , \x -> equal (obj ["Math","floor"] <| x) x
110 ]
113-- INBOUND
115inbound :: String -> T.Port T.Canonical -> Expression ()
116inbound name portType =
117 case portType of
118 T.Normal tipe ->
119 _Port "inbound" `call`
120 [ StringLit () name
121 , StringLit () (show (RenderType.toDoc Map.empty tipe))
122 , toTypeFunction tipe
123 ]
125 T.Signal _root arg ->
126 _Port "inboundSignal" `call`
127 [ StringLit () name
128 , StringLit () (show (RenderType.toDoc Map.empty arg))
129 , toTypeFunction arg
130 ]
133toTypeFunction :: T.Canonical -> Expression ()
134toTypeFunction tipe =
135 function ["v"] [ ReturnStmt () (Just (toType tipe (ref "v"))) ]
138toType :: T.Canonical -> Expression () -> Expression ()
139toType tipe x =
140 case tipe of
141 T.Lambda _ _ ->
142 error "functions should not be allowed through input ports"
144 T.Var _ ->
145 error "type variables should not be allowed through input ports"
147 T.Aliased _ args t ->
148 toType (T.dealias args t) x
150 T.Type (Var.Canonical Var.BuiltIn name)
151 | name == "Float" -> from JSNumber
152 | name == "Int" -> from JSInt
153 | name == "Bool" -> from JSBoolean
154 | name == "String" -> from JSString
155 where
156 from checks = check x checks x
158 T.Type name
159 | Var.isJson name ->
160 x
162 | Var.isTuple name ->
163 toTuple [] x
165 | otherwise ->
166 error "bad type got to foreign input conversion"
168 T.App f args ->
169 case f : args of
170 T.Type name : [t]
171 | Var.isMaybe name ->
172 CondExpr ()
173 (equal x (NullLit ()))
174 (_Maybe "Nothing")
175 (_Maybe "Just" <| toType t x)
177 | Var.isList name ->
178 check x JSArray (_List "fromArray" <| array)
180 | Var.isArray name ->
181 check x JSArray (_Array "fromJSArray" <| array)
182 where
183 array = DotRef () x (var "map") <| toTypeFunction t
185 T.Type name : ts
186 | Var.isTuple name ->
187 toTuple ts x
189 _ -> error "bad ADT got to foreign input conversion"
191 T.Record _ (Just _) ->
192 error "bad record got to foreign input conversion"
194 T.Record fields Nothing ->
195 check x (JSObject (map fst fields)) object
196 where
197 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
198 keys = map convert fields
199 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
202toTuple :: [T.Canonical] -> Expression () -> Expression ()
203toTuple types x =
204 check x JSArray (ObjectLit () fields)
205 where
206 fields =
207 (prop "ctor", ctor) : zipWith convert [0..] types
209 ctor =
210 StringLit () ("_Tuple" ++ show (length types))
212 convert n t =
213 ( prop ('_':show n)
214 , toType t (BracketRef () x (IntLit () n))
215 )
218-- OUTBOUND
220outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
221outbound name expr portType =
222 case portType of
223 T.Normal tipe ->
224 _Port "outbound" `call` [ StringLit () name, fromTypeFunction tipe, expr ]
226 T.Signal _ arg ->
227 _Port "outboundSignal" `call` [ StringLit () name, fromTypeFunction arg, expr ]
230fromTypeFunction :: T.Canonical -> Expression ()
231fromTypeFunction tipe =
232 function ["v"] [ ReturnStmt () (Just (fromType tipe (ref "v"))) ]
235fromType :: T.Canonical -> Expression () -> Expression ()
236fromType tipe x =
237 case tipe of
238 T.Aliased _ args t ->
239 fromType (T.dealias args t) x
241 T.Lambda _ _
242 | numArgs > 1 && numArgs < 10 ->
243 func (ref ('A':show numArgs) `call` (x:values))
244 | otherwise ->
245 func (foldl (<|) x values)
246 where
247 ts = T.collectLambdas tipe
248 numArgs = length ts - 1
249 args = map (\n -> '_' : show n) [0..]
250 values = zipWith toType (init ts) (map ref args)
251 func body =
252 function (take numArgs args)
253 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
254 , ReturnStmt () (Just (fromType (last ts) (ref "_r")))
255 ]
257 T.Var _ ->
258 error "type variables should not be allowed through outputs"
260 T.Type (Var.Canonical Var.BuiltIn name)
261 | name `elem` ["Int","Float","Bool","String"] ->
262 x
264 T.Type name
265 | Var.isJson name -> x
266 | Var.isTuple name -> ArrayLit () []
267 | otherwise -> error "bad type got to an output"
269 T.App f args ->
270 case f : args of
271 T.Type name : [t]
272 | Var.isMaybe name ->
273 CondExpr ()
274 (equal (DotRef () x (var "ctor")) (StringLit () "Nothing"))
275 (NullLit ())
276 (fromType t (DotRef () x (var "_0")))
278 | Var.isArray name ->
279 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
281 | Var.isList name ->
282 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
284 T.Type name : ts
285 | Var.isTuple name ->
286 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
287 in ArrayLit () $ zipWith convert [0..] ts
289 _ -> error "bad ADT got to an output"
291 T.Record _ (Just _) ->
292 error "bad record got to an output"
294 T.Record fields Nothing ->
295 ObjectLit () keys
296 where
297 keys = map convert fields
298 convert (f,t) =
299 (PropId () (var f), fromType t (DotRef () x (var f)))