git.iko.soy/elk
on 0140873 help sign in
elk/src/Generate/JavaScript/Foreign.hs
263 lines 7.3 kB history raw
1module Generate.JavaScript.Foreign (input, output) 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
45check :: Expression () -> JSType -> Expression () -> Expression ()
46check x jsType continue =
47 CondExpr () (jsFold OpLOr checks x) continue throw
48 where
49 jsFold op checks value =
50 foldl1 (InfixExpr () op) (map ($ value) checks)
52 throw =
53 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
55 checks =
56 case jsType of
57 JSNumber -> [typeof "number"]
58 JSBoolean -> [typeof "boolean"]
59 JSString -> [typeof "string", instanceof "String"]
60 JSArray -> [instanceof "Array"]
61 JSObject fields ->
62 [jsFold OpLAnd (typeof "object" : map member fields)]
65-- INPUT
67input :: String -> CanonicalType -> Expression ()
68input name tipe =
69 let args t =
70 [ string name, string (show (pretty t)), toTypeFunction t ]
71 in
72 case tipe of
73 Aliased _ t ->
74 input name t
76 App (Type signal) [t]
77 | Var.isStream signal ->
78 obj ["_P","inputStream"] `call` args t
80 | Var.isVarying signal ->
81 obj ["_P","inputVarying"] `call` args t
83 _ ->
84 obj ["_P","inputValue"] `call` args tipe
87toTypeFunction :: CanonicalType -> Expression ()
88toTypeFunction tipe =
89 ["v"] ==> toType tipe (ref "v")
92toType :: CanonicalType -> Expression () -> Expression ()
93toType tipe x =
94 case tipe of
95 Lambda _ _ ->
96 error "functions should not be allowed through input ports"
98 Var _ ->
99 error "type variables should not be allowed through input ports"
101 Aliased _ t ->
102 toType t x
104 Type (Var.Canonical Var.BuiltIn name)
105 | name == "Int" -> from JSNumber
106 | name == "Float" -> from JSNumber
107 | name == "Bool" -> from JSBoolean
108 | name == "String" -> from JSString
109 where
110 from checks = check x checks x
112 Type name
113 | Var.isJson name ->
114 x
116 | Var.isTuple name ->
117 toTuple [] x
119 | otherwise ->
120 error "bad type got to foreign input conversion"
122 App f args ->
123 case f : args of
124 Type name : [t]
125 | Var.isMaybe name ->
126 CondExpr ()
127 (equal x (NullLit ()))
128 (_Maybe "Nothing")
129 (_Maybe "Just" <| toType t x)
131 | Var.isList name ->
132 check x JSArray (_List "fromArray" <| array)
134 | Var.isArray name ->
135 check x JSArray (_Array "fromJSArray" <| array)
136 where
137 array = DotRef () x (var "map") <| toTypeFunction t
139 Type name : ts
140 | Var.isTuple name ->
141 toTuple ts x
143 _ -> error "bad ADT got to foreign input conversion"
145 Record _ (Just _) ->
146 error "bad record got to foreign input conversion"
148 Record fields Nothing ->
149 check x (JSObject (map fst fields)) object
150 where
151 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
152 keys = map convert fields
153 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
156toTuple :: [CanonicalType] -> Expression () -> Expression ()
157toTuple types x =
158 check x JSArray (ObjectLit () fields)
159 where
160 fields =
161 (prop "ctor", ctor) : zipWith convert [0..] types
163 ctor =
164 string ("_Tuple" ++ show (length types))
166 convert n t =
167 ( prop ('_':show n)
168 , toType t (BracketRef () x (IntLit () n))
169 )
172-- OUTPUT
174output :: String -> CanonicalType -> Expression () -> Expression ()
175output name tipe value =
176 let args t =
177 [ string name, fromTypeFunction t, value ]
178 in
179 case tipe of
180 Aliased _ t ->
181 output name t value
183 App (Type signal) [t]
184 | Var.isStream signal ->
185 obj ["_P","outputStream"] `call` args t
187 | Var.isVarying signal ->
188 obj ["_P","outputVarying"] `call` args t
190 _ ->
191 obj ["_P","outputValue"] `call` args tipe
194fromTypeFunction :: CanonicalType -> Expression ()
195fromTypeFunction tipe =
196 ["v"] ==> fromType tipe (ref "v")
199fromType :: CanonicalType -> Expression () -> Expression ()
200fromType tipe x =
201 case tipe of
202 Aliased _ t ->
203 fromType t x
205 Lambda _ _
206 | numArgs > 1 && numArgs < 10 ->
207 func (ref ('A':show numArgs) `call` (x:values))
208 | otherwise ->
209 func (foldl (<|) x values)
210 where
211 ts = T.collectLambdas tipe
212 numArgs = length ts - 1
213 args = map (\n -> '_' : show n) [0..]
214 values = zipWith toType (init ts) (map ref args)
215 func body =
216 function (take numArgs args)
217 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
218 , ret (fromType (last ts) (ref "_r"))
219 ]
221 Var _ ->
222 error "type variables should not be allowed through outputs"
224 Type (Var.Canonical Var.BuiltIn name)
225 | name `elem` ["Int","Float","Bool","String"] ->
226 x
228 Type name
229 | Var.isJson name -> x
230 | Var.isTuple name -> ArrayLit () []
231 | otherwise -> error "bad type got to an output"
233 App f args ->
234 case f : args of
235 Type name : [t]
236 | Var.isMaybe name ->
237 CondExpr ()
238 (equal (DotRef () x (var "ctor")) (string "Nothing"))
239 (NullLit ())
240 (fromType t (DotRef () x (var "_0")))
242 | Var.isArray name ->
243 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
245 | Var.isList name ->
246 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
248 Type name : ts
249 | Var.isTuple name ->
250 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
251 in ArrayLit () $ zipWith convert [0..] ts
253 _ -> error "bad ADT got to an output"
255 Record _ (Just _) ->
256 error "bad record got to an output"
258 Record fields Nothing ->
259 ObjectLit () keys
260 where
261 keys = map convert fields
262 convert (f,t) =
263 (PropId () (var f), fromType t (DotRef () x (var f)))