git.iko.soy/elk
on master help sign in
Merge remote-tracking branch 'evan/dev' into arbitary-tipe
commit1b44fbf24ada9c4a50c15cac844113efcf6e002c authorJohn P Mayer Jr <john.p.mayer.jr@gmail.com> dateTue 14 Jan 2014, 12:27 (13 years ago) parentc616557c602071
21 files changed+393−241
compare with master
unifiedsplit
Elm.cabal+4 compiler/Generate/JavaScript.hs+18−38 compiler/Generate/JavaScript/Helpers.hs+37 compiler/Generate/JavaScript/Ports.hs+130 compiler/Parse/Declaration.hs+2−3 compiler/SourceSyntax/Declaration.hs+7−14 compiler/SourceSyntax/Expression.hs+46−22 compiler/SourceSyntax/Pattern.hs+3−3 compiler/SourceSyntax/Type.hs+10−6 compiler/Transform/Canonicalize.hs+3−8 compiler/Transform/Check.hs+3−3 compiler/Transform/Declaration.hs+3−8 compiler/Transform/Expression.hs+6−8 compiler/Transform/SafeNames.hs+1−1 compiler/Transform/SortDefinitions.hs+1−3 compiler/Transform/Substitute.hs+1−1 compiler/Type/Constrain/Declaration.hs+2−10 compiler/Type/Constrain/Expression.hs+1−5 compiler/Type/ExtraChecks.hs+53−59 libraries/Native/Ports.js+46−42 runtime/Init.js+16−7
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+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 =
5959 name <- lowVar
6060 whitespace
6161 let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
62− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
63− , port' (string "<-") D.PPOut Expr.expr
64− , port' (string "->") D.PPIn Expr.expr ]
62+ D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
63+ , port' equals D.PPDef Expr.expr ]
compiler/SourceSyntax/Declaration.hs+7−14
@@ -23,13 +23,12 @@ data Derivation = Json | JS | Binary | New
2323
2424data ParsePort
2525 = PPAnnotation String T.Type
26− | PPOut String Expr.LParseExpr
27− | PPIn String Expr.LParseExpr
26+ | PPDef String Expr.LParseExpr
2827 deriving (Show)
2928
3029data Port
3130 = Out String Expr.LExpr T.Type
32− | In String (Maybe Expr.LExpr) T.Type
31+ | In String T.Type
3332 deriving (Show)
3433
3534type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
@@ -101,21 +100,15 @@ instance Pretty ParsePort where
101100 pretty port =
102101 case port of
103102 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
106104
107105instance Pretty Port where
108106 pretty port =
109107 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
114− Just expr -> mkPort "->" name expr tipe
115− where
116− mkPort arrow name expr tipe =
117− P.vcat [ prettyPort name ":" tipe
118− , prettyPort name arrow expr ]
108+ In name tipe -> prettyPort name ":" tipe
109+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe
110+ , prettyPort name "=" expr ]
111+
119112
120113prettyPort :: (Pretty a) => String -> String -> a -> Doc
121114prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
compiler/SourceSyntax/Expression.hs+46−22
@@ -1,5 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
22module 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+
310
411import SourceSyntax.PrettyPrint
512import Text.PrettyPrint as P
@@ -8,14 +15,19 @@ import qualified SourceSyntax.Location as Location
815import qualified SourceSyntax.Pattern as Pattern
916import qualified SourceSyntax.Type as SrcType
1017import qualified SourceSyntax.Literal as Literal
11−import qualified Type.Type as Type
1218
13−{-| This is a located expression. -}
19+---- GENERAL AST ----
20+
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+-}
1425type LExpr' def = Location.Located (Expr' def)
1526
16−{-| This is a fully general expression. The compilation process will enrich
17−this data structure with additional information after the initial parse.
18−The type holes let us reflect these structural changes in the types.
27+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
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
30+structural changes in the types. The only type hole right now is:
1931
2032 def: Parsing allows two kinds of definitions (type annotations or definitions),
2133 but later checks will see that they are well formed and combine them.
@@ -40,28 +52,37 @@ data Expr' def
4052 | Record [(String, LExpr' def)]
4153 | Markdown String String [LExpr' def]
4254 -- for type checking and code gen only
43− | PortIn String SrcType.Type Type.Variable (Maybe (LExpr' def))
55+ | PortIn String SrcType.Type
4456 | PortOut String SrcType.Type (LExpr' def)
4557
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+-}
4665type ParseExpr = Expr' ParseDef
4766type LParseExpr = LExpr' ParseDef
48−type LExpr = LExpr' Def
49−type Expr = Expr' Def
5067
51−{-| Style of definitions as they are parsed. Users specify them
52−separately, and other checks will make sure they can be combined.
53−-}
5468data ParseDef
5569 = Def Pattern.Pattern LParseExpr
5670 | TypeAnnotation String SrcType.Type
5771 deriving (Show)
5872
59−{-| After checking that type annotations and definitions are all
60−valid, they can be combined.
73+{-| "Normal" expressions. When the compiler checks that type annotations and
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.
6176-}
62−data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
77+type LExpr = LExpr' Def
78+type Expr = Expr' Def
79+
80+data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
6381 deriving (Show)
6482
83+
84+---- UTILITIES ----
85+
6586tuple :: [LExpr' def] -> Expr' def
6687tuple es = Data ("_Tuple" ++ show (length es)) es
6788
@@ -90,8 +111,10 @@ instance Pretty def => Pretty (Expr' def) where
90111 P.text "-" <> prettyParens e
91112 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
92113 where op' = if Help.isOp op then op else "`" ++ op ++ "`"
93− Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
94− in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
114+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
115+ where
116+ (ps,body) = collectLambdas (Location.none $ Lambda p e)
117+ args = P.sep (map Pattern.prettyParens ps)
95118 App _ _ -> P.hang func 2 (P.sep args)
96119 where func:args = map prettyParens (collectApps (Location.none expr))
97120 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
@@ -107,7 +130,9 @@ instance Pretty def => Pretty (Expr' def) where
107130 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
108131 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
109132 Data "[]" [] -> P.text "[]"
110− Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
133+ Data name es
134+ | Help.isTuple name -> P.parens (commaCat (map pretty es))
135+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
111136 Access e x -> prettyParens e <> P.text "." <> variable x
112137 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
113138 Insert (Location.L _ (Remove e y)) x v ->
@@ -129,7 +154,7 @@ instance Pretty def => Pretty (Expr' def) where
129154
130155 Markdown _ _ _ -> P.text "[markdown| ... |]"
131156
132− PortIn _ _ _ _ -> P.text "<port in>"
157+ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
133158
134159 PortOut _ _ signal -> pretty signal
135160
@@ -156,12 +181,11 @@ collectApps lexpr@(Location.L _ expr) =
156181 App a b -> collectApps a ++ [b]
157182 _ -> [lexpr]
158183
159−collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
184+collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
160185collectLambdas lexpr@(Location.L _ expr) =
161186 case expr of
162− Lambda pattern body ->
163− let (ps, body') = collectLambdas body
164− in (pretty pattern : ps, body')
187+ Lambda pattern body -> (pattern : ps, body')
188+ where (ps, body') = collectLambdas body
165189 _ -> ([], lexpr)
166190
167191prettyParens :: (Pretty def) => LExpr' def -> Doc
compiler/SourceSyntax/Pattern.hs+3−3
@@ -1,7 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22module SourceSyntax.Pattern where
33
4−import SourceSyntax.Helpers as Help
4+import qualified SourceSyntax.Helpers as Help
55import SourceSyntax.PrettyPrint
66import Text.PrettyPrint as PP
77import qualified Data.Set as Set
@@ -51,7 +51,7 @@ instance Pretty Pattern where
5151 PData "::" _ -> True
5252 _ -> False
5353 PData name ps ->
54− if isTuple name then
54+ if Help.isTuple name then
5555 PP.parens . commaCat $ map pretty ps
5656 else hsep (PP.text name : map prettyParens ps)
5757
@@ -60,6 +60,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
6060 where
6161 needsThem =
6262 case pattern of
63− PData name (_:_) | not (isTuple name) -> True
63+ PData name (_:_) | not (Help.isTuple name) -> True
6464 PAlias _ _ -> True
6565 _ -> False
compiler/SourceSyntax/Type.hs+10−6
@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# OPTIONS_GHC -W #-}
22module SourceSyntax.Type where
33
44import Data.Binary
@@ -32,7 +32,12 @@ instance Pretty Type where
3232 pretty tipe =
3333 case tipe of
3434 Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
35− where t:ts = collectLambdas tipe
35+ where
36+ t:ts = map prettyLambda (collectLambdas tipe)
37+ prettyLambda t = case t of
38+ Lambda _ _ -> P.parens (pretty t)
39+ _ -> pretty t
40+
3641 Var x -> P.text x
3742 Data "_List" [t] -> P.brackets (pretty t)
3843 Data name tipes
@@ -46,12 +51,11 @@ instance Pretty Type where
4651 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
4752 prettyFields = commaSep . map prettyField $ fields
4853
49−collectLambdas :: Type -> [Doc]
54+collectLambdas :: Type -> [Type]
5055collectLambdas tipe =
5156 case tipe of
52− Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body
53− Lambda arg body -> pretty arg : collectLambdas body
54− _ -> [pretty tipe]
57+ Lambda arg body -> arg : collectLambdas body
58+ _ -> [tipe]
5559
5660prettyParens :: Type -> Doc
5761prettyParens tipe = parensIf needed (pretty tipe)
compiler/Transform/Canonicalize.hs+3−8
@@ -4,7 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where
44import Control.Arrow ((***))
55import Control.Applicative (Applicative,(<$>),(<*>))
66import Control.Monad.Identity
7−import Data.Traversable (traverse)
7+import qualified Data.Traversable as T
88import qualified Data.Map as Map
99import qualified Data.Set as Set
1010import qualified Data.List as List
@@ -150,9 +150,7 @@ rename env (L s expr) =
150150 rename' (Definition p body mtipe) =
151151 Definition <$> format (renamePattern env' p)
152152 <*> rename env' body
153− <*> case mtipe of
154− Nothing -> return Nothing
155− Just tipe -> Just <$> renameType' env' tipe
153+ <*> T.traverse (renameType' env') mtipe
156154
157155 Var x -> Var <$> format (replace "variable" env x)
158156
@@ -167,10 +165,7 @@ rename env (L s expr) =
167165
168166 Markdown uid md es -> Markdown uid md <$> mapM rnm es
169167
170− PortIn name st tt handler ->
171− do st' <- renameType' env st
172− handler' <- traverse rnm handler
173− return $ PortIn name st' tt handler'
168+ PortIn name st -> PortIn name <$> renameType' env st
174169
175170 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
176171
compiler/Transform/Check.hs+3−3
@@ -45,11 +45,11 @@ duplicates decls =
4545 unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
4646
4747 (portNames, portExprs) =
48− Arrow.second Maybe.catMaybes $ unzip $
48+ Arrow.second concat $ unzip $
4949 flip map [ port | D.Port port <- decls ] $ \port ->
5050 case port of
51− D.Out name expr _ -> (name, Just expr)
52− D.In name expr _ -> (name, expr)
51+ D.Out name expr _ -> (name, [expr])
52+ D.In name _ -> (name, [])
5353
5454 getNames = Set.toList . Pattern.boundVars
5555
compiler/Transform/Declaration.hs+3−8
@@ -52,17 +52,12 @@ combineAnnotations = go
5252 -- combine ports
5353 Port port : portRest ->
5454 case port of
55− PPOut name _ -> Left (msg name)
56− PPIn name _ -> Left (msg name)
55+ PPDef name _ -> Left (msg name)
5756 PPAnnotation name tipe ->
5857 case portRest of
59− Port (PPOut name' expr) : rest | name == name' ->
58+ Port (PPDef name' expr) : rest | name == name' ->
6059 do expr' <- exprCombineAnnotations expr
6160 (:) (Port (Out name expr' tipe)) <$> go rest
6261
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
6863
compiler/Transform/Expression.hs+6−8
@@ -2,16 +2,14 @@
22module Transform.Expression (crawlLet, checkPorts) where
33
44import Control.Applicative ((<$>),(<*>))
5−import Data.Traversable (traverse)
65import SourceSyntax.Expression
76import SourceSyntax.Location
87import qualified SourceSyntax.Type as ST
9−import qualified Type.Type as TT
108
119crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
12−crawlLet = crawl (\_ _ _ -> return ()) (\_ _ -> return ())
10+crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
1311
14−checkPorts :: (String -> ST.Type -> TT.Variable -> Either a ())
12+checkPorts :: (String -> ST.Type -> Either a ())
1513 -> (String -> ST.Type -> Either a ())
1614 -> LExpr
1715 -> Either a LExpr
@@ -22,7 +20,7 @@ checkPorts inCheck outCheck expr =
2220 do _ <- checkPorts inCheck outCheck body
2321 return def
2422
25−crawl :: (String -> ST.Type -> TT.Variable -> Either a ())
23+crawl :: (String -> ST.Type -> Either a ())
2624 -> (String -> ST.Type -> Either a ())
2725 -> ([def] -> Either a [def'])
2826 -> LExpr' def
@@ -49,9 +47,9 @@ crawl portInCheck portOutCheck defsTransform = go
4947 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
5048 Markdown uid md es -> Markdown uid md <$> mapM go es
5149 Let defs body -> Let <$> defsTransform defs <*> go body
52− PortIn name st tt handler ->
53− do portInCheck name st tt
54− PortIn name st tt <$> traverse go handler
50+ PortIn name st ->
51+ do portInCheck name st
52+ return $ PortIn name st
5553 PortOut name st signal ->
5654 do portOutCheck name st
5755 PortOut name st <$> go signal
compiler/Transform/SafeNames.hs+1−1
@@ -49,7 +49,7 @@ expression (L loc expr) =
4949 Modify r fs -> Modify (f r) (map (var *** f) fs)
5050 Record fs -> Record (map (var *** f) fs)
5151 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
5353 PortOut name st signal -> PortOut name st (f signal)
5454
5555definition :: Def -> Def
compiler/Transform/SortDefinitions.hs+1−3
@@ -3,7 +3,6 @@ module Transform.SortDefinitions (sortDefs) where
33
44import Control.Monad.State
55import Control.Applicative ((<$>),(<*>))
6−import Data.Traversable (traverse)
76import qualified Data.Map as Map
87import SourceSyntax.Expression
98import SourceSyntax.Location
@@ -86,8 +85,7 @@ reorder (L s expr) =
8685
8786 PortOut name st signal -> PortOut name st <$> reorder signal
8887
89− PortIn name st tt handler ->
90− PortIn name st tt <$> traverse reorder handler
88+ PortIn name st -> return $ PortIn name st
9189
9290 -- Actually do some reordering
9391 Let defs body ->
compiler/Transform/Substitute.hs+1−1
@@ -38,5 +38,5 @@ subst old new expr =
3838 Record fs -> Record (map (second f) fs)
3939 Literal _ -> expr
4040 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
4242 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
66import qualified SourceSyntax.Location as L
77import qualified SourceSyntax.Pattern as P
88import qualified SourceSyntax.Type as T
9−import qualified Type.Type as Type
10−import System.IO.Unsafe
119
1210toExpr :: [Declaration] -> [E.Def]
1311toExpr = concatMap toDefs
@@ -47,14 +45,8 @@ toDefs decl =
4745 case port of
4846 Out name expr@(L.L s _) tipe ->
4947 [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
50− In name mexpr tipe ->
51− unsafePerformIO $ do
52− tvar <- Type.var Type.Flexible
53− return $ [ definition name (loc $ E.PortIn name tipe tvar mexpr) tipe ]
54− where
55− loc = case mexpr of
56− Just (L.L s _) -> L.L s
57− Nothing -> L.none
48+ In name tipe ->
49+ [ definition name (L.none $ E.PortIn name tipe) tipe ]
5850
5951 -- no constraints are needed for fixity declarations
6052 Fixity _ _ _ -> []
compiler/Type/Constrain/Expression.hs+1−5
@@ -3,7 +3,6 @@ module Type.Constrain.Expression where
33
44import qualified Data.List as List
55import qualified Data.Map as Map
6−import qualified Data.Maybe as Maybe
76import qualified Data.Set as Set
87import Control.Applicative ((<$>))
98import qualified Control.Monad as Monad
@@ -147,10 +146,7 @@ constrain env (L span expr) tipe =
147146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
148147 (c1 /\ c))
149148
150− PortIn _ _ tt handler ->
151− constrain env (Maybe.fromMaybe identity handler) (VarN tt)
152− where
153− identity = Loc.none $ Lambda (PVar "x") (Loc.none $ Var "x")
149+ PortIn _ _ -> return true
154150
155151 PortOut _ _ signal ->
156152 constrain env signal tipe
compiler/Type/ExtraChecks.hs+53−59
@@ -14,12 +14,12 @@ import qualified Type.State as TS
1414import qualified Type.Alias as Alias
1515import Text.PrettyPrint as P
1616import SourceSyntax.PrettyPrint (pretty)
17+import qualified SourceSyntax.Helpers as Help
1718import qualified SourceSyntax.Type as T
1819import qualified SourceSyntax.Expression as E
1920import qualified SourceSyntax.Location as L
2021import qualified Transform.Expression as Expr
2122import qualified Data.Traversable as Traverse
22−import System.IO.Unsafe
2323
2424throw err = Left [ P.vcat err ]
2525
@@ -43,69 +43,63 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
4343 , P.nest 4 . pretty $ Alias.realias rules mainType
4444 , P.text " " ]
4545
46+data Direction = In | Out
47+
4648portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
4749portTypes rules expr =
48− const () <$> Expr.checkPorts checkIn checkOut expr
50+ const () <$> Expr.checkPorts (check In) (check Out) expr
4951 where
50− showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
51−
52− checkIn name st tt =
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 =
52+ check = isValid False False
53+ isValid seenFunc seenSignal direction name tipe =
54+ let valid = isValid seenFunc seenSignal direction name in
9455 case tipe of
95− T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts
96− | otherwise -> throw $ err msg "Elm values"
97− T.Var _ -> throw $ err msg "type variables"
98− T.Lambda _ _ -> throw $ err msg "Elm functions"
99− T.Record _ _ -> throw $ err msg "Elm records"
56+ T.Data ctor ts
57+ | isJs ctor || isElm ctor -> mapM_ valid ts
58+ | ctor == "Signal.Signal" -> handleSignal ts
59+ | otherwise -> err "Algebraic Data Types"
60+
61+ T.Var _ -> err "free type variables"
62+
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+
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+
10076 where
101− okay ctor = and [ List.isPrefixOf "JavaScript." ctor
102− , 1 == length (filter (=='.') ctor) ]
103−
104− err msg kind =
105− [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++
106− "' must be JavaScript values."
107− , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"
108− , showType tipe
77+ isJs ctor =
78+ List.isPrefixOf "JavaScript." ctor
79+ && length (filter (=='.') ctor) == 1
80+
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"
96+ , " through port '", name, "' is invalid." ]
97+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"
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." ]
101+ , txt [ "The values sent through this port contain ", kind, ":\n" ]
102+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
109103 ]
110104
111105occurs :: (String, Variable) -> StateT TS.SolverState IO ()
libraries/Native/Ports.js+46−42
@@ -6,62 +6,66 @@ 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);
51+ try {
52+ return converter(value);
53+ } catch(e) {
54+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);
3455 }
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;
4556 }
46− function portOut(name, signal) {
47− var subscribers = []
48− function subscribe(handler) {
49− subscribers.push(handler);
57+ function portOut(name, converter, value) {
58+ try {
59+ elm.ports.outgoing[name] = converter(value);
60+ } catch(e) {
61+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);
5062 }
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;
6264 }
6365
6466 return elm.Native.Ports.values = {
67+ incomingSignal: incomingSignal,
68+ outgoingSignal: outgoingSignal,
6569 portOut: portOut,
6670 portIn: portIn
6771 };
runtime/Init.js+16−7
@@ -27,7 +27,7 @@ Elm.worker = function(module, ports) {
2727 return init(ElmRuntime.Display.NONE, {}, module, ports || {});
2828};
2929
30−Elm.input = function(defaultValue, errorHandler) {
30+Elm.signal = function(defaultValue, errorHandler) {
3131 var subscribers = []
3232 function subscribe(handler) {
3333 subscribers.push(handler);
@@ -133,7 +133,7 @@ function init(display, container, module, ports, moduleToReplace) {
133133 }
134134
135135 reportAnyErrors();
136− return { swap:swap, output:elm.ports.outgoing };
136+ return { swap:swap, ports:elm.ports.outgoing };
137137};
138138
139139function checkPorts(elm) {
@@ -142,8 +142,9 @@ function checkPorts(elm) {
142142 var uses = portUses[key]
143143 if (uses === 0) {
144144 throw new Error(
145− "Initialization Error: there is no port named '" + key + "'.\n" +
146− "You should probably remove that input from your initialization code.");
145+ "Initialization Error: provided port '" + key +
146+ "' to a module that does not take it as in input.\n" +
147+ "Remove '" + key + "' from the module initialization code.");
147148 } else if (uses > 1) {
148149 throw new Error(
149150 "Initialization Error: port '" + key +
@@ -179,17 +180,25 @@ function addReceivers(ports) {
179180 ports.log.subscribe(function(v) { console.log(v) });
180181 }
181182 if ('stdout' in ports) {
182− var handler = process ? function(v) { process.stdout.write(v); }
183+ var process = process || {};
184+ var handler = process.stdout
185+ ? function(v) { process.stdout.write(v); }
183186 : function(v) { console.log(v); };
184187 ports.stdout.subscribe(handler);
185188 }
186189 if ('stderr' in ports) {
187− var handler = process ? function(v) { process.stderr.write(v); }
190+ var process = process || {};
191+ var handler = process.stderr
192+ ? function(v) { process.stderr.write(v); }
188193 : function(v) { console.log('Error:' + v); };
189194 ports.stderr.subscribe(handler);
190195 }
191196 if ('title' in ports) {
192− ports.title.subscribe(function(v) { document.title = v; });
197+ if (typeof ports.title === 'string') {
198+ document.title = ports.title;
199+ } else {
200+ ports.title.subscribe(function(v) { document.title = v; });
201+ }
193202 }
194203 if ('redirect' in ports) {
195204 ports.redirect.subscribe(function(v) {