git.iko.soy/elk
on master help sign in
Generate conversion code for ports
commit32fbbca5b2addb17453f43be9275164d1d9187aa authorEvan Czaplicki <info@elm-lang.org> dateMon 13 Jan 2014, 19:32 (13 years ago) parent63243ca
5 files changed+203−82
compare with master
unifiedsplit
Elm.cabal+4 compiler/Generate/JavaScript.hs+18−38 compiler/Generate/JavaScript/Helpers.hs+36 compiler/Generate/JavaScript/Ports.hs+105 libraries/Native/Ports.js+40−44
Elm.cabal+4
@@ -47,6 +47,8 @@ Library
4747 SourceSyntax.PrettyPrint,
4848 SourceSyntax.Type,
4949 Generate.JavaScript,
50+ Generate.JavaScript.Helpers,
51+ Generate.JavaScript.Ports,
5052 Generate.Noscript,
5153 Generate.Markdown,
5254 Generate.Html,
@@ -127,6 +129,8 @@ Executable elm
127129 SourceSyntax.PrettyPrint,
128130 SourceSyntax.Type,
129131 Generate.JavaScript,
132+ Generate.JavaScript.Helpers,
133+ Generate.JavaScript.Ports,
130134 Generate.Noscript,
131135 Generate.Markdown,
132136 Generate.Html,
compiler/Generate/JavaScript.hs+18−38
@@ -8,7 +8,9 @@ import qualified Data.List as List
88import qualified Data.Map as Map
99import qualified Data.Set as Set
1010
11+import Generate.JavaScript.Helpers
1112import qualified Generate.Cases as Case
13+import qualified Generate.JavaScript.Ports as Port
1214import qualified Generate.Markdown as MD
1315import qualified SourceSyntax.Helpers as Help
1416import SourceSyntax.Literal
@@ -20,38 +22,15 @@ import Language.ECMAScript3.Syntax
2022import Language.ECMAScript3.PrettyPrint
2123import qualified Transform.SafeNames as MakeSafe
2224
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−
4825varDecl :: String -> Expression () -> VarDecl ()
4926varDecl x expr =
5027 VarDecl () (var x) (Just expr)
5128
29+include :: String -> String -> VarDecl ()
5230include alias moduleName =
5331 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
5432
33+internalImports :: String -> Statement ()
5534internalImports name =
5635 VarDeclStmt ()
5736 [ varDecl "_N" (obj "Elm.Native")
@@ -155,7 +134,7 @@ expression (L span expr) =
155134 do let (defs',e') = flattenLets defs e
156135 stmts <- concat <$> mapM definition defs'
157136 exp <- expression e'
158− return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
137+ return $ function [] (stmts ++ [ ret exp ]) `call` []
159138
160139 MultiIf branches ->
161140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
@@ -196,15 +175,13 @@ expression (L span expr) =
196175 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197176 md = pad ++ MD.toHtml doc ++ pad
198177
199− PortIn name _ _ handler ->
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')
178+ PortIn name tipe ->
179+ return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
204180
205− PortOut name _ signal ->
206− do signal' <- expression signal
207− return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
181+ PortOut name tipe value ->
182+ do value' <- expression value
183+ return $ obj "Native.Ports.portOut" `call`
184+ [ string name, Port.outgoing tipe, value' ]
208185
209186definition :: Def -> State Int [Statement ()]
210187definition (Definition pattern expr@(L span _) _) = do
@@ -250,7 +227,7 @@ definition (Definition pattern expr@(L span _) _) = do
250227 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
251228 in definition $ Definition (PVar y) expr Nothing
252229
253−match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
230+match :: SrcSpan -> Case.Match -> State Int [Statement ()]
254231match span mtch =
255232 case mtch of
256233 Case.Match name clauses mtch' ->
@@ -272,7 +249,7 @@ match span mtch =
272249 Case.Break -> return [BreakStmt () Nothing]
273250 Case.Other e ->
274251 do e' <- expression e
275− return [ ReturnStmt () (Just e') ]
252+ return [ ret e' ]
276253 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
277254 where
278255 dropEnd acc [] = acc
@@ -281,6 +258,7 @@ match span mtch =
281258 Case.Other _ -> acc ++ [m]
282259 _ -> dropEnd (acc ++ [m]) ms
283260
261+clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
284262clause span variable (Case.Clause value vars mtch) =
285263 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
286264 where
@@ -295,6 +273,7 @@ clause span variable (Case.Clause value vars mtch) =
295273 [] -> name
296274 is -> drop (last is + 1) name
297275
276+flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
298277flattenLets defs lexpr@(L _ expr) =
299278 case expr of
300279 Let ds body -> flattenLets (defs ++ ds) body
@@ -310,13 +289,13 @@ generate unsafeModule =
310289 programStmts =
311290 concat
312291 [ setup (Just "_elm") (names modul ++ ["values"])
313− , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
292+ , [ IfSingleStmt () thisModule (ret thisModule) ]
314293 , [ internalImports (List.intercalate "." (names modul)) ]
315294 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
316295 , [ assign ["_op"] (ObjectLit () []) ]
317296 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
318297 , [ jsExports ]
319− , [ ReturnStmt () (Just thisModule) ]
298+ , [ ret thisModule ]
320299 ]
321300
322301 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
@@ -342,6 +321,7 @@ generate unsafeModule =
342321 Nothing -> tail . init $ List.inits path
343322 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
344323
324+binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
345325binop span op e1 e2 =
346326 case op of
347327 "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) {
66
77 var Signal = Elm.Signal.make(elm);
88
9− // On failure, return message. On success, return the value in an array.
10− // Wrapping in an array allows the programmer to pass in a null value.
11− function processInput(converter, v) {
12− try { var elmValue = converter(v); }
13− catch(e) { return "The given value caused a runtime error!\n" + e.toString(); }
9+ function incomingSignal(converter) {
10+ return function(port) {
11+ var base = converter(port.internal.defaultValue);
12+ var signal = Signal.constant(base);
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+ }
1423
15− var ctor = elmValue.ctor;
16− if (ctor === 'Nothing' || ctor === 'Left') {
17− return "The port's conversion function failed.";
18− } else if (ctor === 'Just' || ctor === 'Right') {
19− return [elmValue._0];
24+ function outgoingSignal(converter) {
25+ return function(signal) {
26+ var subscribers = []
27+ function subscribe(handler) {
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 };
2041 }
21− return [elmValue];
2242 }
43+
2344 function portIn(name, converter) {
24− var port = elm.ports.incoming[name];
25− if (!port) {
45+ var value = elm.ports.incoming[name];
46+ if (!value) {
2647 throw new Error("Initialization Error: port '" + name +
2748 "' was not given an input!");
2849 }
2950 elm.ports.uses[name] += 1;
30− var result = processInput(converter, port.internal.defaultValue);
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;
51+ return converter(value);
4552 }
46− function portOut(name, signal) {
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 };
61− return signal;
53+ function portOut(name, converter, value) {
54+ elm.ports.outgoing[name] = converter(value);
55+ return value;
6256 }
6357
6458 return elm.Native.Ports.values = {
59+ incomingSignal: incomingSignal,
60+ outgoingSignal: outgoingSignal,
6561 portOut: portOut,
6662 portIn: portIn
6763 };