git.iko.soy/elk
on 9d0075c help sign in
elk/src/Generate/JavaScript/Ports.hs
172 lines 6.1 kB history raw
1module Generate.JavaScript.Ports (incoming, outgoing) where
3import Generate.JavaScript.Helpers
4import qualified Generate.JavaScript.Variable as V
5import AST.Type as T
6import qualified AST.Variable as Var
7import Language.ECMAScript3.Syntax
9data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
10 deriving Show
12check :: Expression () -> JSType -> Expression () -> Expression ()
13check x jsType continue =
14 CondExpr () (jsFold OpLOr checks x) continue throw
15 where
16 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)
17 throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x
18 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")
19 checks =
20 case jsType of
21 JSNumber -> [typeof "number"]
22 JSBoolean -> [typeof "boolean"]
23 JSString -> [typeof "string", instanceof "String"]
24 JSArray -> [(obj ["_U","isJSArray"] <|)]
25 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
27incoming :: CanonicalType -> Expression ()
28incoming tipe =
29 case tipe of
30 Aliased _ t -> incoming t
32 App (Type v) [t]
33 | Var.isSignal v -> V.value ["Native","Ports"] "incomingSignal" <| incoming t
35 _ -> ["v"] ==> inc tipe (ref "v")
37inc :: CanonicalType -> Expression () -> Expression ()
38inc tipe x =
39 case tipe of
40 Lambda _ _ -> error "functions should not be allowed through input ports"
41 Var _ -> error "type variables should not be allowed through input ports"
42 Aliased _ t ->
43 inc t x
45 Type (Var.Canonical Var.BuiltIn name)
46 | name == "Int" -> from JSNumber
47 | name == "Float" -> from JSNumber
48 | name == "Bool" -> from JSBoolean
49 | name == "String" -> from JSString
50 where
51 from checks = check x checks x
53 Type name
54 | Var.isJson name -> V.value ["Native","Json"] "fromJS" <| x
55 | Var.isTuple name -> incomingTuple [] x
56 | otherwise -> error "bad type got to incoming port generation code"
58 App f args ->
59 case f : args of
60 Type name : [t]
61 | Var.isMaybe name ->
62 CondExpr ()
63 (equal x (NullLit ()))
64 (V.value ["Maybe"] "Nothing")
65 (V.value ["Maybe"] "Just" <| inc t x)
67 | Var.isList name ->
68 check x JSArray (obj ["_L","fromArray"] <| array)
70 | Var.isArray name ->
71 check x JSArray (obj ["_A","fromJSArray"] <| array)
72 where
73 array = DotRef () x (var "map") <| incoming t
75 Type name : ts
76 | Var.isTuple name -> incomingTuple ts x
78 _ -> error "bad ADT got to incoming port generation code"
80 Record _ (Just _) ->
81 error "bad record got to incoming port generation code"
83 Record fields Nothing ->
84 check x (JSObject (map fst fields)) object
85 where
86 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
87 keys = map convert fields
88 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
90incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
91incomingTuple types x =
92 check x JSArray (ObjectLit () fields)
93 where
94 fields = (prop "ctor", ctor) : zipWith convert [0..] types
96 ctor = string ("_Tuple" ++ show (length types))
98 convert n t =
99 ( prop ('_':show n)
100 , inc t (BracketRef () x (IntLit () n))
101 )
103outgoing :: CanonicalType -> Expression ()
104outgoing tipe =
105 case tipe of
106 Aliased _ t -> outgoing t
108 App (Type v) [t]
109 | Var.isSignal v -> V.value ["Native","Ports"] "outgoingSignal" <| outgoing t
111 _ -> ["v"] ==> out tipe (ref "v")
113out :: CanonicalType -> Expression () -> Expression ()
114out tipe x =
115 case tipe of
116 Aliased _ t -> out t x
118 Lambda _ _
119 | numArgs > 1 && numArgs < 10 ->
120 func (ref ('A':show numArgs) `call` (x:values))
121 | otherwise -> func (foldl (<|) x values)
122 where
123 ts = T.collectLambdas tipe
124 numArgs = length ts - 1
125 args = map (\n -> '_' : show n) [0..]
126 values = zipWith inc (init ts) (map ref args)
127 func body =
128 function (take numArgs args)
129 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
130 , ret (out (last ts) (ref "_r"))
131 ]
133 Var _ -> error "type variables should not be allowed through input ports"
135 Type (Var.Canonical Var.BuiltIn name)
136 | name `elem` ["Int","Float","Bool","String"] -> x
138 Type name
139 | Var.isJson name -> V.value ["Native","Json"] "toJS" <| x
140 | Var.isTuple name -> ArrayLit () []
141 | otherwise -> error "bad type got to outgoing port generation code"
143 App f args ->
144 case f : args of
145 Type name : [t]
146 | Var.isMaybe name ->
147 CondExpr ()
148 (equal (DotRef () x (var "ctor")) (string "Nothing"))
149 (NullLit ())
150 (out t (DotRef () x (var "_0")))
152 | Var.isArray name ->
153 DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t
155 | Var.isList name ->
156 DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t
158 Type name : ts
159 | Var.isTuple name ->
160 let convert n t = out t $ DotRef () x $ var ('_':show n)
161 in ArrayLit () $ zipWith convert [0..] ts
163 _ -> error "bad ADT got to outgoing port generation code"
165 Record _ (Just _) ->
166 error "bad record got to outgoing port generation code"
168 Record fields Nothing ->
169 ObjectLit () keys
170 where
171 keys = map convert fields
172 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))