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