git.iko.soy/elk
on 8913c30 help sign in
elk/src/Generate/JavaScript/Port.hs
260 lines 7.4 kB history raw
1module Generate.JavaScript.Port
2 ( inbound, inboundStream
3 , outbound, outboundStream
4 ) where
6import qualified Data.List as List
7import Language.ECMAScript3.Syntax
9import AST.PrettyPrint (pretty)
10import AST.Type as T
11import qualified AST.Variable as Var
12import Generate.JavaScript.Helpers
15data JSType
16 = JSNumber
17 | JSBoolean
18 | JSString
19 | JSArray
20 | JSObject [String]
23typeToString :: JSType -> String
24typeToString tipe =
25 case tipe of
26 JSNumber -> "a number"
27 JSBoolean -> "a boolean (true or false)"
28 JSString -> "a string"
29 JSArray -> "an array"
30 JSObject fields ->
31 "an object with fields '" ++ List.intercalate "', '" fields ++ "'"
34_Array :: String -> Expression ()
35_Array functionName =
36 useLazy ["Elm","Native","Array"] functionName
39_List :: String -> Expression ()
40_List functionName =
41 useLazy ["Elm","Native","List"] functionName
44_Maybe :: String -> Expression ()
45_Maybe functionName =
46 useLazy ["Elm","Maybe"] functionName
49_Port :: String -> Expression ()
50_Port functionName =
51 useLazy ["Elm","Native","Port"] functionName
54check :: Expression () -> JSType -> Expression () -> Expression ()
55check x jsType continue =
56 CondExpr () (jsFold OpLOr checks x) continue throw
57 where
58 jsFold op checks value =
59 foldl1 (InfixExpr () op) (map ($ value) checks)
61 throw =
62 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
64 checks =
65 case jsType of
66 JSNumber -> [typeof "number"]
67 JSBoolean -> [typeof "boolean"]
68 JSString -> [typeof "string", instanceof "String"]
69 JSArray -> [instanceof "Array"]
70 JSObject fields ->
71 [jsFold OpLAnd (typeof "object" : map member fields)]
74-- INBOUND
76inbound :: String -> CanonicalType -> Expression ()
77inbound name tipe =
78 _Port "inbound" `call`
79 [ string name
80 , string (show (pretty tipe))
81 , toTypeFunction tipe
82 ]
85inboundStream :: String -> CanonicalType -> Expression ()
86inboundStream name tipe =
87 _Port "inboundStream" `call`
88 [ string name
89 , string (show (pretty tipe))
90 , toTypeFunction tipe
91 ]
94toTypeFunction :: CanonicalType -> Expression ()
95toTypeFunction tipe =
96 ["v"] ==> toType tipe (ref "v")
99toType :: CanonicalType -> Expression () -> Expression ()
100toType tipe x =
101 case tipe of
102 Lambda _ _ ->
103 error "functions should not be allowed through input ports"
105 Var _ ->
106 error "type variables should not be allowed through input ports"
108 Aliased _ args t ->
109 toType (dealias args t) x
111 Type (Var.Canonical Var.BuiltIn name)
112 | name == "Int" -> from JSNumber
113 | name == "Float" -> from JSNumber
114 | name == "Bool" -> from JSBoolean
115 | name == "String" -> from JSString
116 where
117 from checks = check x checks x
119 Type name
120 | Var.isJavaScript name ->
121 x
123 | Var.isTuple name ->
124 toTuple [] x
126 | otherwise ->
127 error "bad type got to foreign input conversion"
129 App f args ->
130 case f : args of
131 Type name : [t]
132 | Var.isMaybe name ->
133 CondExpr ()
134 (equal x (NullLit ()))
135 (_Maybe "Nothing")
136 (_Maybe "Just" <| toType t x)
138 | Var.isList name ->
139 check x JSArray (_List "fromArray" <| array)
141 | Var.isArray name ->
142 check x JSArray (_Array "fromJSArray" <| array)
143 where
144 array = DotRef () x (var "map") <| toTypeFunction t
146 Type name : ts
147 | Var.isTuple name ->
148 toTuple ts x
150 _ -> error "bad ADT got to foreign input conversion"
152 Record _ (Just _) ->
153 error "bad record got to foreign input conversion"
155 Record fields Nothing ->
156 check x (JSObject (map fst fields)) object
157 where
158 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
159 keys = map convert fields
160 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
163toTuple :: [CanonicalType] -> Expression () -> Expression ()
164toTuple types x =
165 check x JSArray (ObjectLit () fields)
166 where
167 fields =
168 (prop "ctor", ctor) : zipWith convert [0..] types
170 ctor =
171 string ("_Tuple" ++ show (length types))
173 convert n t =
174 ( prop ('_':show n)
175 , toType t (BracketRef () x (IntLit () n))
176 )
179-- OUTBOUND
181outbound :: String -> CanonicalType -> Expression () -> Expression ()
182outbound name tipe expr =
183 _Port "outbound" `call` [ string name, fromTypeFunction tipe, expr ]
186outboundStream :: String -> CanonicalType -> Expression () -> Expression ()
187outboundStream name tipe expr =
188 _Port "outboundStream" `call` [ string name, fromTypeFunction tipe, expr ]
191fromTypeFunction :: CanonicalType -> Expression ()
192fromTypeFunction tipe =
193 ["v"] ==> fromType tipe (ref "v")
196fromType :: CanonicalType -> Expression () -> Expression ()
197fromType tipe x =
198 case tipe of
199 Aliased _ args t ->
200 fromType (dealias args t) x
202 Lambda _ _
203 | numArgs > 1 && numArgs < 10 ->
204 func (ref ('A':show numArgs) `call` (x:values))
205 | otherwise ->
206 func (foldl (<|) x values)
207 where
208 ts = T.collectLambdas tipe
209 numArgs = length ts - 1
210 args = map (\n -> '_' : show n) [0..]
211 values = zipWith toType (init ts) (map ref args)
212 func body =
213 function (take numArgs args)
214 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
215 , ret (fromType (last ts) (ref "_r"))
216 ]
218 Var _ ->
219 error "type variables should not be allowed through outputs"
221 Type (Var.Canonical Var.BuiltIn name)
222 | name `elem` ["Int","Float","Bool","String"] ->
223 x
225 Type name
226 | Var.isJavaScript name -> x
227 | Var.isTuple name -> ArrayLit () []
228 | otherwise -> error "bad type got to an output"
230 App f args ->
231 case f : args of
232 Type name : [t]
233 | Var.isMaybe name ->
234 CondExpr ()
235 (equal (DotRef () x (var "ctor")) (string "Nothing"))
236 (NullLit ())
237 (fromType t (DotRef () x (var "_0")))
239 | Var.isArray name ->
240 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
242 | Var.isList name ->
243 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
245 Type name : ts
246 | Var.isTuple name ->
247 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
248 in ArrayLit () $ zipWith convert [0..] ts
250 _ -> error "bad ADT got to an output"
252 Record _ (Just _) ->
253 error "bad record got to an output"
255 Record fields Nothing ->
256 ObjectLit () keys
257 where
258 keys = map convert fields
259 convert (f,t) =
260 (PropId () (var f), fromType t (DotRef () x (var f)))