diff --git a/Elm.cabal b/Elm.cabal
index 12f734b..943fbf1 100644
--- a/Elm.cabal
+++ b/Elm.cabal
@@ -47,6 +47,8 @@ Library
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
Generate.JavaScript,
+ Generate.JavaScript.Helpers,
+ Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
@@ -127,6 +129,8 @@ Executable elm
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
Generate.JavaScript,
+ Generate.JavaScript.Helpers,
+ Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
diff --git a/compiler/Generate/JavaScript.hs b/compiler/Generate/JavaScript.hs
index 951e68a..aae77b4 100644
--- a/compiler/Generate/JavaScript.hs
+++ b/compiler/Generate/JavaScript.hs
@@ -8,7 +8,9 @@ import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Generate.JavaScript.Helpers
import qualified Generate.Cases as Case
+import qualified Generate.JavaScript.Ports as Port
import qualified Generate.Markdown as MD
import qualified SourceSyntax.Helpers as Help
import SourceSyntax.Literal
@@ -20,38 +22,15 @@ import Language.ECMAScript3.Syntax
import Language.ECMAScript3.PrettyPrint
import qualified Transform.SafeNames as MakeSafe
-split :: String -> [String]
-split = go []
- where
- go vars str =
- case break (=='.') str of
- (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
- | otherwise -> go (vars ++ [x]) rest
- (x,[]) -> vars ++ [x]
-
-var name = Id () name
-ref name = VarRef () (var name)
-prop name = PropId () (var name)
-f <| x = CallExpr () f [x]
-args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
-function args stmts = FuncExpr () Nothing (map var args) stmts
-call = CallExpr ()
-string = StringLit ()
-
-dotSep vars =
- case vars of
- x:xs -> foldl (DotRef ()) (ref x) (map var xs)
- [] -> error "dotSep must be called on a non-empty list of variables"
-
-obj = dotSep . split
-
varDecl :: String -> Expression () -> VarDecl ()
varDecl x expr =
VarDecl () (var x) (Just expr)
+include :: String -> String -> VarDecl ()
include alias moduleName =
varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
+internalImports :: String -> Statement ()
internalImports name =
VarDeclStmt ()
[ varDecl "_N" (obj "Elm.Native")
@@ -155,7 +134,7 @@ expression (L span expr) =
do let (defs',e') = flattenLets defs e
stmts <- concat <$> mapM definition defs'
exp <- expression e'
- return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
+ return $ function [] (stmts ++ [ ret exp ]) `call` []
MultiIf branches ->
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
@@ -196,15 +175,13 @@ expression (L span expr) =
pad = "
"
md = pad ++ MD.toHtml doc ++ pad
- PortIn name _ _ handler ->
- do handler' <- case handler of
- Nothing -> return []
- Just h -> (:[]) `fmap` expression h
- return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
+ PortIn name tipe ->
+ return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
- PortOut name _ signal ->
- do signal' <- expression signal
- return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
+ PortOut name tipe value ->
+ do value' <- expression value
+ return $ obj "Native.Ports.portOut" `call`
+ [ string name, Port.outgoing tipe, value' ]
definition :: Def -> State Int [Statement ()]
definition (Definition pattern expr@(L span _) _) = do
@@ -250,7 +227,7 @@ definition (Definition pattern expr@(L span _) _) = do
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (PVar y) expr Nothing
-match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
+match :: SrcSpan -> Case.Match -> State Int [Statement ()]
match span mtch =
case mtch of
Case.Match name clauses mtch' ->
@@ -272,7 +249,7 @@ match span mtch =
Case.Break -> return [BreakStmt () Nothing]
Case.Other e ->
do e' <- expression e
- return [ ReturnStmt () (Just e') ]
+ return [ ret e' ]
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
where
dropEnd acc [] = acc
@@ -281,6 +258,7 @@ match span mtch =
Case.Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms
+clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause span variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
where
@@ -295,6 +273,7 @@ clause span variable (Case.Clause value vars mtch) =
[] -> name
is -> drop (last is + 1) name
+flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
flattenLets defs lexpr@(L _ expr) =
case expr of
Let ds body -> flattenLets (defs ++ ds) body
@@ -310,13 +289,13 @@ generate unsafeModule =
programStmts =
concat
[ setup (Just "_elm") (names modul ++ ["values"])
- , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
+ , [ IfSingleStmt () thisModule (ret thisModule) ]
, [ internalImports (List.intercalate "." (names modul)) ]
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
, [ assign ["_op"] (ObjectLit () []) ]
, concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
, [ jsExports ]
- , [ ReturnStmt () (Just thisModule) ]
+ , [ ret thisModule ]
]
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
@@ -342,6 +321,7 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
+binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
binop span op e1 e2 =
case op of
"Basics.." ->
diff --git a/compiler/Generate/JavaScript/Helpers.hs b/compiler/Generate/JavaScript/Helpers.hs
new file mode 100644
index 0000000..ff3f385
--- /dev/null
+++ b/compiler/Generate/JavaScript/Helpers.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -W #-}
+module Generate.JavaScript.Helpers where
+
+import qualified SourceSyntax.Helpers as Help
+import Language.ECMAScript3.Syntax
+
+split :: String -> [String]
+split = go []
+ where
+ go vars str =
+ case break (=='.') str of
+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
+ | otherwise -> go (vars ++ [x]) rest
+ (x,[]) -> vars ++ [x]
+
+var name = Id () name
+ref name = VarRef () (var name)
+prop name = PropId () (var name)
+f <| x = CallExpr () f [x]
+ret e = ReturnStmt () (Just e)
+args ==> e = FuncExpr () Nothing (map var args) [ ret e ]
+function args stmts = FuncExpr () Nothing (map var args) stmts
+call = CallExpr ()
+string = StringLit ()
+
+dotSep vars =
+ case vars of
+ x:xs -> foldl (DotRef ()) (ref x) (map var xs)
+ [] -> error "dotSep must be called on a non-empty list of variables"
+
+obj = dotSep . split
+
+equal a b = InfixExpr () OpStrictEq a b
+instanceof tipe x = InfixExpr () OpInstanceof x (ref tipe)
+typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)
+member field x = InfixExpr () OpIn (string field) x
diff --git a/compiler/Generate/JavaScript/Ports.hs b/compiler/Generate/JavaScript/Ports.hs
new file mode 100644
index 0000000..d6e292e
--- /dev/null
+++ b/compiler/Generate/JavaScript/Ports.hs
@@ -0,0 +1,105 @@
+{-# OPTIONS_GHC -W #-}
+module Generate.JavaScript.Ports (incoming, outgoing) where
+
+import Generate.JavaScript.Helpers
+import qualified SourceSyntax.Helpers as Help
+import SourceSyntax.Type
+import Language.ECMAScript3.Syntax
+
+check :: a -> [a -> Expression ()] -> Expression () -> Expression ()
+check x checks continue =
+ CondExpr () (foldl1 (InfixExpr () OpLOr) (map ($x) checks)) continue throw
+ where
+ throw = obj "_E.raise" <| string "invalid input to port"
+
+incoming :: Type -> Expression ()
+incoming t = ["v"] ==> go t (ref "v")
+ where
+ go :: Type -> Expression () -> Expression ()
+ go tipe x =
+ case tipe of
+ Lambda _ _ -> error "functions should not be allowed through input ports"
+ Var _ -> error "type variables should not be allowed through input ports"
+ Data ctor []
+ | ctor == "Int" -> elm "Int" [typeof "number"]
+ | ctor == "Float" -> elm "Float" [typeof "number"]
+ | ctor == "Bool" -> elm "Bool" [typeof "boolean"]
+ | ctor == "String" -> elm "String" [typeof "string", instanceof "String"]
+ | ctor == "JavaScript.JSNumber" -> js [typeof "number"]
+ | ctor == "JavaScript.JSBool" -> js [typeof "boolean"]
+ | ctor == "JavaScript.JSString" -> js [typeof "string", instanceof "String"]
+ where
+ elm out checks = check x checks (obj ("_J.to" ++ out) <| x)
+ js checks = check x checks x
+
+ Data ctor [t]
+ | ctor == "Maybe.Maybe" ->
+ CondExpr () (equal x (NullLit ()))
+ (obj "Maybe.Nothing")
+ (obj "Maybe.Just" <| go t x)
+
+ | ctor == "Signal.Signal" ->
+ obj "Native.Ports.incomingSignal" <| incoming t
+
+ | ctor == "_List" ->
+ check x [instanceof "Array"] (obj "_J.toList" <| array)
+ where
+ array = DotRef () x (var "map") <| incoming t
+
+ Data ctor ts | Help.isTuple ctor -> check x [instanceof "Array"] tuple
+ where
+ tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
+ values = zipWith convert [0..] ts
+ convert n t = ( PropId () $ var ('_':show n)
+ , go t (BracketRef () x (IntLit () n)))
+
+ Data _ _ -> error "bad ADT got to port generation code"
+
+ Record _ (Just _) -> error "bad record got to port generation code"
+
+ Record fields Nothing ->
+ check x (typeof "object" : map (member . fst) fields) object
+ where
+ object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
+ keys = map convert fields
+ convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
+
+outgoing t = ["v"] ==> go t (ref "v")
+ where
+ go :: Type -> Expression () -> Expression ()
+ go tipe x =
+ case tipe of
+ Lambda _ _ -> error "unimplemented"
+ Var _ -> error "type variables should not be allowed through input ports"
+ Data ctor []
+ | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x
+ | ctor `elem` jsPrims -> x
+ where
+ jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]
+
+ Data ctor [t]
+ | ctor == "Maybe.Maybe" ->
+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
+ (NullLit ())
+ (DotRef () x (var "_0"))
+
+ | ctor == "Signal.Signal" ->
+ obj "Native.Ports.outgoingSignal" <| incoming t
+
+ | ctor == "_List" ->
+ DotRef () (obj "_J.fromList" <| x) (var "map") <| incoming t
+
+ Data ctor ts | Help.isTuple ctor ->
+ ArrayLit () $ zipWith convert [0..] ts
+ where
+ convert n t = go t $ DotRef () x $ var ('_':show n)
+
+ Data _ _ -> error "bad ADT got to port generation code"
+
+ Record _ (Just _) -> error "bad record got to port generation code"
+
+ Record fields Nothing ->
+ ObjectLit () keys
+ where
+ keys = map convert fields
+ convert (f,t) = (PropId () (var f), go t (DotRef () x (var f)))
diff --git a/libraries/Native/Ports.js b/libraries/Native/Ports.js
index d344402..6092dfd 100644
--- a/libraries/Native/Ports.js
+++ b/libraries/Native/Ports.js
@@ -6,62 +6,58 @@ Elm.Native.Ports.make = function(elm) {
var Signal = Elm.Signal.make(elm);
- // On failure, return message. On success, return the value in an array.
- // Wrapping in an array allows the programmer to pass in a null value.
- function processInput(converter, v) {
- try { var elmValue = converter(v); }
- catch(e) { return "The given value caused a runtime error!\n" + e.toString(); }
-
- var ctor = elmValue.ctor;
- if (ctor === 'Nothing' || ctor === 'Left') {
- return "The port's conversion function failed.";
- } else if (ctor === 'Just' || ctor === 'Right') {
- return [elmValue._0];
+ function incomingSignal(converter) {
+ return function(port) {
+ var base = converter(port.internal.defaultValue);
+ var signal = Signal.constant(base);
+ port.internal.subscribe(function(v) {
+ try {
+ elm.notify(signal.id, converter(v));
+ } catch(e) {
+ port.internal.errorHandler(v);
+ }
+ });
+ return signal;
}
- return [elmValue];
}
+
+ function outgoingSignal(converter) {
+ return function(signal) {
+ var subscribers = []
+ function subscribe(handler) {
+ subscribers.push(handler);
+ }
+ function unsubscribe(handler) {
+ subscribers.pop(subscribers.indexOf(handler));
+ }
+ A2( Signal.lift, function(value) {
+ var val = converter(value);
+ var len = subscribers.length;
+ for (var i = 0; i < len; ++i) {
+ subscribers[i](val);
+ }
+ }, signal);
+ return { subscribe:subscribe, unsubscribe:unsubscribe };
+ }
+ }
+
function portIn(name, converter) {
- var port = elm.ports.incoming[name];
- if (!port) {
+ var value = elm.ports.incoming[name];
+ if (!value) {
throw new Error("Initialization Error: port '" + name +
"' was not given an input!");
}
elm.ports.uses[name] += 1;
- var result = processInput(converter, port.internal.defaultValue);
- if (typeof result === 'string') {
- throw new Error("Initialization Error: The default value for port '" +
- name + "' is invalid.\n" + result);
- }
- var signal = Signal.constant(result[0]);
- port.internal.subscribe(function(v) {
- var result = processInput(converter, v);
- if (typeof result === 'string') {
- port.internal.errorHandler(v)
- } else {
- elm.notify(signal.id, result[0]);
- }
- });
- return signal;
+ return converter(value);
}
- function portOut(name, signal) {
- var subscribers = []
- function subscribe(handler) {
- subscribers.push(handler);
- }
- function unsubscribe(handler) {
- subscribers.pop(subscribers.indexOf(handler));
- }
- A2( Signal.lift, function(value) {
- var len = subscribers.length;
- for (var i = 0; i < len; ++i) {
- subscribers[i](value);
- }
- }, signal);
- elm.ports.outgoing[name] = { subscribe:subscribe, unsubscribe:unsubscribe };
- return signal;
+ function portOut(name, converter, value) {
+ elm.ports.outgoing[name] = converter(value);
+ return value;
}
return elm.Native.Ports.values = {
+ incomingSignal: incomingSignal,
+ outgoingSignal: outgoingSignal,
portOut: portOut,
portIn: portIn
};