git.iko.soy/elk
on 7ecaa26 help sign in
elk/compiler/Generate/JavaScript/Ports.hs
155 lines 5.6 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript.Ports (incoming, outgoing) where
4import Generate.JavaScript.Helpers
5import qualified AST.Helpers as Help
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 = 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 Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
33 obj "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 Data (Var.Canonical (Var.Module "Json") "Value") [] ->
46 obj "Native.Json.fromJS" <| x
48 Data (Var.Canonical Var.BuiltIn ctor) []
49 | ctor == "Int" -> from JSNumber
50 | ctor == "Float" -> from JSNumber
51 | ctor == "Bool" -> from JSBoolean
52 | ctor == "String" -> from JSString
53 where
54 from checks = check x checks x
56 Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
57 CondExpr () (equal x (NullLit ()))
58 (obj "Maybe.Nothing")
59 (obj "Maybe.Just" <| inc t x)
61 Data (Var.Canonical Var.BuiltIn ctor) [t]
62 | ctor == "_List" ->
63 check x JSArray (obj "_L.fromArray" <| array)
65 | ctor == "Array.Array" ->
66 check x JSArray (obj "_A.fromJSArray" <| array)
68 where
69 array = DotRef () x (var "map") <| incoming t
71 Data (Var.Canonical Var.BuiltIn ctor) ts
72 | Help.isTuple ctor -> check x JSArray tuple
73 where
74 tuple = ObjectLit () $ (prop "ctor", string ctor) : values
75 values = zipWith convert [0..] ts
76 convert n t = ( prop ('_':show n)
77 , inc t (BracketRef () x (IntLit () n)))
79 Data _ _ ->
80 error "bad ADT got to incoming port generation code"
82 Record _ (Just _) ->
83 error "bad record got to incoming port generation code"
85 Record fields Nothing ->
86 check x (JSObject (map fst fields)) object
87 where
88 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
89 keys = map convert fields
90 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
92outgoing :: CanonicalType -> Expression ()
93outgoing tipe =
94 case tipe of
95 Aliased _ t -> outgoing t
97 Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
98 obj "Native.Ports.outgoingSignal" <| outgoing t
100 _ -> ["v"] ==> out tipe (ref "v")
102out :: CanonicalType -> Expression () -> Expression ()
103out tipe x =
104 case tipe of
105 Aliased _ t -> out t x
107 Lambda _ _
108 | numArgs > 1 && numArgs < 10 ->
109 func (ref ('A':show numArgs) `call` (x:values))
110 | otherwise -> func (foldl (<|) x values)
111 where
112 ts = T.collectLambdas tipe
113 numArgs = length ts - 1
114 args = map (\n -> '_' : show n) [0..]
115 values = zipWith inc (init ts) (map ref args)
116 func body = function (take numArgs args)
117 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
118 , ret (out (last ts) (ref "_r"))
119 ]
121 Var _ -> error "type variables should not be allowed through input ports"
123 Data (Var.Canonical Var.BuiltIn ctor) []
124 | ctor `elem` ["Int","Float","Bool","String"] -> x
126 Data (Var.Canonical (Var.Module "Json") "Value") [] ->
127 obj "Native.Json.toJS" <| x
129 Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
130 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
131 (NullLit ())
132 (out t (DotRef () x (var "_0")))
134 Data (Var.Canonical (Var.Module "Array") "Array") [t] ->
135 DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
137 Data (Var.Canonical Var.BuiltIn "_List") [t] ->
138 DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
140 Data (Var.Canonical Var.BuiltIn ctor) ts
141 | Help.isTuple ctor ->
142 let convert n t = out t $ DotRef () x $ var ('_':show n)
143 in ArrayLit () $ zipWith convert [0..] ts
145 Data _ _ ->
146 error "bad ADT got to outgoing port generation code"
148 Record _ (Just _) ->
149 error "bad record got to outgoing port generation code"
151 Record fields Nothing ->
152 ObjectLit () keys
153 where
154 keys = map convert fields
155 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))