git.iko.soy/elk
on 461abc0 help sign in
elk/compiler/Generate/JavaScript/Ports.hs
117 lines 4.5 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript.Ports (incoming, outgoing) where
4import Generate.JavaScript.Helpers
5import qualified SourceSyntax.Helpers as Help
6import SourceSyntax.Type
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 = case jsType of
20 JSNumber -> [typeof "number"]
21 JSBoolean -> [typeof "boolean"]
22 JSString -> [typeof "string", instanceof "String"]
23 JSArray -> [instanceof "Array"]
24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
26incoming :: Type -> Expression ()
27incoming tipe =
28 case tipe of
29 Data "Signal.Signal" [t] ->
30 obj "Native.Ports.incomingSignal" <| incoming t
31 _ -> ["v"] ==> go tipe (ref "v")
32 where
33 go :: Type -> Expression () -> Expression ()
34 go tipe x =
35 case tipe of
36 Lambda _ _ -> error "functions should not be allowed through input ports"
37 Var _ -> error "type variables should not be allowed through input ports"
38 Data ctor []
39 | ctor == "Int" -> elm JSNumber
40 | ctor == "Float" -> elm JSNumber
41 | ctor == "Bool" -> elm JSBoolean
42 | ctor == "String" -> elm JSString
43 | ctor == "JavaScript.JSNumber" -> js JSNumber
44 | ctor == "JavaScript.JSBool" -> js JSBoolean
45 | ctor == "JavaScript.JSString" -> js JSString
46 where
47 elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)
48 js checks = check x checks x
50 Data ctor [t]
51 | ctor == "Maybe.Maybe" ->
52 CondExpr () (equal x (NullLit ()))
53 (obj "Maybe.Nothing")
54 (obj "Maybe.Just" <| go t x)
56 | ctor == "_List" ->
57 check x JSArray (obj "_J.toList" <| array)
58 where
59 array = DotRef () x (var "map") <| incoming t
61 Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
62 where
63 tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
64 values = zipWith convert [0..] ts
65 convert n t = ( PropId () $ var ('_':show n)
66 , go t (BracketRef () x (IntLit () n)))
68 Data _ _ -> error "bad ADT got to port generation code"
70 Record _ (Just _) -> error "bad record got to port generation code"
72 Record fields Nothing -> check x (JSObject (map fst fields)) object
73 where
74 object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
75 keys = map convert fields
76 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
78outgoing tipe =
79 case tipe of
80 Data "Signal.Signal" [t] ->
81 obj "Native.Ports.outgoingSignal" <| outgoing t
82 _ -> ["v"] ==> go tipe (ref "v")
83 where
84 go :: Type -> Expression () -> Expression ()
85 go tipe x =
86 case tipe of
87 Lambda _ _ -> error "unimplemented"
88 Var _ -> error "type variables should not be allowed through input ports"
89 Data ctor []
90 | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x
91 | ctor `elem` jsPrims -> x
92 where
93 jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]
95 Data ctor [t]
96 | ctor == "Maybe.Maybe" ->
97 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
98 (NullLit ())
99 (DotRef () x (var "_0"))
101 | ctor == "_List" ->
102 DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
104 Data ctor ts | Help.isTuple ctor ->
105 ArrayLit () $ zipWith convert [0..] ts
106 where
107 convert n t = go t $ DotRef () x $ var ('_':show n)
109 Data _ _ -> error "bad ADT got to port generation code"
111 Record _ (Just _) -> error "bad record got to port generation code"
113 Record fields Nothing ->
114 ObjectLit () keys
115 where
116 keys = map convert fields
117 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))