git.iko.soy/elk
on 32fbbca help sign in
elk/compiler/Generate/JavaScript/Ports.hs
105 lines 4.2 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
9check :: a -> [a -> Expression ()] -> Expression () -> Expression ()
10check x checks continue =
11 CondExpr () (foldl1 (InfixExpr () OpLOr) (map ($x) checks)) continue throw
12 where
13 throw = obj "_E.raise" <| string "invalid input to port"
15incoming :: Type -> Expression ()
16incoming t = ["v"] ==> go t (ref "v")
17 where
18 go :: Type -> Expression () -> Expression ()
19 go tipe x =
20 case tipe of
21 Lambda _ _ -> error "functions should not be allowed through input ports"
22 Var _ -> error "type variables should not be allowed through input ports"
23 Data ctor []
24 | ctor == "Int" -> elm "Int" [typeof "number"]
25 | ctor == "Float" -> elm "Float" [typeof "number"]
26 | ctor == "Bool" -> elm "Bool" [typeof "boolean"]
27 | ctor == "String" -> elm "String" [typeof "string", instanceof "String"]
28 | ctor == "JavaScript.JSNumber" -> js [typeof "number"]
29 | ctor == "JavaScript.JSBool" -> js [typeof "boolean"]
30 | ctor == "JavaScript.JSString" -> js [typeof "string", instanceof "String"]
31 where
32 elm out checks = check x checks (obj ("_J.to" ++ out) <| x)
33 js checks = check x checks x
35 Data ctor [t]
36 | ctor == "Maybe.Maybe" ->
37 CondExpr () (equal x (NullLit ()))
38 (obj "Maybe.Nothing")
39 (obj "Maybe.Just" <| go t x)
41 | ctor == "Signal.Signal" ->
42 obj "Native.Ports.incomingSignal" <| incoming t
44 | ctor == "_List" ->
45 check x [instanceof "Array"] (obj "_J.toList" <| array)
46 where
47 array = DotRef () x (var "map") <| incoming t
49 Data ctor ts | Help.isTuple ctor -> check x [instanceof "Array"] tuple
50 where
51 tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
52 values = zipWith convert [0..] ts
53 convert n t = ( PropId () $ var ('_':show n)
54 , go t (BracketRef () x (IntLit () n)))
56 Data _ _ -> error "bad ADT got to port generation code"
58 Record _ (Just _) -> error "bad record got to port generation code"
60 Record fields Nothing ->
61 check x (typeof "object" : map (member . fst) fields) object
62 where
63 object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
64 keys = map convert fields
65 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
67outgoing t = ["v"] ==> go t (ref "v")
68 where
69 go :: Type -> Expression () -> Expression ()
70 go tipe x =
71 case tipe of
72 Lambda _ _ -> error "unimplemented"
73 Var _ -> error "type variables should not be allowed through input ports"
74 Data ctor []
75 | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x
76 | ctor `elem` jsPrims -> x
77 where
78 jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]
80 Data ctor [t]
81 | ctor == "Maybe.Maybe" ->
82 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
83 (NullLit ())
84 (DotRef () x (var "_0"))
86 | ctor == "Signal.Signal" ->
87 obj "Native.Ports.outgoingSignal" <| incoming t
89 | ctor == "_List" ->
90 DotRef () (obj "_J.fromList" <| x) (var "map") <| incoming t
92 Data ctor ts | Help.isTuple ctor ->
93 ArrayLit () $ zipWith convert [0..] ts
94 where
95 convert n t = go t $ DotRef () x $ var ('_':show n)
97 Data _ _ -> error "bad ADT got to port generation code"
99 Record _ (Just _) -> error "bad record got to port generation code"
101 Record fields Nothing ->
102 ObjectLit () keys
103 where
104 keys = map convert fields
105 convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))