Generate conversion code for ports

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,

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 = "<div style=\"height:0;width:0;\">&nbsp;</div>"
             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.." ->

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

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)))

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
     };