git.iko.soy/elk
on 2a930fd help sign in
elk/src/Generate/JavaScript/Ports.hs
173 lines 6.1 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript.Ports (incoming, outgoing) where
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
10data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
11 deriving Show
13check :: Expression () -> JSType -> Expression () -> Expression ()
14check x jsType continue =
15 CondExpr () (jsFold OpLOr checks x) continue throw
16 where
17 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)
18 throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x
19 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")
20 checks =
21 case jsType of
22 JSNumber -> [typeof "number"]
23 JSBoolean -> [typeof "boolean"]
24 JSString -> [typeof "string", instanceof "String"]
25 JSArray -> [(obj ["_U","isJSArray"] <|)]
26 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
28incoming :: CanonicalType -> Expression ()
29incoming tipe =
30 case tipe of
31 Aliased _ t -> incoming t
33 App (Type v) [t]
34 | Var.isSignal v -> V.value ["Native","Ports"] "incomingSignal" <| incoming t
36 _ -> ["v"] ==> inc tipe (ref "v")
38inc :: CanonicalType -> Expression () -> Expression ()
39inc tipe x =
40 case tipe of
41 Lambda _ _ -> error "functions should not be allowed through input ports"
42 Var _ -> error "type variables should not be allowed through input ports"
43 Aliased _ t ->
44 inc t x
46 Type (Var.Canonical Var.BuiltIn name)
47 | name == "Int" -> from JSNumber
48 | name == "Float" -> from JSNumber
49 | name == "Bool" -> from JSBoolean
50 | name == "String" -> from JSString
51 where
52 from checks = check x checks x
54 Type name
55 | Var.isJson name -> V.value ["Native","Json"] "fromJS" <| x
56 | Var.isTuple name -> incomingTuple [] x
57 | otherwise -> error "bad type got to incoming port generation code"
59 App f args ->
60 case f : args of
61 Type name : [t]
62 | Var.isMaybe name ->
63 CondExpr ()
64 (equal x (NullLit ()))
65 (V.value ["Maybe"] "Nothing")
66 (V.value ["Maybe"] "Just" <| inc t x)
68 | Var.isList name ->
69 check x JSArray (obj ["_L","fromArray"] <| array)
71 | Var.isArray name ->
72 check x JSArray (obj ["_A","fromJSArray"] <| array)
73 where
74 array = DotRef () x (var "map") <| incoming t
76 Type name : ts
77 | Var.isTuple name -> incomingTuple ts x
79 _ -> error "bad ADT got to incoming port generation code"
81 Record _ (Just _) ->
82 error "bad record got to incoming port generation code"
84 Record fields Nothing ->
85 check x (JSObject (map fst fields)) object
86 where
87 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
88 keys = map convert fields
89 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
91incomingTuple :: [CanonicalType] -> Expression () -> Expression ()
92incomingTuple types x =
93 check x JSArray (ObjectLit () fields)
94 where
95 fields = (prop "ctor", ctor) : zipWith convert [0..] types
97 ctor = string ("_Tuple" ++ show (length types))
99 convert n t =
100 ( prop ('_':show n)
101 , inc t (BracketRef () x (IntLit () n))
102 )
104outgoing :: CanonicalType -> Expression ()
105outgoing tipe =
106 case tipe of
107 Aliased _ t -> outgoing t
109 App (Type v) [t]
110 | Var.isSignal v -> V.value ["Native","Ports"] "outgoingSignal" <| outgoing t
112 _ -> ["v"] ==> out tipe (ref "v")
114out :: CanonicalType -> Expression () -> Expression ()
115out tipe x =
116 case tipe of
117 Aliased _ t -> out t x
119 Lambda _ _
120 | numArgs > 1 && numArgs < 10 ->
121 func (ref ('A':show numArgs) `call` (x:values))
122 | otherwise -> func (foldl (<|) x values)
123 where
124 ts = T.collectLambdas tipe
125 numArgs = length ts - 1
126 args = map (\n -> '_' : show n) [0..]
127 values = zipWith inc (init ts) (map ref args)
128 func body =
129 function (take numArgs args)
130 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
131 , ret (out (last ts) (ref "_r"))
132 ]
134 Var _ -> error "type variables should not be allowed through input ports"
136 Type (Var.Canonical Var.BuiltIn name)
137 | name `elem` ["Int","Float","Bool","String"] -> x
139 Type name
140 | Var.isJson name -> V.value ["Native","Json"] "toJS" <| x
141 | Var.isTuple name -> ArrayLit () []
142 | otherwise -> error "bad type got to outgoing port generation code"
144 App f args ->
145 case f : args of
146 Type name : [t]
147 | Var.isMaybe name ->
148 CondExpr ()
149 (equal (DotRef () x (var "ctor")) (string "Nothing"))
150 (NullLit ())
151 (out t (DotRef () x (var "_0")))
153 | Var.isArray name ->
154 DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t
156 | Var.isList name ->
157 DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t
159 Type name : ts
160 | Var.isTuple name ->
161 let convert n t = out t $ DotRef () x $ var ('_':show n)
162 in ArrayLit () $ zipWith convert [0..] ts
164 _ -> error "bad ADT got to outgoing port generation code"
166 Record _ (Just _) ->
167 error "bad record got to outgoing port generation code"
169 Record fields Nothing ->
170 ObjectLit () keys
171 where
172 keys = map convert fields
173 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))