git.iko.soy/elk
on master help sign in
Generate conversion code for ports
32fbbcaEvan Czaplicki
Elm.cabal+4
compare with master
unifiedsplit
@@ -47,6 +47,8 @@ Library
47 SourceSyntax.PrettyPrint,
47 SourceSyntax.PrettyPrint,
48 SourceSyntax.Type,
48 SourceSyntax.Type,
49 Generate.JavaScript,
49 Generate.JavaScript,
50+ Generate.JavaScript.Helpers,
51+ Generate.JavaScript.Ports,
50 Generate.Noscript,
52 Generate.Noscript,
51 Generate.Markdown,
53 Generate.Markdown,
52 Generate.Html,
54 Generate.Html,
@@ -127,6 +129,8 @@ Executable elm
127 SourceSyntax.PrettyPrint,
129 SourceSyntax.PrettyPrint,
128 SourceSyntax.Type,
130 SourceSyntax.Type,
129 Generate.JavaScript,
131 Generate.JavaScript,
132+ Generate.JavaScript.Helpers,
133+ Generate.JavaScript.Ports,
130 Generate.Noscript,
134 Generate.Noscript,
131 Generate.Markdown,
135 Generate.Markdown,
132 Generate.Html,
136 Generate.Html,
compiler/Generate/JavaScript.hs+18−38
@@ -8,7 +8,9 @@ import qualified Data.List as List
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10
10
11+import Generate.JavaScript.Helpers
11import qualified Generate.Cases as Case
12import qualified Generate.Cases as Case
13+import qualified Generate.JavaScript.Ports as Port
12import qualified Generate.Markdown as MD
14import qualified Generate.Markdown as MD
13import qualified SourceSyntax.Helpers as Help
15import qualified SourceSyntax.Helpers as Help
14import SourceSyntax.Literal
16import SourceSyntax.Literal
@@ -20,38 +22,15 @@ import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
22import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23import qualified Transform.SafeNames as MakeSafe
22
24
23−split :: String -> [String]
24−split = go []
25− where
26− go vars str =
27− case break (=='.') str of
28− (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29− | otherwise -> go (vars ++ [x]) rest
30− (x,[]) -> vars ++ [x]
31−
32−var name = Id () name
33−ref name = VarRef () (var name)
34−prop name = PropId () (var name)
35−f <| x = CallExpr () f [x]
36−args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37−function args stmts = FuncExpr () Nothing (map var args) stmts
38−call = CallExpr ()
39−string = StringLit ()
40−
41−dotSep vars =
42− case vars of
43− x:xs -> foldl (DotRef ()) (ref x) (map var xs)
44− [] -> error "dotSep must be called on a non-empty list of variables"
45−
46−obj = dotSep . split
47−
48varDecl :: String -> Expression () -> VarDecl ()
25varDecl :: String -> Expression () -> VarDecl ()
49varDecl x expr =
26varDecl x expr =
50 VarDecl () (var x) (Just expr)
27 VarDecl () (var x) (Just expr)
51
28
29+include :: String -> String -> VarDecl ()
52include alias moduleName =
30include alias moduleName =
53 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
31 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
54
32
33+internalImports :: String -> Statement ()
55internalImports name =
34internalImports name =
56 VarDeclStmt ()
35 VarDeclStmt ()
57 [ varDecl "_N" (obj "Elm.Native")
36 [ varDecl "_N" (obj "Elm.Native")
@@ -155,7 +134,7 @@ expression (L span expr) =
155 do let (defs',e') = flattenLets defs e
134 do let (defs',e') = flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
135 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
136 exp <- expression e'
158− return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
137+ return $ function [] (stmts ++ [ ret exp ]) `call` []
159
138
160 MultiIf branches ->
139 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
@@ -196,15 +175,13 @@ expression (L span expr) =
196 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
175 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197 md = pad ++ MD.toHtml doc ++ pad
176 md = pad ++ MD.toHtml doc ++ pad
198
177
199− PortIn name _ _ handler ->
178+ PortIn name tipe ->
200− do handler' <- case handler of
201− Nothing -> return []
202− Just h -> (:[]) `fmap` expression h
203− return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
179+ return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
204
180
205− PortOut name _ signal ->
181+ PortOut name tipe value ->
206− do signal' <- expression signal
182+ do value' <- expression value
207− return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
183+ return $ obj "Native.Ports.portOut" `call`
184+ [ string name, Port.outgoing tipe, value' ]
208
185
209definition :: Def -> State Int [Statement ()]
186definition :: Def -> State Int [Statement ()]
210definition (Definition pattern expr@(L span _) _) = do
187definition (Definition pattern expr@(L span _) _) = do
@@ -250,7 +227,7 @@ definition (Definition pattern expr@(L span _) _) = do
250 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
227 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
251 in definition $ Definition (PVar y) expr Nothing
228 in definition $ Definition (PVar y) expr Nothing
252
229
253−match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
230+match :: SrcSpan -> Case.Match -> State Int [Statement ()]
254match span mtch =
231match span mtch =
255 case mtch of
232 case mtch of
256 Case.Match name clauses mtch' ->
233 Case.Match name clauses mtch' ->
@@ -272,7 +249,7 @@ match span mtch =
272 Case.Break -> return [BreakStmt () Nothing]
249 Case.Break -> return [BreakStmt () Nothing]
273 Case.Other e ->
250 Case.Other e ->
274 do e' <- expression e
251 do e' <- expression e
275− return [ ReturnStmt () (Just e') ]
252+ return [ ret e' ]
276 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
253 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
277 where
254 where
278 dropEnd acc [] = acc
255 dropEnd acc [] = acc
@@ -281,6 +258,7 @@ match span mtch =
281 Case.Other _ -> acc ++ [m]
258 Case.Other _ -> acc ++ [m]
282 _ -> dropEnd (acc ++ [m]) ms
259 _ -> dropEnd (acc ++ [m]) ms
283
260
261+clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
284clause span variable (Case.Clause value vars mtch) =
262clause span variable (Case.Clause value vars mtch) =
285 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
263 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
286 where
264 where
@@ -295,6 +273,7 @@ clause span variable (Case.Clause value vars mtch) =
295 [] -> name
273 [] -> name
296 is -> drop (last is + 1) name
274 is -> drop (last is + 1) name
297
275
276+flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
298flattenLets defs lexpr@(L _ expr) =
277flattenLets defs lexpr@(L _ expr) =
299 case expr of
278 case expr of
300 Let ds body -> flattenLets (defs ++ ds) body
279 Let ds body -> flattenLets (defs ++ ds) body
@@ -310,13 +289,13 @@ generate unsafeModule =
310 programStmts =
289 programStmts =
311 concat
290 concat
312 [ setup (Just "_elm") (names modul ++ ["values"])
291 [ setup (Just "_elm") (names modul ++ ["values"])
313− , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
292+ , [ IfSingleStmt () thisModule (ret thisModule) ]
314 , [ internalImports (List.intercalate "." (names modul)) ]
293 , [ internalImports (List.intercalate "." (names modul)) ]
315 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
294 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
316 , [ assign ["_op"] (ObjectLit () []) ]
295 , [ assign ["_op"] (ObjectLit () []) ]
317 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
296 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
318 , [ jsExports ]
297 , [ jsExports ]
319− , [ ReturnStmt () (Just thisModule) ]
298+ , [ ret thisModule ]
320 ]
299 ]
321
300
322 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
301 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
@@ -342,6 +321,7 @@ generate unsafeModule =
342 Nothing -> tail . init $ List.inits path
321 Nothing -> tail . init $ List.inits path
343 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
322 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
344
323
324+binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
345binop span op e1 e2 =
325binop span op e1 e2 =
346 case op of
326 case op of
347 "Basics.." ->
327 "Basics.." ->
compiler/Generate/JavaScript/Helpers.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# OPTIONS_GHC -W #-}
2+module Generate.JavaScript.Helpers where
3+
4+import qualified SourceSyntax.Helpers as Help
5+import Language.ECMAScript3.Syntax
6+
7+split :: String -> [String]
8+split = go []
9+ where
10+ go vars str =
11+ case break (=='.') str of
12+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
13+ | otherwise -> go (vars ++ [x]) rest
14+ (x,[]) -> vars ++ [x]
15+
16+var name = Id () name
17+ref name = VarRef () (var name)
18+prop name = PropId () (var name)
19+f <| x = CallExpr () f [x]
20+ret e = ReturnStmt () (Just e)
21+args ==> e = FuncExpr () Nothing (map var args) [ ret e ]
22+function args stmts = FuncExpr () Nothing (map var args) stmts
23+call = CallExpr ()
24+string = StringLit ()
25+
26+dotSep vars =
27+ case vars of
28+ x:xs -> foldl (DotRef ()) (ref x) (map var xs)
29+ [] -> error "dotSep must be called on a non-empty list of variables"
30+
31+obj = dotSep . split
32+
33+equal a b = InfixExpr () OpStrictEq a b
34+instanceof tipe x = InfixExpr () OpInstanceof x (ref tipe)
35+typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)
36+member field x = InfixExpr () OpIn (string field) x
compiler/Generate/JavaScript/Ports.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# OPTIONS_GHC -W #-}
2+module Generate.JavaScript.Ports (incoming, outgoing) where
3+
4+import Generate.JavaScript.Helpers
5+import qualified SourceSyntax.Helpers as Help
6+import SourceSyntax.Type
7+import Language.ECMAScript3.Syntax
8+
9+check :: a -> [a -> Expression ()] -> Expression () -> Expression ()
10+check 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"
14+
15+incoming :: Type -> Expression ()
16+incoming 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
34+
35+ Data ctor [t]
36+ | ctor == "Maybe.Maybe" ->
37+ CondExpr () (equal x (NullLit ()))
38+ (obj "Maybe.Nothing")
39+ (obj "Maybe.Just" <| go t x)
40+
41+ | ctor == "Signal.Signal" ->
42+ obj "Native.Ports.incomingSignal" <| incoming t
43+
44+ | ctor == "_List" ->
45+ check x [instanceof "Array"] (obj "_J.toList" <| array)
46+ where
47+ array = DotRef () x (var "map") <| incoming t
48+
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)))
55+
56+ Data _ _ -> error "bad ADT got to port generation code"
57+
58+ Record _ (Just _) -> error "bad record got to port generation code"
59+
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)))
66+
67+outgoing 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"]
79+
80+ Data ctor [t]
81+ | ctor == "Maybe.Maybe" ->
82+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
83+ (NullLit ())
84+ (DotRef () x (var "_0"))
85+
86+ | ctor == "Signal.Signal" ->
87+ obj "Native.Ports.outgoingSignal" <| incoming t
88+
89+ | ctor == "_List" ->
90+ DotRef () (obj "_J.fromList" <| x) (var "map") <| incoming t
91+
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)
96+
97+ Data _ _ -> error "bad ADT got to port generation code"
98+
99+ Record _ (Just _) -> error "bad record got to port generation code"
100+
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)))
libraries/Native/Ports.js+40−44
@@ -6,62 +6,58 @@ Elm.Native.Ports.make = function(elm) {
6
6
7 var Signal = Elm.Signal.make(elm);
7 var Signal = Elm.Signal.make(elm);
8
8
9− // On failure, return message. On success, return the value in an array.
9+ function incomingSignal(converter) {
10− // Wrapping in an array allows the programmer to pass in a null value.
10+ return function(port) {
11− function processInput(converter, v) {
11+ var base = converter(port.internal.defaultValue);
12− try { var elmValue = converter(v); }
12+ var signal = Signal.constant(base);
13− catch(e) { return "The given value caused a runtime error!\n" + e.toString(); }
13+ port.internal.subscribe(function(v) {
14+ try {
15+ elm.notify(signal.id, converter(v));
16+ } catch(e) {
17+ port.internal.errorHandler(v);
18+ }
19+ });
20+ return signal;
21+ }
22+ }
14
23
15− var ctor = elmValue.ctor;
24+ function outgoingSignal(converter) {
16− if (ctor === 'Nothing' || ctor === 'Left') {
25+ return function(signal) {
17− return "The port's conversion function failed.";
26+ var subscribers = []
18− } else if (ctor === 'Just' || ctor === 'Right') {
27+ function subscribe(handler) {
19− return [elmValue._0];
28+ subscribers.push(handler);
29+ }
30+ function unsubscribe(handler) {
31+ subscribers.pop(subscribers.indexOf(handler));
32+ }
33+ A2( Signal.lift, function(value) {
34+ var val = converter(value);
35+ var len = subscribers.length;
36+ for (var i = 0; i < len; ++i) {
37+ subscribers[i](val);
38+ }
39+ }, signal);
40+ return { subscribe:subscribe, unsubscribe:unsubscribe };
20 }
41 }
21− return [elmValue];
22 }
42 }
43+
23 function portIn(name, converter) {
44 function portIn(name, converter) {
24− var port = elm.ports.incoming[name];
45+ var value = elm.ports.incoming[name];
25− if (!port) {
46+ if (!value) {
26 throw new Error("Initialization Error: port '" + name +
47 throw new Error("Initialization Error: port '" + name +
27 "' was not given an input!");
48 "' was not given an input!");
28 }
49 }
29 elm.ports.uses[name] += 1;
50 elm.ports.uses[name] += 1;
30− var result = processInput(converter, port.internal.defaultValue);
51+ return converter(value);
31− if (typeof result === 'string') {
32− throw new Error("Initialization Error: The default value for port '" +
33− name + "' is invalid.\n" + result);
34− }
35− var signal = Signal.constant(result[0]);
36− port.internal.subscribe(function(v) {
37− var result = processInput(converter, v);
38− if (typeof result === 'string') {
39− port.internal.errorHandler(v)
40− } else {
41− elm.notify(signal.id, result[0]);
42− }
43− });
44− return signal;
45 }
52 }
46− function portOut(name, signal) {
53+ function portOut(name, converter, value) {
47− var subscribers = []
48− function subscribe(handler) {
49− subscribers.push(handler);
50− }
51− function unsubscribe(handler) {
52− subscribers.pop(subscribers.indexOf(handler));
53− }
54− A2( Signal.lift, function(value) {
55− var len = subscribers.length;
56− for (var i = 0; i < len; ++i) {
57− subscribers[i](value);
58− }
59− }, signal);
60− elm.ports.outgoing[name] = { subscribe:subscribe, unsubscribe:unsubscribe };
54+ elm.ports.outgoing[name] = converter(value);
61− return signal;
55+ return value;
62 }
56 }
63
57
64 return elm.Native.Ports.values = {
58 return elm.Native.Ports.values = {
59+ incomingSignal: incomingSignal,
60+ outgoingSignal: outgoingSignal,
65 portOut: portOut,
61 portOut: portOut,
66 portIn: portIn
62 portIn: portIn
67 };
63 };