git.iko.soy/elk
on e7a4551 help sign in
elk/src/Generate/JavaScript/Port.hs
287 lines 8.2 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 -> [typeof "number"]
87 JSInt ->
88 [jsFold OpLAnd (typeof "number" : intChecks)]
89 JSBoolean -> [typeof "boolean"]
90 JSString -> [typeof "string", instanceof "String"]
91 JSArray -> [instanceof "Array"]
92 JSObject fields ->
93 [jsFold OpLAnd (typeof "object" : map member fields)]
95 intChecks =
96 [ \x -> ref "isFinite" <| x
97 , \x -> equal (obj ["Math","floor"] <| x) x
98 ]
101-- INBOUND
103inbound :: String -> T.Port T.Canonical -> Expression ()
104inbound name portType =
105 case portType of
106 T.Normal tipe ->
107 _Port "inbound" `call`
108 [ StringLit () name
109 , StringLit () (show (RenderType.toDoc Map.empty tipe))
110 , toTypeFunction tipe
111 ]
113 T.Signal _root arg ->
114 _Port "inboundSignal" `call`
115 [ StringLit () name
116 , StringLit () (show (RenderType.toDoc Map.empty arg))
117 , toTypeFunction arg
118 ]
121toTypeFunction :: T.Canonical -> Expression ()
122toTypeFunction tipe =
123 function ["v"] [ ReturnStmt () (Just (toType tipe (ref "v"))) ]
126toType :: T.Canonical -> Expression () -> Expression ()
127toType tipe x =
128 case tipe of
129 T.Lambda _ _ ->
130 error "functions should not be allowed through input ports"
132 T.Var _ ->
133 error "type variables should not be allowed through input ports"
135 T.Aliased _ args t ->
136 toType (T.dealias args t) x
138 T.Type (Var.Canonical Var.BuiltIn name)
139 | name == "Float" -> from JSNumber
140 | name == "Int" -> from JSInt
141 | name == "Bool" -> from JSBoolean
142 | name == "String" -> from JSString
143 where
144 from checks = check x checks x
146 T.Type name
147 | Var.isJson name ->
148 x
150 | Var.isTuple name ->
151 toTuple [] x
153 | otherwise ->
154 error "bad type got to foreign input conversion"
156 T.App f args ->
157 case f : args of
158 T.Type name : [t]
159 | Var.isMaybe name ->
160 CondExpr ()
161 (equal x (NullLit ()))
162 (_Maybe "Nothing")
163 (_Maybe "Just" <| toType t x)
165 | Var.isList name ->
166 check x JSArray (_List "fromArray" <| array)
168 | Var.isArray name ->
169 check x JSArray (_Array "fromJSArray" <| array)
170 where
171 array = DotRef () x (var "map") <| toTypeFunction t
173 T.Type name : ts
174 | Var.isTuple name ->
175 toTuple ts x
177 _ -> error "bad ADT got to foreign input conversion"
179 T.Record _ (Just _) ->
180 error "bad record got to foreign input conversion"
182 T.Record fields Nothing ->
183 check x (JSObject (map fst fields)) object
184 where
185 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
186 keys = map convert fields
187 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
190toTuple :: [T.Canonical] -> Expression () -> Expression ()
191toTuple types x =
192 check x JSArray (ObjectLit () fields)
193 where
194 fields =
195 (prop "ctor", ctor) : zipWith convert [0..] types
197 ctor =
198 StringLit () ("_Tuple" ++ show (length types))
200 convert n t =
201 ( prop ('_':show n)
202 , toType t (BracketRef () x (IntLit () n))
203 )
206-- OUTBOUND
208outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
209outbound name expr portType =
210 case portType of
211 T.Normal tipe ->
212 _Port "outbound" `call` [ StringLit () name, fromTypeFunction tipe, expr ]
214 T.Signal _ arg ->
215 _Port "outboundSignal" `call` [ StringLit () name, fromTypeFunction arg, expr ]
218fromTypeFunction :: T.Canonical -> Expression ()
219fromTypeFunction tipe =
220 function ["v"] [ ReturnStmt () (Just (fromType tipe (ref "v"))) ]
223fromType :: T.Canonical -> Expression () -> Expression ()
224fromType tipe x =
225 case tipe of
226 T.Aliased _ args t ->
227 fromType (T.dealias args t) x
229 T.Lambda _ _
230 | numArgs > 1 && numArgs < 10 ->
231 func (ref ('A':show numArgs) `call` (x:values))
232 | otherwise ->
233 func (foldl (<|) x values)
234 where
235 ts = T.collectLambdas tipe
236 numArgs = length ts - 1
237 args = map (\n -> '_' : show n) [0..]
238 values = zipWith toType (init ts) (map ref args)
239 func body =
240 function (take numArgs args)
241 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
242 , ReturnStmt () (Just (fromType (last ts) (ref "_r")))
243 ]
245 T.Var _ ->
246 error "type variables should not be allowed through outputs"
248 T.Type (Var.Canonical Var.BuiltIn name)
249 | name `elem` ["Int","Float","Bool","String"] ->
250 x
252 T.Type name
253 | Var.isJson name -> x
254 | Var.isTuple name -> ArrayLit () []
255 | otherwise -> error "bad type got to an output"
257 T.App f args ->
258 case f : args of
259 T.Type name : [t]
260 | Var.isMaybe name ->
261 CondExpr ()
262 (equal (DotRef () x (var "ctor")) (StringLit () "Nothing"))
263 (NullLit ())
264 (fromType t (DotRef () x (var "_0")))
266 | Var.isArray name ->
267 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
269 | Var.isList name ->
270 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
272 T.Type name : ts
273 | Var.isTuple name ->
274 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
275 in ArrayLit () $ zipWith convert [0..] ts
277 _ -> error "bad ADT got to an output"
279 T.Record _ (Just _) ->
280 error "bad record got to an output"
282 T.Record fields Nothing ->
283 ObjectLit () keys
284 where
285 keys = map convert fields
286 convert (f,t) =
287 (PropId () (var f), fromType t (DotRef () x (var f)))