git.iko.soy/elk
on 914e047 help sign in
elk/src/Generate/JavaScript/Ports.hs
202 lines 6.4 kB history raw
1module Generate.JavaScript.Ports (incoming, outgoing) where
3import qualified Data.List as List
4import Generate.JavaScript.Helpers
5import qualified Generate.JavaScript.Variable as V
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 ++ "'"
30check :: Expression () -> JSType -> Expression () -> Expression ()
31check x jsType continue =
32 CondExpr () (jsFold OpLOr checks x) continue throw
33 where
34 jsFold op checks value =
35 foldl1 (InfixExpr () op) (map ($ value) checks)
37 throw =
38 obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]
40 checks =
41 case jsType of
42 JSNumber -> [typeof "number"]
43 JSBoolean -> [typeof "boolean"]
44 JSString -> [typeof "string", instanceof "String"]
45 JSArray -> [instanceof "Array"]
46 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
49incoming :: CanonicalType -> Expression ()
50incoming tipe =
51 case tipe of
52 Aliased _ t -> incoming t
54 App (Type v) [t]
55 | Var.isSignal v -> obj ["_P","incomingSignal"] <| incoming t
57 _ -> ["v"] ==> inc tipe (ref "v")
59inc :: CanonicalType -> Expression () -> Expression ()
60inc tipe x =
61 case tipe of
62 Lambda _ _ -> error "functions should not be allowed through input ports"
63 Var _ -> error "type variables should not be allowed through input ports"
64 Aliased _ t ->
65 inc t x
67 Type (Var.Canonical Var.BuiltIn name)
68 | name == "Int" -> from JSNumber
69 | name == "Float" -> from JSNumber
70 | name == "Bool" -> from JSBoolean
71 | name == "String" -> from JSString
72 where
73 from checks = check x checks x
75 Type name
76 | Var.isJavaScript name ->
77 x
79 | Var.isJson name ->
80 V.value ["Native","Json"] "fromJS" <| x
82 | Var.isTuple name ->
83 incomingTuple [] x
85 | otherwise ->
86 error "bad type got to incoming port generation code"
88 App f args ->
89 case f : args of
90 Type name : [t]
91 | Var.isMaybe name ->
92 CondExpr ()
93 (equal x (NullLit ()))
94 (V.value ["Maybe"] "Nothing")
95 (V.value ["Maybe"] "Just" <| inc t x)
97 | Var.isList name ->
98 check x JSArray (obj ["_L","fromArray"] <| array)
100 | Var.isArray name ->
101 check x JSArray (obj ["_A","fromJSArray"] <| array)
102 where
103 array = DotRef () x (var "map") <| incoming t
105 Type name : ts
106 | Var.isTuple name -> incomingTuple ts x
108 _ -> error "bad ADT got to incoming port generation code"
110 Record _ (Just _) ->
111 error "bad record got to incoming port generation code"
113 Record fields Nothing ->
114 check x (JSObject (map fst fields)) object
115 where
116 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
117 keys = map convert fields
118 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
120incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
121incomingTuple types x =
122 check x JSArray (ObjectLit () fields)
123 where
124 fields = (prop "ctor", ctor) : zipWith convert [0..] types
126 ctor = string ("_Tuple" ++ show (length types))
128 convert n t =
129 ( prop ('_':show n)
130 , inc t (BracketRef () x (IntLit () n))
131 )
133outgoing :: CanonicalType -> Expression ()
134outgoing tipe =
135 case tipe of
136 Aliased _ t -> outgoing t
138 App (Type v) [t]
139 | Var.isSignal v -> obj ["_P","outgoingSignal"] <| outgoing t
141 _ -> ["v"] ==> out tipe (ref "v")
143out :: CanonicalType -> Expression () -> Expression ()
144out tipe x =
145 case tipe of
146 Aliased _ t -> out t x
148 Lambda _ _
149 | numArgs > 1 && numArgs < 10 ->
150 func (ref ('A':show numArgs) `call` (x:values))
151 | otherwise -> func (foldl (<|) x values)
152 where
153 ts = T.collectLambdas tipe
154 numArgs = length ts - 1
155 args = map (\n -> '_' : show n) [0..]
156 values = zipWith inc (init ts) (map ref args)
157 func body =
158 function (take numArgs args)
159 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
160 , ret (out (last ts) (ref "_r"))
161 ]
163 Var _ -> error "type variables should not be allowed through input ports"
165 Type (Var.Canonical Var.BuiltIn name)
166 | name `elem` ["Int","Float","Bool","String"] -> x
168 Type name
169 | Var.isJson name -> V.value ["Native","Json"] "toJS" <| x
170 | Var.isTuple name -> ArrayLit () []
171 | otherwise -> error "bad type got to outgoing port generation code"
173 App f args ->
174 case f : args of
175 Type name : [t]
176 | Var.isMaybe name ->
177 CondExpr ()
178 (equal (DotRef () x (var "ctor")) (string "Nothing"))
179 (NullLit ())
180 (out t (DotRef () x (var "_0")))
182 | Var.isArray name ->
183 DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t
185 | Var.isList name ->
186 DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t
188 Type name : ts
189 | Var.isTuple name ->
190 let convert n t = out t $ DotRef () x $ var ('_':show n)
191 in ArrayLit () $ zipWith convert [0..] ts
193 _ -> error "bad ADT got to outgoing port generation code"
195 Record _ (Just _) ->
196 error "bad record got to outgoing port generation code"
198 Record fields Nothing ->
199 ObjectLit () keys
200 where
201 keys = map convert fields
202 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))