git.iko.soy/elk
on 0f3f409 help sign in
elk/compiler/Generate/JavaScript/Ports.hs
165 lines 6.1 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
8import Generate.JavaScript.Variable (canonical)
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 App (Type v) [t]
33 | Var.isSignal v -> obj ["_P","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 Type (Var.Canonical Var.BuiltIn name)
46 | name == "Int" -> from JSNumber
47 | name == "Float" -> from JSNumber
48 | name == "Bool" -> from JSBoolean
49 | name == "String" -> from JSString
50 where
51 from checks = check x checks x
53 Type name
54 | Var.isJson name -> canonical fromJS <| x
55 | otherwise -> error "bad type got to incoming port generation code"
56 where
57 fromJS = Var.Canonical (Var.Module "Native.Json") "fromJS"
60 App f args ->
61 case f : args of
62 Type name : [t]
63 | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))
64 (obj ["Maybe","Nothing"])
65 (obj ["Maybe","Just"] <| inc t x)
67 | Var.isList name -> check x JSArray (obj ["_L","fromArray"] <| array)
69 | Var.isArray name -> check x JSArray (obj ["_A","fromJSArray"] <| array)
70 where
71 array = DotRef () x (var "map") <| incoming t
73 Type name : ts
74 | Var.isTuple name -> check x JSArray tuple
75 where
76 tuple = ObjectLit () $ (prop "ctor", ctor) : values
78 ctor = string ("_Tuple" ++ show (length ts))
79 values = zipWith convert [0..] ts
81 convert n t = ( prop ('_':show n)
82 , inc t (BracketRef () x (IntLit () n))
83 )
85 _ -> error "bad ADT got to incoming port generation code"
87 Record _ (Just _) ->
88 error "bad record got to incoming port generation code"
90 Record fields Nothing ->
91 check x (JSObject (map fst fields)) object
92 where
93 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
94 keys = map convert fields
95 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
97outgoing :: CanonicalType -> Expression ()
98outgoing tipe =
99 case tipe of
100 Aliased _ t -> outgoing t
102 App (Type v) [t]
103 | Var.isSignal v -> obj ["_P","outgoingSignal"] <| outgoing t
105 _ -> ["v"] ==> out tipe (ref "v")
107out :: CanonicalType -> Expression () -> Expression ()
108out tipe x =
109 case tipe of
110 Aliased _ t -> out t x
112 Lambda _ _
113 | numArgs > 1 && numArgs < 10 ->
114 func (ref ('A':show numArgs) `call` (x:values))
115 | otherwise -> func (foldl (<|) x values)
116 where
117 ts = T.collectLambdas tipe
118 numArgs = length ts - 1
119 args = map (\n -> '_' : show n) [0..]
120 values = zipWith inc (init ts) (map ref args)
121 func body = function (take numArgs args)
122 [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
123 , ret (out (last ts) (ref "_r"))
124 ]
126 Var _ -> error "type variables should not be allowed through input ports"
128 Type (Var.Canonical Var.BuiltIn name)
129 | name `elem` ["Int","Float","Bool","String"] -> x
131 Type name
132 | Var.isJson name -> canonical toJS <| x
133 | otherwise -> error "bad type got to outgoing port generation code"
134 where
135 toJS = Var.Canonical (Var.Module "Native.Json") "toJS"
137 App f args ->
138 case f : args of
139 Type name : [t]
140 | Var.isMaybe name ->
141 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
142 (NullLit ())
143 (out t (DotRef () x (var "_0")))
145 | Var.isArray name ->
146 DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t
148 | Var.isList name ->
149 DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t
151 Type name : ts
152 | Var.isTuple name ->
153 let convert n t = out t $ DotRef () x $ var ('_':show n)
154 in ArrayLit () $ zipWith convert [0..] ts
156 _ -> error "bad ADT got to outgoing port generation code"
158 Record _ (Just _) ->
159 error "bad record got to outgoing port generation code"
161 Record fields Nothing ->
162 ObjectLit () keys
163 where
164 keys = map convert fields
165 convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))