git.iko.soy/elk
on 021af44 help sign in
elk/compiler/Generate/JavaScript/Ports.hs
142 lines 5.1 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 as T
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 -> [(obj "_U.isJSArray" <|)]
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"] ==> inc tipe (ref "v")
33inc :: Type -> Expression () -> Expression ()
34inc 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"
39 Data "Json.Value" [] ->
40 obj "Native.Json.fromJS" <| x
42 Data ctor []
43 | ctor == "Int" -> from JSNumber
44 | ctor == "Float" -> from JSNumber
45 | ctor == "Bool" -> from JSBoolean
46 | ctor == "String" -> from JSString
47 where
48 from 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" <| inc t x)
56 | ctor == "_List" ->
57 check x JSArray (obj "_L.fromArray" <| array)
59 | ctor == "Array.Array" ->
60 check x JSArray (obj "_A.fromJSArray" <| array)
62 where
63 array = DotRef () x (var "map") <| incoming t
65 Data ctor ts
66 | Help.isTuple ctor -> check x JSArray tuple
67 where
68 tuple = ObjectLit () $ (prop "ctor", string ctor) : values
69 values = zipWith convert [0..] ts
70 convert n t = ( prop ('_':show n)
71 , inc t (BracketRef () x (IntLit () n)))
73 Data _ _ ->
74 error "bad ADT got to incoming port generation code"
76 Record _ (Just _) ->
77 error "bad record got to incoming port generation code"
79 Record fields Nothing ->
80 check x (JSObject (map fst fields)) object
81 where
82 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
83 keys = map convert fields
84 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
86outgoing tipe =
87 case tipe of
88 Data "Signal.Signal" [t] ->
89 obj "Native.Ports.outgoingSignal" <| outgoing t
90 _ -> ["v"] ==> out tipe (ref "v")
92out :: Type -> Expression () -> Expression ()
93out tipe x =
94 case tipe of
95 Lambda _ _
96 | numArgs > 1 && numArgs < 10 ->
97 func (ref ('A':show numArgs) `call` (x:values))
98 | otherwise -> func (foldl (<|) x values)
99 where
100 ts = T.collectLambdas tipe
101 numArgs = length ts - 1
102 args = map (\n -> '_' : show n) [0..]
103 values = zipWith inc (init ts) (map ref args)
104 func body = function (take numArgs args)
105 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
106 , ret (out (last ts) (ref "_r"))
107 ]
109 Var _ -> error "type variables should not be allowed through input ports"
110 Data ctor []
111 | ctor `elem` ["Int","Float","Bool","String"] -> x
112 | ctor == "Json.Value" ->
113 obj "Native.Json.toJS" <| x
115 Data ctor [t]
116 | ctor == "Maybe.Maybe" ->
117 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
118 (NullLit ())
119 (out t (DotRef () x (var "_0")))
121 | ctor == "_List" ->
122 DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
124 | ctor == "Array.Array" ->
125 DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
127 Data ctor ts
128 | Help.isTuple ctor ->
129 let convert n t = out t $ DotRef () x $ var ('_':show n)
130 in ArrayLit () $ zipWith convert [0..] ts
132 Data _ _ ->
133 error "bad ADT got to outgoing port generation code"
135 Record _ (Just _) ->
136 error "bad record got to outgoing port generation code"
138 Record fields Nothing ->
139 ObjectLit () keys
140 where
141 keys = map convert fields
142 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))