git.iko.soy/elk
on edfca84 help sign in
elk/src/Generate/JavaScript/Foreign.hs
250 lines 7.2 kB history raw
1module Generate.JavaScript.Foreign (input, output) where
3import qualified Data.List as List
4import Generate.JavaScript.Helpers
5import AST.Type as T
6import qualified AST.Variable as Var
7import Language.ECMAScript3.Syntax
10data JSType
11 = JSNumber
12 | JSBoolean
13 | JSString
14 | JSArray
15 | JSObject [String]
18typeToString :: JSType -> String
19typeToString tipe =
20 case tipe of
21 JSNumber -> "a number"
22 JSBoolean -> "a boolean (true or false)"
23 JSString -> "a string"
24 JSArray -> "an array"
25 JSObject fields ->
26 "an object with fields '" ++ List.intercalate "', '" fields ++ "'"
29_Array :: String -> Expression ()
30_Array functionName =
31 useLazy ["Elm","Native","Array"] functionName
34_List :: String -> Expression ()
35_List functionName =
36 useLazy ["Elm","Native","List"] functionName
39_Maybe :: String -> Expression ()
40_Maybe functionName =
41 useLazy ["Elm","Maybe"] functionName
44check :: Expression () -> JSType -> Expression () -> Expression ()
45check x jsType continue =
46 CondExpr () (jsFold OpLOr checks x) continue throw
47 where
48 jsFold op checks value =
49 foldl1 (InfixExpr () op) (map ($ value) checks)
51 throw =
52 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
54 checks =
55 case jsType of
56 JSNumber -> [typeof "number"]
57 JSBoolean -> [typeof "boolean"]
58 JSString -> [typeof "string", instanceof "String"]
59 JSArray -> [instanceof "Array"]
60 JSObject fields ->
61 [jsFold OpLAnd (typeof "object" : map member fields)]
64-- INPUT
66input :: String -> CanonicalType -> Expression ()
67input name tipe =
68 case T.dealias tipe of
69 App (Type signal) [t]
70 | Var.isStream signal ->
71 obj ["_P","inputStream"] <| toTypeFunction t
73 | Var.isVarying signal ->
74 obj ["_P","inputVarying"] <| toTypeFunction t
76 dealiasedType ->
77 obj ["_P","inputValue"] <| toTypeFunction dealiasedType
80toTypeFunction :: CanonicalType -> Expression ()
81toTypeFunction tipe =
82 ["v"] ==> toType tipe (ref "v")
85toType :: CanonicalType -> Expression () -> Expression ()
86toType tipe x =
87 case tipe of
88 Lambda _ _ ->
89 error "functions should not be allowed through input ports"
91 Var _ ->
92 error "type variables should not be allowed through input ports"
94 Aliased _ t ->
95 toType t x
97 Type (Var.Canonical Var.BuiltIn name)
98 | name == "Int" -> from JSNumber
99 | name == "Float" -> from JSNumber
100 | name == "Bool" -> from JSBoolean
101 | name == "String" -> from JSString
102 where
103 from checks = check x checks x
105 Type name
106 | Var.isJson name ->
107 x
109 | Var.isTuple name ->
110 toTuple [] x
112 | otherwise ->
113 error "bad type got to foreign input conversion"
115 App f args ->
116 case f : args of
117 Type name : [t]
118 | Var.isMaybe name ->
119 CondExpr ()
120 (equal x (NullLit ()))
121 (_Maybe "Nothing")
122 (_Maybe "Just" <| toType t x)
124 | Var.isList name ->
125 check x JSArray (_List "fromArray" <| array)
127 | Var.isArray name ->
128 check x JSArray (_Array "fromJSArray" <| array)
129 where
130 array = DotRef () x (var "map") <| toTypeFunction t
132 Type name : ts
133 | Var.isTuple name ->
134 toTuple ts x
136 _ -> error "bad ADT got to foreign input conversion"
138 Record _ (Just _) ->
139 error "bad record got to foreign input conversion"
141 Record fields Nothing ->
142 check x (JSObject (map fst fields)) object
143 where
144 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
145 keys = map convert fields
146 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
149toTuple :: [CanonicalType] -> Expression () -> Expression ()
150toTuple types x =
151 check x JSArray (ObjectLit () fields)
152 where
153 fields =
154 (prop "ctor", ctor) : zipWith convert [0..] types
156 ctor =
157 string ("_Tuple" ++ show (length types))
159 convert n t =
160 ( prop ('_':show n)
161 , toType t (BracketRef () x (IntLit () n))
162 )
165-- OUTPUT
167output :: String -> CanonicalType -> Expression () -> Expression ()
168output name tipe value =
169 case T.dealias tipe of
170 App (Type signal) [t]
171 | Var.isStream signal ->
172 obj ["_P","outputStream"] `call` [ fromTypeFunction t, value ]
174 | Var.isVarying signal ->
175 obj ["_P","outputVarying"] `call` [ fromTypeFunction t, value ]
177 dealiasedType ->
178 obj ["_P","outputValue"] `call` [ fromTypeFunction dealiasedType, value ]
181fromTypeFunction :: CanonicalType -> Expression ()
182fromTypeFunction tipe =
183 ["v"] ==> fromType tipe (ref "v")
186fromType :: CanonicalType -> Expression () -> Expression ()
187fromType tipe x =
188 case tipe of
189 Aliased _ t ->
190 fromType t x
192 Lambda _ _
193 | numArgs > 1 && numArgs < 10 ->
194 func (ref ('A':show numArgs) `call` (x:values))
195 | otherwise ->
196 func (foldl (<|) x values)
197 where
198 ts = T.collectLambdas tipe
199 numArgs = length ts - 1
200 args = map (\n -> '_' : show n) [0..]
201 values = zipWith toType (init ts) (map ref args)
202 func body =
203 function (take numArgs args)
204 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
205 , ret (fromType (last ts) (ref "_r"))
206 ]
208 Var _ ->
209 error "type variables should not be allowed through outputs"
211 Type (Var.Canonical Var.BuiltIn name)
212 | name `elem` ["Int","Float","Bool","String"] ->
213 x
215 Type name
216 | Var.isJson name -> x
217 | Var.isTuple name -> ArrayLit () []
218 | otherwise -> error "bad type got to an output"
220 App f args ->
221 case f : args of
222 Type name : [t]
223 | Var.isMaybe name ->
224 CondExpr ()
225 (equal (DotRef () x (var "ctor")) (string "Nothing"))
226 (NullLit ())
227 (fromType t (DotRef () x (var "_0")))
229 | Var.isArray name ->
230 DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
232 | Var.isList name ->
233 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
235 Type name : ts
236 | Var.isTuple name ->
237 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
238 in ArrayLit () $ zipWith convert [0..] ts
240 _ -> error "bad ADT got to an output"
242 Record _ (Just _) ->
243 error "bad record got to an output"
245 Record fields Nothing ->
246 ObjectLit () keys
247 where
248 keys = map convert fields
249 convert (f,t) =
250 (PropId () (var f), fromType t (DotRef () x (var f)))