git.iko.soy/elk
on fb08d70 help sign in
elk/src/Generate/JavaScript/Port.hs
277 lines 7.8 kB history raw
1module Generate.JavaScript.Port (inbound, outbound, task) where
3import qualified Data.List as List
4import Language.ECMAScript3.Syntax
6import qualified AST.Type as T
7import qualified AST.Variable as Var
8import Generate.JavaScript.Helpers
9import qualified Reporting.PrettyPrint as P
12-- TASK
14task :: String -> Expression () -> T.Port t -> Expression ()
15task name expr portType =
16 case portType of
17 T.Normal _ ->
18 _Task "perform" `call` [ expr ]
20 T.Signal _ _ ->
21 _Task "performSignal" `call` [ string name, expr ]
25-- HELPERS
27data JSType
28 = JSNumber
29 | JSBoolean
30 | JSString
31 | JSArray
32 | JSObject [String]
35typeToString :: JSType -> String
36typeToString tipe =
37 case tipe of
38 JSNumber -> "a number"
39 JSBoolean -> "a boolean (true or false)"
40 JSString -> "a string"
41 JSArray -> "an array"
42 JSObject fields ->
43 "an object with fields '" ++ List.intercalate "', '" fields ++ "'"
46_Array :: String -> Expression ()
47_Array functionName =
48 useLazy ["Elm","Native","Array"] functionName
51_List :: String -> Expression ()
52_List functionName =
53 useLazy ["Elm","Native","List"] functionName
56_Maybe :: String -> Expression ()
57_Maybe functionName =
58 useLazy ["Elm","Maybe"] functionName
61_Port :: String -> Expression ()
62_Port functionName =
63 useLazy ["Elm","Native","Port"] functionName
66_Task :: String -> Expression ()
67_Task functionName =
68 useLazy ["Elm","Native","Task"] functionName
71check :: Expression () -> JSType -> Expression () -> Expression ()
72check x jsType continue =
73 CondExpr () (jsFold OpLOr checks x) continue throw
74 where
75 jsFold op checks value =
76 foldl1 (InfixExpr () op) (map ($ value) checks)
78 throw =
79 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
81 checks =
82 case jsType of
83 JSNumber -> [typeof "number"]
84 JSBoolean -> [typeof "boolean"]
85 JSString -> [typeof "string", instanceof "String"]
86 JSArray -> [instanceof "Array"]
87 JSObject fields ->
88 [jsFold OpLAnd (typeof "object" : map member fields)]
91-- INBOUND
93inbound :: String -> T.Port T.Canonical -> Expression ()
94inbound name portType =
95 case portType of
96 T.Normal tipe ->
97 _Port "inbound" `call`
98 [ string name
99 , string (show (P.pretty False tipe))
100 , toTypeFunction tipe
101 ]
103 T.Signal _root arg ->
104 _Port "inboundSignal" `call`
105 [ string name
106 , string (show (P.pretty False arg))
107 , toTypeFunction arg
108 ]
111toTypeFunction :: T.Canonical -> Expression ()
112toTypeFunction tipe =
113 ["v"] ==> toType tipe (ref "v")
116toType :: T.Canonical -> Expression () -> Expression ()
117toType tipe x =
118 case tipe of
119 T.Lambda _ _ ->
120 error "functions should not be allowed through input ports"
122 T.Var _ ->
123 error "type variables should not be allowed through input ports"
125 T.Aliased _ args t ->
126 toType (T.dealias args t) x
128 T.Type (Var.Canonical Var.BuiltIn name)
129 | name == "Int" -> from JSNumber
130 | name == "Float" -> from JSNumber
131 | name == "Bool" -> from JSBoolean
132 | name == "String" -> from JSString
133 where
134 from checks = check x checks x
136 T.Type name
137 | Var.isJson name ->
138 x
140 | Var.isTuple name ->
141 toTuple [] x
143 | otherwise ->
144 error "bad type got to foreign input conversion"
146 T.App f args ->
147 case f : args of
148 T.Type name : [t]
149 | Var.isMaybe name ->
150 CondExpr ()
151 (equal x (NullLit ()))
152 (_Maybe "Nothing")
153 (_Maybe "Just" <| toType t x)
155 | Var.isList name ->
156 check x JSArray (_List "fromArray" <| array)
158 | Var.isArray name ->
159 check x JSArray (_Array "fromJSArray" <| array)
160 where
161 array = DotRef () x (var "map") <| toTypeFunction t
163 T.Type name : ts
164 | Var.isTuple name ->
165 toTuple ts x
167 _ -> error "bad ADT got to foreign input conversion"
169 T.Record _ (Just _) ->
170 error "bad record got to foreign input conversion"
172 T.Record fields Nothing ->
173 check x (JSObject (map fst fields)) object
174 where
175 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
176 keys = map convert fields
177 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
180toTuple :: [T.Canonical] -> Expression () -> Expression ()
181toTuple types x =
182 check x JSArray (ObjectLit () fields)
183 where
184 fields =
185 (prop "ctor", ctor) : zipWith convert [0..] types
187 ctor =
188 string ("_Tuple" ++ show (length types))
190 convert n t =
191 ( prop ('_':show n)
192 , toType t (BracketRef () x (IntLit () n))
193 )
196-- OUTBOUND
198outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
199outbound name expr portType =
200 case portType of
201 T.Normal tipe ->
202 _Port "outbound" `call` [ string name, fromTypeFunction tipe, expr ]
204 T.Signal _ arg ->
205 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]
208fromTypeFunction :: T.Canonical -> Expression ()
209fromTypeFunction tipe =
210 ["v"] ==> fromType tipe (ref "v")
213fromType :: T.Canonical -> Expression () -> Expression ()
214fromType tipe x =
215 case tipe of
216 T.Aliased _ args t ->
217 fromType (T.dealias args t) x
219 T.Lambda _ _
220 | numArgs > 1 && numArgs < 10 ->
221 func (ref ('A':show numArgs) `call` (x:values))
222 | otherwise ->
223 func (foldl (<|) x values)
224 where
225 ts = T.collectLambdas tipe
226 numArgs = length ts - 1
227 args = map (\n -> '_' : show n) [0..]
228 values = zipWith toType (init ts) (map ref args)
229 func body =
230 function (take numArgs args)
231 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
232 , ret (fromType (last ts) (ref "_r"))
233 ]
235 T.Var _ ->
236 error "type variables should not be allowed through outputs"
238 T.Type (Var.Canonical Var.BuiltIn name)
239 | name `elem` ["Int","Float","Bool","String"] ->
240 x
242 T.Type name
243 | Var.isJson name -> x
244 | Var.isTuple name -> ArrayLit () []
245 | otherwise -> error "bad type got to an output"
247 T.App f args ->
248 case f : args of
249 T.Type name : [t]
250 | Var.isMaybe name ->
251 CondExpr ()
252 (equal (DotRef () x (var "ctor")) (string "Nothing"))
253 (NullLit ())
254 (fromType t (DotRef () x (var "_0")))
256 | Var.isArray name ->
257 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
259 | Var.isList name ->
260 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
262 T.Type name : ts
263 | Var.isTuple name ->
264 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
265 in ArrayLit () $ zipWith convert [0..] ts
267 _ -> error "bad ADT got to an output"
269 T.Record _ (Just _) ->
270 error "bad record got to an output"
272 T.Record fields Nothing ->
273 ObjectLit () keys
274 where
275 keys = map convert fields
276 convert (f,t) =
277 (PropId () (var f), fromType t (DotRef () x (var f)))