git.iko.soy/elk
on 5cf1074 help sign in
elk/src/Generate/JavaScript/Port.hs
249 lines 7.0 kB history raw
1module Generate.JavaScript.Port (inbound, internal, outbound) where
3import qualified Data.List as List
4import Generate.JavaScript.Helpers
5import AST.PrettyPrint (pretty)
6import AST.Type as T
7import qualified AST.Variable as Var
8import Language.ECMAScript3.Syntax
11data JSType
12 = JSNumber
13 | JSBoolean
14 | JSString
15 | JSArray
16 | JSObject [String]
19typeToString :: JSType -> String
20typeToString tipe =
21 case tipe of
22 JSNumber -> "a number"
23 JSBoolean -> "a boolean (true or false)"
24 JSString -> "a string"
25 JSArray -> "an array"
26 JSObject fields ->
27 "an object with fields '" ++ List.intercalate "', '" fields ++ "'"
30_Array :: String -> Expression ()
31_Array functionName =
32 useLazy ["Elm","Native","Array"] functionName
35_List :: String -> Expression ()
36_List functionName =
37 useLazy ["Elm","Native","List"] functionName
40_Maybe :: String -> Expression ()
41_Maybe functionName =
42 useLazy ["Elm","Maybe"] functionName
45_Port :: String -> Expression ()
46_Port functionName =
47 useLazy ["Elm","Native","Port"] functionName
50check :: Expression () -> JSType -> Expression () -> Expression ()
51check x jsType continue =
52 CondExpr () (jsFold OpLOr checks x) continue throw
53 where
54 jsFold op checks value =
55 foldl1 (InfixExpr () op) (map ($ value) checks)
57 throw =
58 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
60 checks =
61 case jsType of
62 JSNumber -> [typeof "number"]
63 JSBoolean -> [typeof "boolean"]
64 JSString -> [typeof "string", instanceof "String"]
65 JSArray -> [instanceof "Array"]
66 JSObject fields ->
67 [jsFold OpLAnd (typeof "object" : map member fields)]
70-- INTERNAL
72internal :: String -> Expression ()
73internal name =
74 _Port "port" `call` [ string name ]
77-- INBOUND
79inbound :: String -> CanonicalType -> Expression ()
80inbound name tipe =
81 _Port "inbound" `call`
82 [ string name
83 , string (show (pretty tipe))
84 , toTypeFunction tipe
85 ]
88toTypeFunction :: CanonicalType -> Expression ()
89toTypeFunction tipe =
90 ["v"] ==> toType tipe (ref "v")
93toType :: CanonicalType -> Expression () -> Expression ()
94toType tipe x =
95 case tipe of
96 Lambda _ _ ->
97 error "functions should not be allowed through input ports"
99 Var _ ->
100 error "type variables should not be allowed through input ports"
102 Aliased _ args t ->
103 toType (dealias args t) x
105 Type (Var.Canonical Var.BuiltIn name)
106 | name == "Int" -> from JSNumber
107 | name == "Float" -> from JSNumber
108 | name == "Bool" -> from JSBoolean
109 | name == "String" -> from JSString
110 where
111 from checks = check x checks x
113 Type name
114 | Var.isJson name ->
115 x
117 | Var.isTuple name ->
118 toTuple [] x
120 | otherwise ->
121 error "bad type got to foreign input conversion"
123 App f args ->
124 case f : args of
125 Type name : [t]
126 | Var.isMaybe name ->
127 CondExpr ()
128 (equal x (NullLit ()))
129 (_Maybe "Nothing")
130 (_Maybe "Just" <| toType t x)
132 | Var.isList name ->
133 check x JSArray (_List "fromArray" <| array)
135 | Var.isArray name ->
136 check x JSArray (_Array "fromJSArray" <| array)
137 where
138 array = DotRef () x (var "map") <| toTypeFunction t
140 Type name : ts
141 | Var.isTuple name ->
142 toTuple ts x
144 _ -> error "bad ADT got to foreign input conversion"
146 Record _ (Just _) ->
147 error "bad record got to foreign input conversion"
149 Record fields Nothing ->
150 check x (JSObject (map fst fields)) object
151 where
152 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
153 keys = map convert fields
154 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
157toTuple :: [CanonicalType] -> Expression () -> Expression ()
158toTuple types x =
159 check x JSArray (ObjectLit () fields)
160 where
161 fields =
162 (prop "ctor", ctor) : zipWith convert [0..] types
164 ctor =
165 string ("_Tuple" ++ show (length types))
167 convert n t =
168 ( prop ('_':show n)
169 , toType t (BracketRef () x (IntLit () n))
170 )
173-- OUTBOUND
175outbound :: String -> CanonicalType -> Expression ()
176outbound name tipe =
177 _Port "outbound" `call` [ string name, fromTypeFunction tipe ]
180fromTypeFunction :: CanonicalType -> Expression ()
181fromTypeFunction tipe =
182 ["v"] ==> fromType tipe (ref "v")
185fromType :: CanonicalType -> Expression () -> Expression ()
186fromType tipe x =
187 case tipe of
188 Aliased _ args t ->
189 fromType (dealias args t) x
191 Lambda _ _
192 | numArgs > 1 && numArgs < 10 ->
193 func (ref ('A':show numArgs) `call` (x:values))
194 | otherwise ->
195 func (foldl (<|) x values)
196 where
197 ts = T.collectLambdas tipe
198 numArgs = length ts - 1
199 args = map (\n -> '_' : show n) [0..]
200 values = zipWith toType (init ts) (map ref args)
201 func body =
202 function (take numArgs args)
203 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
204 , ret (fromType (last ts) (ref "_r"))
205 ]
207 Var _ ->
208 error "type variables should not be allowed through outputs"
210 Type (Var.Canonical Var.BuiltIn name)
211 | name `elem` ["Int","Float","Bool","String"] ->
212 x
214 Type name
215 | Var.isJson name -> x
216 | Var.isTuple name -> ArrayLit () []
217 | otherwise -> error "bad type got to an output"
219 App f args ->
220 case f : args of
221 Type name : [t]
222 | Var.isMaybe name ->
223 CondExpr ()
224 (equal (DotRef () x (var "ctor")) (string "Nothing"))
225 (NullLit ())
226 (fromType t (DotRef () x (var "_0")))
228 | Var.isArray name ->
229 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
231 | Var.isList name ->
232 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
234 Type name : ts
235 | Var.isTuple name ->
236 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
237 in ArrayLit () $ zipWith convert [0..] ts
239 _ -> error "bad ADT got to an output"
241 Record _ (Just _) ->
242 error "bad record got to an output"
244 Record fields Nothing ->
245 ObjectLit () keys
246 where
247 keys = map convert fields
248 convert (f,t) =
249 (PropId () (var f), fromType t (DotRef () x (var f)))