git.iko.soy/elk
on 34b72a2 help sign in
elk/compiler/Generate/JavaScript/Ports.hs
159 lines 5.9 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript.Ports (incoming, outgoing) where
4import Generate.JavaScript.Helpers
5import AST.Type as T
6import qualified AST.Variable as Var
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 :: CanonicalType -> Expression ()
27incoming tipe =
28 case tipe of
29 Aliased _ t -> incoming t
31 App (Type v) [t]
32 | Var.isSignal v -> obj ["Native","Ports","incomingSignal"] <| incoming t
34 _ -> ["v"] ==> inc tipe (ref "v")
36inc :: CanonicalType -> Expression () -> Expression ()
37inc tipe x =
38 case tipe of
39 Lambda _ _ -> error "functions should not be allowed through input ports"
40 Var _ -> error "type variables should not be allowed through input ports"
41 Aliased _ t ->
42 inc t x
44 Type (Var.Canonical Var.BuiltIn name)
45 | name == "Int" -> from JSNumber
46 | name == "Float" -> from JSNumber
47 | name == "Bool" -> from JSBoolean
48 | name == "String" -> from JSString
49 where
50 from checks = check x checks x
52 Type name
53 | Var.isJson name -> obj ["Native","Json","fromJS"] <| x
54 | otherwise -> error "bad type got to incoming port generation code"
56 App f args ->
57 case f : args of
58 Type name : [t]
59 | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))
60 (obj ["Maybe","Nothing"])
61 (obj ["Maybe","Just"] <| inc t x)
63 | Var.isList name -> check x JSArray (obj ["_L","fromArray"] <| array)
65 | Var.isArray name -> check x JSArray (obj ["_A","fromJSArray"] <| array)
66 where
67 array = DotRef () x (var "map") <| incoming t
69 Type name : ts
70 | Var.isTuple name -> check x JSArray tuple
71 where
72 tuple = ObjectLit () $ (prop "ctor", ctor) : values
74 ctor = string ("_Tuple" ++ show (length ts))
75 values = zipWith convert [0..] ts
77 convert n t = ( prop ('_':show n)
78 , inc t (BracketRef () x (IntLit () n))
79 )
81 _ -> error "bad ADT got to incoming port generation code"
83 Record _ (Just _) ->
84 error "bad record got to incoming port generation code"
86 Record fields Nothing ->
87 check x (JSObject (map fst fields)) object
88 where
89 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
90 keys = map convert fields
91 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
93outgoing :: CanonicalType -> Expression ()
94outgoing tipe =
95 case tipe of
96 Aliased _ t -> outgoing t
98 App (Type v) [t]
99 | Var.isSignal v -> obj ["Native","Ports","outgoingSignal"] <| outgoing t
101 _ -> ["v"] ==> out tipe (ref "v")
103out :: CanonicalType -> Expression () -> Expression ()
104out tipe x =
105 case tipe of
106 Aliased _ t -> out t x
108 Lambda _ _
109 | numArgs > 1 && numArgs < 10 ->
110 func (ref ('A':show numArgs) `call` (x:values))
111 | otherwise -> func (foldl (<|) x values)
112 where
113 ts = T.collectLambdas tipe
114 numArgs = length ts - 1
115 args = map (\n -> '_' : show n) [0..]
116 values = zipWith inc (init ts) (map ref args)
117 func body = function (take numArgs args)
118 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
119 , ret (out (last ts) (ref "_r"))
120 ]
122 Var _ -> error "type variables should not be allowed through input ports"
124 Type (Var.Canonical Var.BuiltIn name)
125 | name `elem` ["Int","Float","Bool","String"] -> x
127 Type name
128 | Var.isJson name -> obj ["Native","Json","toJS"] <| x
129 | otherwise -> error "bad type got to outgoing port generation code"
131 App f args ->
132 case f : args of
133 Type name : [t]
134 | Var.isMaybe name ->
135 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
136 (NullLit ())
137 (out t (DotRef () x (var "_0")))
139 | Var.isArray name ->
140 DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t
142 | Var.isList name ->
143 DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t
145 Type name : ts
146 | Var.isTuple name ->
147 let convert n t = out t $ DotRef () x $ var ('_':show n)
148 in ArrayLit () $ zipWith convert [0..] ts
150 _ -> error "bad ADT got to outgoing port generation code"
152 Record _ (Just _) ->
153 error "bad record got to outgoing port generation code"
155 Record fields Nothing ->
156 ObjectLit () keys
157 where
158 keys = map convert fields
159 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))