1b44fbf · elk · git.iko.soy

Elm.cabal+4

compare with master

unifiedsplit

@@ -47,6 +47,8 @@ Library

47 SourceSyntax.PrettyPrint,

48 SourceSyntax.Type,

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

9import qualified Data.Set as Set

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;\"> </div>"

175 pad = "<div style=\"height:0;width:0;\"> </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+37

@@ -0,0 +1,37 @@

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 =

35+ InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

36+typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

37+member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hsnew file+130

@@ -0,0 +1,130 @@

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 as T

7+import Language.ECMAScript3.Syntax

8+

9+data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

10+ deriving Show

11+

12+check :: Expression () -> JSType -> Expression () -> Expression ()

13+check x jsType continue =

14+ CondExpr () (jsFold OpLOr checks x) continue throw

15+ where

16+ jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17+ throw = obj "_E.raise" <| InfixExpr () OpAdd msg x

18+ msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19+ checks = case jsType of

20+ JSNumber -> [typeof "number"]

21+ JSBoolean -> [typeof "boolean"]

22+ JSString -> [typeof "string", instanceof "String"]

23+ JSArray -> [instanceof "Array"]

24+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25+

26+incoming :: Type -> Expression ()

27+incoming tipe =

28+ case tipe of

29+ Data "Signal.Signal" [t] ->

30+ obj "Native.Ports.incomingSignal" <| incoming t

31+ _ -> ["v"] ==> inc tipe (ref "v")

32+

33+inc :: Type -> Expression () -> Expression ()

34+inc tipe x =

35+ case tipe of

36+ Lambda _ _ -> error "functions should not be allowed through input ports"

37+ Var _ -> error "type variables should not be allowed through input ports"

38+ Data ctor []

39+ | ctor == "Int" -> elm JSNumber

40+ | ctor == "Float" -> elm JSNumber

41+ | ctor == "Bool" -> elm JSBoolean

42+ | ctor == "String" -> elm JSString

43+ | ctor == "JavaScript.JSNumber" -> js JSNumber

44+ | ctor == "JavaScript.JSBool" -> js JSBoolean

45+ | ctor == "JavaScript.JSString" -> js JSString

46+ where

47+ elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)

48+ js checks = check x checks x

49+

50+ Data ctor [t]

51+ | ctor == "Maybe.Maybe" ->

52+ CondExpr () (equal x (NullLit ()))

53+ (obj "Maybe.Nothing")

54+ (obj "Maybe.Just" <| inc t x)

55+

56+ | ctor == "_List" ->

57+ check x JSArray (obj "_J.toList" <| array)

58+ where

59+ array = DotRef () x (var "map") <| incoming t

60+

61+ Data ctor ts | Help.isTuple ctor -> check x JSArray tuple

62+ where

63+ tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values

64+ values = zipWith convert [0..] ts

65+ convert n t = ( PropId () $ var ('_':show n)

66+ , inc t (BracketRef () x (IntLit () n)))

67+

68+ Data _ _ -> error "bad ADT got to port generation code"

69+

70+ Record _ (Just _) -> error "bad record got to port generation code"

71+

72+ Record fields Nothing -> check x (JSObject (map fst fields)) object

73+ where

74+ object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys

75+ keys = map convert fields

76+ convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))

77+

78+outgoing tipe =

79+ case tipe of

80+ Data "Signal.Signal" [t] ->

81+ obj "Native.Ports.outgoingSignal" <| outgoing t

82+ _ -> ["v"] ==> out tipe (ref "v")

83+

84+out :: Type -> Expression () -> Expression ()

85+out tipe x =

86+ case tipe of

87+ Lambda _ _

88+ | numArgs > 1 && numArgs < 10 ->

89+ func (ref ('A':show numArgs) `call` (x:values))

90+ | otherwise -> func (foldl (<|) x values)

91+ where

92+ ts = T.collectLambdas tipe

93+ numArgs = length ts - 1

94+ args = map (\n -> '_' : show n) [0..]

95+ values = zipWith inc (init ts) (map ref args)

96+ func body = function (take numArgs args)

97+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

98+ , ret (out (last ts) (ref "_r"))

99+ ]

100+

101+ Var _ -> error "type variables should not be allowed through input ports"

102+ Data ctor []

103+ | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x

104+ | ctor `elem` jsPrims -> x

105+ where

106+ jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]

107+

108+ Data ctor [t]

109+ | ctor == "Maybe.Maybe" ->

110+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

111+ (NullLit ())

112+ (DotRef () x (var "_0"))

113+

114+ | ctor == "_List" ->

115+ DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t

116+

117+ Data ctor ts | Help.isTuple ctor ->

118+ ArrayLit () $ zipWith convert [0..] ts

119+ where

120+ convert n t = out t $ DotRef () x $ var ('_':show n)

121+

122+ Data _ _ -> error "bad ADT got to port generation code"

123+

124+ Record _ (Just _) -> error "bad record got to port generation code"

125+

126+ Record fields Nothing ->

127+ ObjectLit () keys

128+ where

129+ keys = map convert fields

130+ convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))

compiler/Parse/Declaration.hs+2−3

@@ -59,6 +59,5 @@ port =

59 name <- lowVar

60 whitespace

61 let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }

62− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr

62+ D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr

63− , port' (string "<-") D.PPOut Expr.expr

63+ , port' equals D.PPDef Expr.expr ]

64− , port' (string "->") D.PPIn Expr.expr ]

compiler/SourceSyntax/Declaration.hs+7−14

@@ -23,13 +23,12 @@ data Derivation = Json | JS | Binary | New

23

24data ParsePort

25 = PPAnnotation String T.Type

26− | PPOut String Expr.LParseExpr

27− | PPIn String Expr.LParseExpr

26+ | PPDef String Expr.LParseExpr

28 deriving (Show)

27 deriving (Show)

29

28

30data Port

29data Port

31 = Out String Expr.LExpr T.Type

30 = Out String Expr.LExpr T.Type

32− | In String (Maybe Expr.LExpr) T.Type

31+ | In String T.Type

33 deriving (Show)

32 deriving (Show)

34

33

35type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

34type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

@@ -101,21 +100,15 @@ instance Pretty ParsePort where

101 pretty port =

100 pretty port =

102 case port of

101 case port of

103 PPAnnotation name tipe -> prettyPort name ":" tipe

102 PPAnnotation name tipe -> prettyPort name ":" tipe

104− PPOut name expr -> prettyPort name "<-" expr

105− PPIn name expr -> prettyPort name "->" expr

103+ PPDef name expr -> prettyPort name "=" expr

106

104

107instance Pretty Port where

105instance Pretty Port where

108 pretty port =

106 pretty port =

109 case port of

107 case port of

110− Out name expr tipe -> mkPort "<-" name expr tipe

111− In name mexpr tipe ->

112− case mexpr of

113− Nothing -> prettyPort name ":" tipe

108+ In name tipe -> prettyPort name ":" tipe

114− Just expr -> mkPort "->" name expr tipe

115− where

116− mkPort arrow name expr tipe =

117− P.vcat [ prettyPort name ":" tipe

109+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe

118− , prettyPort name arrow expr ]

110+ , prettyPort name "=" expr ]

111+

119

112

120prettyPort :: (Pretty a) => String -> String -> a -> Doc

113prettyPort :: (Pretty a) => String -> String -> a -> Doc

121prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

114prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

compiler/SourceSyntax/Expression.hs+46−22

@@ -1,5 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Expression where

3+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.

4+The first is the fully general version and is labeled with a prime (Expr').

5+The others are specialized versions of the AST that represent specific phases

6+of the compilation process. I expect there to be more phases as we begin to

7+enrich the AST with more information.

8+-}

9+

3

10

4import SourceSyntax.PrettyPrint

11import SourceSyntax.PrettyPrint

5import Text.PrettyPrint as P

12import Text.PrettyPrint as P

@@ -8,14 +15,19 @@ import qualified SourceSyntax.Location as Location

8import qualified SourceSyntax.Pattern as Pattern

15import qualified SourceSyntax.Pattern as Pattern

9import qualified SourceSyntax.Type as SrcType

16import qualified SourceSyntax.Type as SrcType

10import qualified SourceSyntax.Literal as Literal

17import qualified SourceSyntax.Literal as Literal

11−import qualified Type.Type as Type

12

18

19+---- GENERAL AST ----

20+

13−{-| This is a located expression. -}

21+{-| This is a located expression, meaning it is tagged with info about where it

22+came from in the source code. Expr' is defined in terms of LExpr' so that the

23+location information does not need to be an extra field on every constructor.

24+-}

14type LExpr' def = Location.Located (Expr' def)

25type LExpr' def = Location.Located (Expr' def)

15

26

16−{-| This is a fully general expression. The compilation process will enrich

27+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

17−this data structure with additional information after the initial parse.

28+"type holes" that allow us to enrich the AST with additional information as we

29+move through the compilation process. The type holes let us show these

18−The type holes let us reflect these structural changes in the types.

30+structural changes in the types. The only type hole right now is:

19

31

20 def: Parsing allows two kinds of definitions (type annotations or definitions),

32 def: Parsing allows two kinds of definitions (type annotations or definitions),

21 but later checks will see that they are well formed and combine them.

33 but later checks will see that they are well formed and combine them.

@@ -40,28 +52,37 @@ data Expr' def

40 | Record [(String, LExpr' def)]

52 | Record [(String, LExpr' def)]

41 | Markdown String String [LExpr' def]

53 | Markdown String String [LExpr' def]

42 -- for type checking and code gen only

54 -- for type checking and code gen only

43− | PortIn String SrcType.Type Type.Variable (Maybe (LExpr' def))

55+ | PortIn String SrcType.Type

44 | PortOut String SrcType.Type (LExpr' def)

56 | PortOut String SrcType.Type (LExpr' def)

45

57

58+

59+---- SPECIALIZED ASTs ----

60+

61+{-| Expressions created by the parser. These use a split representation of type

62+annotations and definitions, which is how they appear in source code and how

63+they are parsed.

64+-}

46type ParseExpr = Expr' ParseDef

65type ParseExpr = Expr' ParseDef

47type LParseExpr = LExpr' ParseDef

66type LParseExpr = LExpr' ParseDef

48−type LExpr = LExpr' Def

49−type Expr = Expr' Def

50

67

51−{-| Style of definitions as they are parsed. Users specify them

52−separately, and other checks will make sure they can be combined.

53−-}

54data ParseDef

68data ParseDef

55 = Def Pattern.Pattern LParseExpr

69 = Def Pattern.Pattern LParseExpr

56 | TypeAnnotation String SrcType.Type

70 | TypeAnnotation String SrcType.Type

57 deriving (Show)

71 deriving (Show)

58

72

59−{-| After checking that type annotations and definitions are all

73+{-| "Normal" expressions. When the compiler checks that type annotations and

60−valid, they can be combined.

74+ports are all paired with definitions in the appropriate order, it collapses

75+them into a Def that is easier to work with in later phases of compilation.

61-}

76-}

77+type LExpr = LExpr' Def

78+type Expr = Expr' Def

79+

62−data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)

80+data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)

63 deriving (Show)

81 deriving (Show)

64

82

83+

84+---- UTILITIES ----

85+

65tuple :: [LExpr' def] -> Expr' def

86tuple :: [LExpr' def] -> Expr' def

66tuple es = Data ("_Tuple" ++ show (length es)) es

87tuple es = Data ("_Tuple" ++ show (length es)) es

67

88

@@ -90,8 +111,10 @@ instance Pretty def => Pretty (Expr' def) where

90 P.text "-" <> prettyParens e

111 P.text "-" <> prettyParens e

91 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

112 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

92 where op' = if Help.isOp op then op else "`" ++ op ++ "`"

113 where op' = if Help.isOp op then op else "`" ++ op ++ "`"

114+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

115+ where

93− Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)

116+ (ps,body) = collectLambdas (Location.none $ Lambda p e)

94− in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body

117+ args = P.sep (map Pattern.prettyParens ps)

95 App _ _ -> P.hang func 2 (P.sep args)

118 App _ _ -> P.hang func 2 (P.sep args)

96 where func:args = map prettyParens (collectApps (Location.none expr))

119 where func:args = map prettyParens (collectApps (Location.none expr))

97 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

120 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

@@ -107,7 +130,9 @@ instance Pretty def => Pretty (Expr' def) where

107 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

130 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

108 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

131 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

109 Data "[]" [] -> P.text "[]"

132 Data "[]" [] -> P.text "[]"

133+ Data name es

134+ | Help.isTuple name -> P.parens (commaCat (map pretty es))

110− Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

135+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

111 Access e x -> prettyParens e <> P.text "." <> variable x

136 Access e x -> prettyParens e <> P.text "." <> variable x

112 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

137 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

113 Insert (Location.L _ (Remove e y)) x v ->

138 Insert (Location.L _ (Remove e y)) x v ->

@@ -129,7 +154,7 @@ instance Pretty def => Pretty (Expr' def) where

129

154

130 Markdown _ _ _ -> P.text "[markdown| ... |]"

155 Markdown _ _ _ -> P.text "[markdown| ... |]"

131

156

132− PortIn _ _ _ _ -> P.text "<port in>"

157+ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

133

158

134 PortOut _ _ signal -> pretty signal

159 PortOut _ _ signal -> pretty signal

135

160

@@ -156,12 +181,11 @@ collectApps lexpr@(Location.L _ expr) =

156 App a b -> collectApps a ++ [b]

181 App a b -> collectApps a ++ [b]

157 _ -> [lexpr]

182 _ -> [lexpr]

158

183

159−collectLambdas :: LExpr' def -> ([Doc], LExpr' def)

184+collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)

160collectLambdas lexpr@(Location.L _ expr) =

185collectLambdas lexpr@(Location.L _ expr) =

161 case expr of

186 case expr of

162− Lambda pattern body ->

187+ Lambda pattern body -> (pattern : ps, body')

163− let (ps, body') = collectLambdas body

188+ where (ps, body') = collectLambdas body

164− in (pretty pattern : ps, body')

165 _ -> ([], lexpr)

189 _ -> ([], lexpr)

166

190

167prettyParens :: (Pretty def) => LExpr' def -> Doc

191prettyParens :: (Pretty def) => LExpr' def -> Doc

compiler/SourceSyntax/Pattern.hs+3−3

@@ -1,7 +1,7 @@

1{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Pattern where

3

4−import SourceSyntax.Helpers as Help

4+import qualified SourceSyntax.Helpers as Help

5import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as PP

7import qualified Data.Set as Set

@@ -51,7 +51,7 @@ instance Pretty Pattern where

51 PData "::" _ -> True

52 _ -> False

53 PData name ps ->

54− if isTuple name then

54+ if Help.isTuple name then

55 PP.parens . commaCat $ map pretty ps

56 else hsep (PP.text name : map prettyParens ps)

57

@@ -60,6 +60,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)

60 where

61 needsThem =

62 case pattern of

63− PData name (_:_) | not (isTuple name) -> True

63+ PData name (_:_) | not (Help.isTuple name) -> True

64 PAlias _ _ -> True

65 _ -> False

compiler/SourceSyntax/Type.hs+10−6

@@ -1,4 +1,4 @@

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2module SourceSyntax.Type where

3

4import Data.Binary

@@ -32,7 +32,12 @@ instance Pretty Type where

32 pretty tipe =

33 case tipe of

34 Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

35+ where

35− where t:ts = collectLambdas tipe

36+ t:ts = map prettyLambda (collectLambdas tipe)

37+ prettyLambda t = case t of

38+ Lambda _ _ -> P.parens (pretty t)

39+ _ -> pretty t

40+

36 Var x -> P.text x

41 Var x -> P.text x

37 Data "_List" [t] -> P.brackets (pretty t)

42 Data "_List" [t] -> P.brackets (pretty t)

38 Data name tipes

43 Data name tipes

@@ -46,12 +51,11 @@ instance Pretty Type where

46 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

51 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

47 prettyFields = commaSep . map prettyField $ fields

52 prettyFields = commaSep . map prettyField $ fields

48

53

49−collectLambdas :: Type -> [Doc]

54+collectLambdas :: Type -> [Type]

50collectLambdas tipe =

55collectLambdas tipe =

51 case tipe of

56 case tipe of

52− Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

53− Lambda arg body -> pretty arg : collectLambdas body

57+ Lambda arg body -> arg : collectLambdas body

54− _ -> [pretty tipe]

58+ _ -> [tipe]

55

59

56prettyParens :: Type -> Doc

60prettyParens :: Type -> Doc

57prettyParens tipe = parensIf needed (pretty tipe)

61prettyParens tipe = parensIf needed (pretty tipe)

compiler/Transform/Canonicalize.hs+3−8

@@ -4,7 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where

4import Control.Arrow ((***))

5import Control.Applicative (Applicative,(<$>),(<*>))

6import Control.Monad.Identity

7−import Data.Traversable (traverse)

7+import qualified Data.Traversable as T

8import qualified Data.Map as Map

9import qualified Data.Set as Set

10import qualified Data.List as List

@@ -150,9 +150,7 @@ rename env (L s expr) =

150 rename' (Definition p body mtipe) =

151 Definition <$> format (renamePattern env' p)

152 <*> rename env' body

153− <*> case mtipe of

154− Nothing -> return Nothing

155− Just tipe -> Just <$> renameType' env' tipe

153+ <*> T.traverse (renameType' env') mtipe

156

154

157 Var x -> Var <$> format (replace "variable" env x)

155 Var x -> Var <$> format (replace "variable" env x)

158

156

@@ -167,10 +165,7 @@ rename env (L s expr) =

167

165

168 Markdown uid md es -> Markdown uid md <$> mapM rnm es

166 Markdown uid md es -> Markdown uid md <$> mapM rnm es

169

167

170− PortIn name st tt handler ->

171− do st' <- renameType' env st

168+ PortIn name st -> PortIn name <$> renameType' env st

172− handler' <- traverse rnm handler

173− return $ PortIn name st' tt handler'

174

169

175 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

170 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

176

171

compiler/Transform/Check.hs+3−3

@@ -45,11 +45,11 @@ duplicates decls =

45 unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

46

47 (portNames, portExprs) =

48− Arrow.second Maybe.catMaybes $ unzip $

48+ Arrow.second concat $ unzip $

49 flip map [ port | D.Port port <- decls ] $ \port ->

50 case port of

51− D.Out name expr _ -> (name, Just expr)

51+ D.Out name expr _ -> (name, [expr])

52− D.In name expr _ -> (name, expr)

52+ D.In name _ -> (name, [])

53

54 getNames = Set.toList . Pattern.boundVars

55

compiler/Transform/Declaration.hs+3−8

@@ -52,17 +52,12 @@ combineAnnotations = go

52 -- combine ports

53 Port port : portRest ->

54 case port of

55− PPOut name _ -> Left (msg name)

56− PPIn name _ -> Left (msg name)

55+ PPDef name _ -> Left (msg name)

57 PPAnnotation name tipe ->

56 PPAnnotation name tipe ->

58 case portRest of

57 case portRest of

59− Port (PPOut name' expr) : rest | name == name' ->

58+ Port (PPDef name' expr) : rest | name == name' ->

60 do expr' <- exprCombineAnnotations expr

59 do expr' <- exprCombineAnnotations expr

61 (:) (Port (Out name expr' tipe)) <$> go rest

60 (:) (Port (Out name expr' tipe)) <$> go rest

62

61

63− Port (PPIn name' expr) : rest | name == name' ->

64− do expr' <- exprCombineAnnotations expr

65− (:) (Port (In name (Just expr') tipe)) <$> go rest

66−

67− _ -> (:) (Port (In name Nothing tipe)) <$> go portRest

62+ _ -> (:) (Port (In name tipe)) <$> go portRest

68

63

compiler/Transform/Expression.hs+6−8

@@ -2,16 +2,14 @@

2module Transform.Expression (crawlLet, checkPorts) where

3

4import Control.Applicative ((<$>),(<*>))

5−import Data.Traversable (traverse)

6import SourceSyntax.Expression

5import SourceSyntax.Expression

7import SourceSyntax.Location

6import SourceSyntax.Location

8import qualified SourceSyntax.Type as ST

7import qualified SourceSyntax.Type as ST

9−import qualified Type.Type as TT

10

8

11crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

9crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

12−crawlLet = crawl (\_ _ _ -> return ()) (\_ _ -> return ())

10+crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

13

11

14−checkPorts :: (String -> ST.Type -> TT.Variable -> Either a ())

12+checkPorts :: (String -> ST.Type -> Either a ())

15 -> (String -> ST.Type -> Either a ())

13 -> (String -> ST.Type -> Either a ())

16 -> LExpr

14 -> LExpr

17 -> Either a LExpr

15 -> Either a LExpr

@@ -22,7 +20,7 @@ checkPorts inCheck outCheck expr =

22 do _ <- checkPorts inCheck outCheck body

20 do _ <- checkPorts inCheck outCheck body

23 return def

21 return def

24

22

25−crawl :: (String -> ST.Type -> TT.Variable -> Either a ())

23+crawl :: (String -> ST.Type -> Either a ())

26 -> (String -> ST.Type -> Either a ())

24 -> (String -> ST.Type -> Either a ())

27 -> ([def] -> Either a [def'])

25 -> ([def] -> Either a [def'])

28 -> LExpr' def

26 -> LExpr' def

@@ -49,9 +47,9 @@ crawl portInCheck portOutCheck defsTransform = go

49 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

47 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

50 Markdown uid md es -> Markdown uid md <$> mapM go es

48 Markdown uid md es -> Markdown uid md <$> mapM go es

51 Let defs body -> Let <$> defsTransform defs <*> go body

49 Let defs body -> Let <$> defsTransform defs <*> go body

52− PortIn name st tt handler ->

50+ PortIn name st ->

53− do portInCheck name st tt

51+ do portInCheck name st

54− PortIn name st tt <$> traverse go handler

52+ return $ PortIn name st

55 PortOut name st signal ->

53 PortOut name st signal ->

56 do portOutCheck name st

54 do portOutCheck name st

57 PortOut name st <$> go signal

55 PortOut name st <$> go signal

compiler/Transform/SafeNames.hs+1−1

@@ -49,7 +49,7 @@ expression (L loc expr) =

49 Modify r fs -> Modify (f r) (map (var *** f) fs)

50 Record fs -> Record (map (var *** f) fs)

51 Markdown uid md es -> Markdown uid md (map f es)

52− PortIn name st tt handler -> PortIn name st tt (fmap f handler)

52+ PortIn name st -> PortIn name st

53 PortOut name st signal -> PortOut name st (f signal)

54

55definition :: Def -> Def

compiler/Transform/SortDefinitions.hs+1−3

@@ -3,7 +3,6 @@ module Transform.SortDefinitions (sortDefs) where

3

4import Control.Monad.State

5import Control.Applicative ((<$>),(<*>))

6−import Data.Traversable (traverse)

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8import SourceSyntax.Expression

7import SourceSyntax.Expression

9import SourceSyntax.Location

8import SourceSyntax.Location

@@ -86,8 +85,7 @@ reorder (L s expr) =

86

85

87 PortOut name st signal -> PortOut name st <$> reorder signal

86 PortOut name st signal -> PortOut name st <$> reorder signal

88

87

89− PortIn name st tt handler ->

88+ PortIn name st -> return $ PortIn name st

90− PortIn name st tt <$> traverse reorder handler

91

89

92 -- Actually do some reordering

90 -- Actually do some reordering

93 Let defs body ->

91 Let defs body ->

compiler/Transform/Substitute.hs+1−1

@@ -38,5 +38,5 @@ subst old new expr =

38 Record fs -> Record (map (second f) fs)

39 Literal _ -> expr

40 Markdown uid md es -> Markdown uid md (map f es)

41− PortIn name st tt handler -> PortIn name st tt (fmap f handler)

41+ PortIn name st -> PortIn name st

42 PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Constrain/Declaration.hs+2−10

@@ -6,8 +6,6 @@ import qualified SourceSyntax.Expression as E

6import qualified SourceSyntax.Location as L

7import qualified SourceSyntax.Pattern as P

8import qualified SourceSyntax.Type as T

9−import qualified Type.Type as Type

10−import System.IO.Unsafe

11

9

12toExpr :: [Declaration] -> [E.Def]

10toExpr :: [Declaration] -> [E.Def]

13toExpr = concatMap toDefs

11toExpr = concatMap toDefs

@@ -47,14 +45,8 @@ toDefs decl =

47 case port of

45 case port of

48 Out name expr@(L.L s _) tipe ->

46 Out name expr@(L.L s _) tipe ->

49 [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

47 [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

50− In name mexpr tipe ->

48+ In name tipe ->

51− unsafePerformIO $ do

52− tvar <- Type.var Type.Flexible

53− return $ [ definition name (loc $ E.PortIn name tipe tvar mexpr) tipe ]

49+ [ definition name (L.none $ E.PortIn name tipe) tipe ]

54− where

55− loc = case mexpr of

56− Just (L.L s _) -> L.L s

57− Nothing -> L.none

58

50

59 -- no constraints are needed for fixity declarations

51 -- no constraints are needed for fixity declarations

60 Fixity _ _ _ -> []

52 Fixity _ _ _ -> []

compiler/Type/Constrain/Expression.hs+1−5

@@ -3,7 +3,6 @@ module Type.Constrain.Expression where

3

4import qualified Data.List as List

5import qualified Data.Map as Map

6−import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

6import qualified Data.Set as Set

8import Control.Applicative ((<$>))

7import Control.Applicative ((<$>))

9import qualified Control.Monad as Monad

8import qualified Control.Monad as Monad

@@ -147,10 +146,7 @@ constrain env (L span expr) tipe =

147 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

148 (c1 /\ c))

147 (c1 /\ c))

149

148

150− PortIn _ _ tt handler ->

149+ PortIn _ _ -> return true

151− constrain env (Maybe.fromMaybe identity handler) (VarN tt)

152− where

153− identity = Loc.none $ Lambda (PVar "x") (Loc.none $ Var "x")

154

150

155 PortOut _ _ signal ->

151 PortOut _ _ signal ->

156 constrain env signal tipe

152 constrain env signal tipe

compiler/Type/ExtraChecks.hs+53−59

@@ -14,12 +14,12 @@ import qualified Type.State as TS

14import qualified Type.Alias as Alias

15import Text.PrettyPrint as P

16import SourceSyntax.PrettyPrint (pretty)

17+import qualified SourceSyntax.Helpers as Help

17import qualified SourceSyntax.Type as T

18import qualified SourceSyntax.Type as T

18import qualified SourceSyntax.Expression as E

19import qualified SourceSyntax.Expression as E

19import qualified SourceSyntax.Location as L

20import qualified SourceSyntax.Location as L

20import qualified Transform.Expression as Expr

21import qualified Transform.Expression as Expr

21import qualified Data.Traversable as Traverse

22import qualified Data.Traversable as Traverse

22−import System.IO.Unsafe

23

24throw err = Left [ P.vcat err ]

25

@@ -43,69 +43,63 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

43 , P.nest 4 . pretty $ Alias.realias rules mainType

44 , P.text " " ]

45

46+data Direction = In | Out

47+

46portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

48portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

47portTypes rules expr =

49portTypes rules expr =

48− const () <$> Expr.checkPorts checkIn checkOut expr

50+ const () <$> Expr.checkPorts (check In) (check Out) expr

49 where

51 where

50− showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

52+ check = isValid False False

51−

53+ isValid seenFunc seenSignal direction name tipe =

52− checkIn name st tt =

54+ let valid = isValid seenFunc seenSignal direction name in

53− do t <- getSignal name st

54− case unsafePerformIO (toSrcType tt) of

55− T.Lambda a b ->

56− do isJsType "coming in" name a

57− if b `elem` okayTypes then return () else throw msg

58− where

59− okayTypes = [ t

60− , T.Data "Maybe.Maybe" [t]

61− , T.Data "Either.Either" [T.Data "String.String" [], t]

62− ]

63− msg = [ P.text $ "Type Error: the handler for port '" ++ name ++

64− "' returns values of type:\n"

65− , showType b

66− , P.text $ "but the port's type annotation requires that the handler returns values"

67− , P.text $ "with one of the following types:\n"

68− ] ++ map showType okayTypes ++

69− [ P.text "If the handler returns a Maybe or Either, invalid values will cause an"

70− , P.text "error to be thrown to the JS error handler associated with this port." ]

71−

72− tipe ->

73− throw [ P.text $ "Type Error: the handler for port '" ++ name ++

74− "' must be a function!"

75− , P.text "Instead it was given a value of type:\n"

76− , showType tipe

77− ]

78−

79− checkOut name st =

80− do t <- getSignal name st

81− isJsType "sent out" name t

82−

83− getSignal name tipe =

84− case tipe of

85− T.Data "Signal.Signal" [t] -> return t

86− _ -> throw [ P.text $ "Type Error: port '" ++ name ++ "' must be a Signal,"

87− , P.text $ "but the type annotation says it has non-Signal type:\n"

88− , showType tipe

89− , P.text $ "Maybe instead you want the following type?\n"

90− , showType (T.Data "Signal.Signal" [tipe])

91− ]

92−

93− isJsType msg name tipe =

94 case tipe of

55 case tipe of

95− T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts

56+ T.Data ctor ts

96− | otherwise -> throw $ err msg "Elm values"

57+ | isJs ctor || isElm ctor -> mapM_ valid ts

58+ | ctor == "Signal.Signal" -> handleSignal ts

59+ | otherwise -> err "Algebraic Data Types"

60+

97− T.Var _ -> throw $ err msg "type variables"

61+ T.Var _ -> err "free type variables"

62+

98− T.Lambda _ _ -> throw $ err msg "Elm functions"

63+ T.Lambda _ _ ->

64+ case direction of

65+ In -> err "functions"

66+ Out | seenFunc -> err "higher-order functions"

67+ | seenSignal -> err "signals that contain functions"

68+ | otherwise ->

69+ mapM_ (isValid True seenSignal direction name) (T.collectLambdas tipe)

70+

99− T.Record _ _ -> throw $ err msg "Elm records"

71+ T.Record _ (Just _) -> err "extended records with free type variables"

72+

73+ T.Record fields Nothing ->

74+ mapM_ (\(k,v) -> (,) k <$> valid v) fields

75+

100 where

76 where

77+ isJs ctor =

101− okay ctor = and [ List.isPrefixOf "JavaScript." ctor

78+ List.isPrefixOf "JavaScript." ctor

102− , 1 == length (filter (=='.') ctor) ]

79+ && length (filter (=='.') ctor) == 1

103−

80+

104− err msg kind =

81+ isElm ctor =

82+ ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]

83+ || Help.isTuple ctor

84+

85+ handleSignal ts

86+ | seenFunc = err "functions that involve signals"

87+ | seenSignal = err "signals-of-signals"

88+ | otherwise = mapM_ (isValid seenFunc True direction name) ts

89+

90+ dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

91+ txt = P.text . concat

92+

93+ err kind =

94+ throw $

95+ [ txt [ "Type Error: the value ", dir "coming in" "sent out"

105− [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++

96+ , " through port '", name, "' is invalid." ]

97+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"

106− "' must be JavaScript values."

98+ , " ports include JavaScript values and the following Elm values:" ]

99+ , txt [ "Ints, Floats, Bools, Strings, Maybes, Lists, Tuples, "

100+ , dir "" "first-order functions, ", "and concrete records." ]

107− , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"

101+ , txt [ "The values sent through this port contain ", kind, ":\n" ]

108− , showType tipe

102+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

109 ]

103 ]

110

104

111occurs :: (String, Variable) -> StateT TS.SolverState IO ()

105occurs :: (String, Variable) -> StateT TS.SolverState IO ()

libraries/Native/Ports.js+46−42

@@ -6,62 +6,66 @@ Elm.Native.Ports.make = function(elm) {

6

7 var Signal = Elm.Signal.make(elm);

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+ try {

31− if (typeof result === 'string') {

52+ return converter(value);

53+ } catch(e) {

32− throw new Error("Initialization Error: The default value for port '" +

54+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

33− name + "' is invalid.\n" + result);

34 }

55 }

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 }

56 }

46− function portOut(name, signal) {

57+ function portOut(name, converter, value) {

47− var subscribers = []

58+ try {

48− function subscribe(handler) {

59+ elm.ports.outgoing[name] = converter(value);

49− subscribers.push(handler);

60+ } catch(e) {

61+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

50 }

62 }

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;

63+ return value;

62 }

64 }

63

65

64 return elm.Native.Ports.values = {

66 return elm.Native.Ports.values = {

67+ incomingSignal: incomingSignal,

68+ outgoingSignal: outgoingSignal,

65 portOut: portOut,

69 portOut: portOut,

66 portIn: portIn

70 portIn: portIn

67 };

71 };

runtime/Init.js+16−7

@@ -27,7 +27,7 @@ Elm.worker = function(module, ports) {

27 return init(ElmRuntime.Display.NONE, {}, module, ports || {});

28};

29

30−Elm.input = function(defaultValue, errorHandler) {

30+Elm.signal = function(defaultValue, errorHandler) {

31 var subscribers = []

32 function subscribe(handler) {

33 subscribers.push(handler);

@@ -133,7 +133,7 @@ function init(display, container, module, ports, moduleToReplace) {

133 }

134

135 reportAnyErrors();

136− return { swap:swap, output:elm.ports.outgoing };

136+ return { swap:swap, ports:elm.ports.outgoing };

137};

138

139function checkPorts(elm) {

@@ -142,8 +142,9 @@ function checkPorts(elm) {

142 var uses = portUses[key]

143 if (uses === 0) {

144 throw new Error(

145− "Initialization Error: there is no port named '" + key + "'.\n" +

145+ "Initialization Error: provided port '" + key +

146+ "' to a module that does not take it as in input.\n" +

146− "You should probably remove that input from your initialization code.");

147+ "Remove '" + key + "' from the module initialization code.");

147 } else if (uses > 1) {

148 } else if (uses > 1) {

148 throw new Error(

149 throw new Error(

149 "Initialization Error: port '" + key +

150 "Initialization Error: port '" + key +

@@ -179,17 +180,25 @@ function addReceivers(ports) {

179 ports.log.subscribe(function(v) { console.log(v) });

180 ports.log.subscribe(function(v) { console.log(v) });

180 }

181 }

181 if ('stdout' in ports) {

182 if ('stdout' in ports) {

183+ var process = process || {};

184+ var handler = process.stdout

182− var handler = process ? function(v) { process.stdout.write(v); }

185+ ? function(v) { process.stdout.write(v); }

183 : function(v) { console.log(v); };

186 : function(v) { console.log(v); };

184 ports.stdout.subscribe(handler);

187 ports.stdout.subscribe(handler);

185 }

188 }

186 if ('stderr' in ports) {

189 if ('stderr' in ports) {

190+ var process = process || {};

191+ var handler = process.stderr

187− var handler = process ? function(v) { process.stderr.write(v); }

192+ ? function(v) { process.stderr.write(v); }

188 : function(v) { console.log('Error:' + v); };

193 : function(v) { console.log('Error:' + v); };

189 ports.stderr.subscribe(handler);

194 ports.stderr.subscribe(handler);

190 }

195 }

191 if ('title' in ports) {

196 if ('title' in ports) {

197+ if (typeof ports.title === 'string') {

198+ document.title = ports.title;

199+ } else {

192− ports.title.subscribe(function(v) { document.title = v; });

200+ ports.title.subscribe(function(v) { document.title = v; });

201+ }

193 }

202 }

194 if ('redirect' in ports) {

203 if ('redirect' in ports) {

195 ports.redirect.subscribe(function(v) {

204 ports.redirect.subscribe(function(v) {