git.iko.soy/elk
on master help sign in
Add guarded definitions. Add whitespace sensitivity for let- and case-expressions.
2eeac2fevancz
core-js/Prelude.js+1
compare with master
unifiedsplit
@@ -75,6 +75,7 @@ Elm.Prelude = function() {
75 snd : function(p) { return p[2]; },
75 snd : function(p) { return p[2]; },
76 rem : function(x) { return function(y) { return x % y; }; },
76 rem : function(x) { return function(y) { return x % y; }; },
77 div : function(x) { return function(y) { return ~~(x / y); }; },
77 div : function(x) { return function(y) { return ~~(x / y); }; },
78+ otherwise : true,
78 compare : function(x) { return function (y) {
79 compare : function(x) { return function (y) {
79 x = (typeof x === "object") ? toText(x) : x;
80 x = (typeof x === "object") ? toText(x) : x;
80 y = (typeof y === "object") ? toText(y) : y;
81 y = (typeof y === "object") ? toText(y) : y;
elm/Elm.cabal+4−2
@@ -71,7 +71,8 @@ Library
71 shakespeare >= 1,
71 shakespeare >= 1,
72 pandoc <= 1.9.4.2,
72 pandoc <= 1.9.4.2,
73 bytestring,
73 bytestring,
74− hjsmin
74+ hjsmin,
75+ indents
75
76
76Executable elm
77Executable elm
77 Main-is: Compiler.hs
78 Main-is: Compiler.hs
@@ -112,4 +113,5 @@ Executable elm
112 cmdargs,
113 cmdargs,
113 pandoc <= 1.9.4.2,
114 pandoc <= 1.9.4.2,
114 bytestring,
115 bytestring,
115− hjsmin
116+ hjsmin,
117+ indents
elm/src/Ast.hs+2−1
@@ -4,7 +4,6 @@ module Ast where
4import Data.Char (isDigit)
4import Data.Char (isDigit)
5import Data.List (intercalate)
5import Data.List (intercalate)
6import Types.Types
6import Types.Types
7−import Guid
8import qualified Text.Pandoc as Pandoc
7import qualified Text.Pandoc as Pandoc
9
8
10data Module = Module [String] Exports Imports [Statement]
9data Module = Module [String] Exports Imports [Statement]
@@ -30,6 +29,7 @@ data Expr = IntNum Int
30 | Lambda String Expr
29 | Lambda String Expr
31 | App Expr Expr
30 | App Expr Expr
32 | If Expr Expr Expr
31 | If Expr Expr Expr
32+ | Guard [(Expr,Expr)]
33 | Lift Expr [Expr]
33 | Lift Expr [Expr]
34 | Fold Expr Expr Expr
34 | Fold Expr Expr Expr
35 | Async Expr
35 | Async Expr
@@ -92,6 +92,7 @@ instance Show Expr where
92 concat [ "\\", intercalate " " xs, " -> ", show e' ]
92 concat [ "\\", intercalate " " xs, " -> ", show e' ]
93 show (App e1 e2) = show' e1 ++ " " ++ show' e2
93 show (App e1 e2) = show' e1 ++ " " ++ show' e2
94 show (If e1 e2 e3) = concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
94 show (If e1 e2 e3) = concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
95+ show (Guard ps) = concatMap (\(b,e) -> concat ["\n | ",show b," = ",show e]) ps
95 show (Let defs e) = "let { " ++ intercalate " ; " (map show defs) ++ " } in " ++ show e
96 show (Let defs e) = "let { " ++ intercalate " ; " (map show defs) ++ " } in " ++ show e
96 show (Var x) = x
97 show (Var x) = x
97 show (Case e pats) = "case " ++ show e ++ " of { " ++ intercalate " ; " (map (\(p,e) -> show p ++ " -> " ++ show e) pats) ++ " }"
98 show (Case e pats) = "case " ++ show e ++ " of { " ++ intercalate " ; " (map (\(p,e) -> show p ++ " -> " ++ show e) pats) ++ " }"
elm/src/FreeVar.hs+2
@@ -1,6 +1,7 @@
1module FreeVar (freeIn,freeVars) where
1module FreeVar (freeIn,freeVars) where
2
2
3import Ast
3import Ast
4+import Control.Arrow ((***))
4import Data.Set (union, unions, delete, singleton, empty, difference, member)
5import Data.Set (union, unions, delete, singleton, empty, difference, member)
5
6
6x `freeIn` expr = member x $ freeVars expr
7x `freeIn` expr = member x $ freeVars expr
@@ -13,6 +14,7 @@ freeVars expr =
13 Lambda x e -> delete x (f e)
14 Lambda x e -> delete x (f e)
14 App e1 e2 -> f e1 `union` f e2
15 App e1 e2 -> f e1 `union` f e2
15 If e1 e2 e3 -> unions $ map f [e1,e2,e3]
16 If e1 e2 e3 -> unions $ map f [e1,e2,e3]
17+ Guard ps -> map (f *** f) ps
16 Lift e es -> unions $ map f es
18 Lift e es -> unions $ map f es
17 Fold e1 e2 e3 -> unions $ map f [e1,e2,e3]
19 Fold e1 e2 e3 -> unions $ map f [e1,e2,e3]
18 Async e -> f e
20 Async e -> f e
elm/src/Gen/CompileToJS.hs+8
@@ -173,6 +173,7 @@ instance ToJS Expr where
173 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
173 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
174 Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
174 Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
175 If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
175 If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
176+ Guard ps -> guardToJS ps
176 Lambda v e -> liftM (jsFunc v . ret) (toJS e)
177 Lambda v e -> liftM (jsFunc v . ret) (toJS e)
177 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
178 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
178 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
179 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
@@ -191,6 +192,13 @@ formatMarkdown = concatMap f
191 f '"' = "\""
192 f '"' = "\""
192 f c = [c]
193 f c = [c]
193
194
195+guardToJS ps = format `liftM` mapM f ps
196+ where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
197+ err = "(function(){throw \"Non-exhaustive guard expression\";}())"
198+ f (b,e) = do b' <- toJS b
199+ e' <- toJS e
200+ return (b' ++ " ? " ++ e')
201+
194jsLet defs e' = do
202jsLet defs e' = do
195 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
203 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
196 return $ jsFunc "" body ++ "()"
204 return $ jsFunc "" body ++ "()"
elm/src/Parse/Expr.hs+38−18
@@ -1,4 +1,4 @@
1−module Parse.Expr (def,term) where
1+module Parse.Expr {-(def,term)-} where
2
2
3import Ast
3import Ast
4import Control.Applicative ((<$>), (<*>))
4import Control.Applicative ((<$>), (<*>))
@@ -6,6 +6,7 @@ import Control.Monad
6import Data.Char (isSymbol, isDigit)
6import Data.Char (isSymbol, isDigit)
7import Data.List (foldl')
7import Data.List (foldl')
8import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
9+import Text.Parsec.Indent
9import qualified Text.Pandoc as Pan
10import qualified Text.Pandoc as Pan
10
11
11import Parse.Library
12import Parse.Library
@@ -20,7 +21,7 @@ import System.IO.Unsafe
20
21
21-------- Basic Terms --------
22-------- Basic Terms --------
22
23
23−numTerm :: (Monad m) => ParsecT [Char] u m Expr
24+numTerm :: IParser Expr
24numTerm = toExpr <$> (preNum <?> "number")
25numTerm = toExpr <$> (preNum <?> "number")
25 where toExpr n | '.' `elem` n = FloatNum (read n)
26 where toExpr n | '.' `elem` n = FloatNum (read n)
26 | otherwise = IntNum (read n)
27 | otherwise = IntNum (read n)
@@ -29,24 +30,25 @@ numTerm = toExpr <$> (preNum <?> "number")
29 string "."
30 string "."
30 ('.':) <$> many1 digit
31 ('.':) <$> many1 digit
31
32
32−strTerm :: (Monad m) => ParsecT [Char] u m Expr
33+strTerm :: IParser Expr
33strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
34strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
34 backslashed <|> satisfy (/='"')
35 backslashed <|> satisfy (/='"')
35
36
36−varTerm :: (Monad m) => ParsecT [Char] u m Expr
37+varTerm :: IParser Expr
37varTerm = toVar <$> var <?> "variable"
38varTerm = toVar <$> var <?> "variable"
38
39
39toVar v = case v of "True" -> Boolean True
40toVar v = case v of "True" -> Boolean True
40 "False" -> Boolean False
41 "False" -> Boolean False
41 _ -> Var v
42 _ -> Var v
42
43
43−chrTerm :: (Monad m) => ParsecT [Char] u m Expr
44+chrTerm :: IParser Expr
44chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
45chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
45 <?> "character"
46 <?> "character"
46
47
47
48
48-------- Complex Terms --------
49-------- Complex Terms --------
49
50
51+listTerm :: IParser Expr
50listTerm = (do { try $ string "[markdown|"
52listTerm = (do { try $ string "[markdown|"
51 ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
53 ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
52 ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })
54 ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })
@@ -55,6 +57,7 @@ listTerm = (do { try $ string "[markdown|"
55 ; Range lo <$> expr }
57 ; Range lo <$> expr }
56 , list <$> commaSep expr ])
58 , list <$> commaSep expr ])
57
59
60+parensTerm :: IParser Expr
58parensTerm = parens $ choice
61parensTerm = parens $ choice
59 [ do op <- anyOp
62 [ do op <- anyOp
60 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
63 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
@@ -66,6 +69,7 @@ parensTerm = parens $ choice
66 return $ case es of { [e] -> e; _ -> tuple es }
69 return $ case es of { [e] -> e; _ -> tuple es }
67 ]
70 ]
68
71
72+term :: IParser Expr
69term = choice [ numTerm, strTerm, chrTerm
73term = choice [ numTerm, strTerm, chrTerm
70 , accessible varTerm
74 , accessible varTerm
71 , listTerm, parensTerm ]
75 , listTerm, parensTerm ]
@@ -73,6 +77,7 @@ term = choice [ numTerm, strTerm, chrTerm
73
77
74-------- Applications --------
78-------- Applications --------
75
79
80+appExpr :: IParser Expr
76appExpr = do
81appExpr = do
77 tlist <- spaceSep1 term
82 tlist <- spaceSep1 term
78 return $ case tlist of
83 return $ case tlist of
@@ -81,12 +86,15 @@ appExpr = do
81
86
82-------- Normal Expressions --------
87-------- Normal Expressions --------
83
88
89+binaryExpr :: IParser Expr
84binaryExpr = binops appExpr anyOp
90binaryExpr = binops appExpr anyOp
85
91
92+ifExpr :: IParser Expr
86ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
93ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
87 reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
94 reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
88 reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
95 reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
89
96
97+lambdaExpr :: IParser Expr
90lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
98lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
91 whitespace
99 whitespace
92 pats <- spaceSep1 patternTerm
100 pats <- spaceSep1 patternTerm
@@ -94,32 +102,40 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
94 e <- expr
102 e <- expr
95 return $ makeLambda pats e
103 return $ makeLambda pats e
96
104
105+defSet :: IParser [Def]
97defSet = do
106defSet = do
98 brace <- optionMaybe $ do
107 brace <- optionMaybe $ do
99− char '{' <?> "a set of definitions { x = ... ; y = ... }"
108+ string "{" <?> "a set of definitions { x = ... ; y = ... }"
100− whitespace
109+ whitespace >> return "{"
101 case brace of
110 case brace of
102− Nothing -> assignExpr
111+ Nothing -> concat <$> block (do d <- assignExpr ; whitespace ; return d)
103− Just '{' -> do dss <- semiSep1 assignExpr
112+ Just "{" -> do dss <- semiSep1 assignExpr
104 whitespace
113 whitespace
105 string "}" <?> "closing bracket '}'"
114 string "}" <?> "closing bracket '}'"
106 return (concat dss)
115 return (concat dss)
116+
117+letExpr :: IParser Expr
107letExpr = do
118letExpr = do
108 reserved "let" ; whitespace
119 reserved "let" ; whitespace
109 defs <- defSet
120 defs <- defSet
110 whitespace ; reserved "in" ; whitespace
121 whitespace ; reserved "in" ; whitespace
111 Let defs <$> expr
122 Let defs <$> expr
112
123
124+caseExpr :: IParser Expr
113caseExpr = do
125caseExpr = do
114 reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
126 reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
115− Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
127+ Case e <$> (with <|> without)
116 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
128 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
117 (,) p <$> expr
129 (,) p <$> expr
130+ with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
131+ without = block (do c <- case_ ; whitespace ; return c)
118
132
119expr = choice [ ifExpr, letExpr, caseExpr
133expr = choice [ ifExpr, letExpr, caseExpr
120 , lambdaExpr, binaryExpr ] <?> "an expression"
134 , lambdaExpr, binaryExpr ] <?> "an expression"
121
135
122−funcDef = do p1 <- try patternTerm ; infics p1 <|> func p1
136+funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)
137+ <|> ((:[]) <$> patternExpr)
138+ <?> "the definition of a variable (x = ...)"
123 where func p@(PVar v) = (p:) <$> spacePrefix patternTerm
139 where func p@(PVar v) = (p:) <$> spacePrefix patternTerm
124 func p = do try (lookAhead (whitespace >> string "="))
140 func p = do try (lookAhead (whitespace >> string "="))
125 return [p]
141 return [p]
@@ -129,18 +145,22 @@ funcDef = do p1 <- try patternTerm ; infics p1 <|> func p1
129 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
145 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
130 else [ PVar (o:p), p1, p2 ]
146 else [ PVar (o:p), p1, p2 ]
131
147
132−assignExpr = do
148+assignExpr :: IParser [Def]
149+assignExpr = withPos $ do
133− fDefs <- try funcDef
150+ fDefs <- funcDef
134− <|> ((:[]) <$> patternExpr)
151+ whitespace
135− <?> "the definition of a variable (x = ...)"
136− whitespace; string "="; whitespace
152+ e <- (string "=" >> whitespace >> expr) <|> guardExpr
137− e <- expr
138 flattenPatterns fDefs e
153 flattenPatterns fDefs e
139
154
155+guardExpr = (Guard <$> spaceSep1 gExpr)
156+ where gExpr = do string "|" ; whitespace
157+ b <- expr ; whitespace ; string "=" ; whitespace
158+ (,) b <$> expr
159+
140def = map Definition <$> assignExpr
160def = map Definition <$> assignExpr
141
161
142
162
143parseDef str =
163parseDef str =
144− case parse def "" str of
164+ case iParse def "" str of
145 Right result -> Right result
165 Right result -> Right result
146 Left err -> Left $ "Parse error at " ++ show err
166 Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/Library.hs+41−30
@@ -4,8 +4,10 @@ module Parse.Library where
4import Ast
4import Ast
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad
6import Control.Monad
7+import Control.Monad.State
7import Data.Char (isSymbol)
8import Data.Char (isSymbol)
8−import Text.Parsec hiding (newline,spaces)
9+import Text.Parsec hiding (newline,spaces,State)
10+import Text.Parsec.Indent
9
11
10reserveds = [ "if", "then", "else"
12reserveds = [ "if", "then", "else"
11 , "case", "of", "data"
13 , "case", "of", "data"
@@ -16,74 +18,82 @@ reserveds = [ "if", "then", "else"
16
18
17expecting = flip (<?>)
19expecting = flip (<?>)
18
20
19−backslashed :: (Monad m) => ParsecT [Char] u m Char
21+type IParser a = ParsecT String () (State SourcePos) a
22+
23+iParse :: IParser a -> SourceName -> String -> Either ParseError a
24+iParse aParser source_name input =
25+ runIndent source_name $ runParserT aParser () source_name input
26+
27+backslashed :: IParser Char
20backslashed = do { char '\\'; c <- anyChar
28backslashed = do { char '\\'; c <- anyChar
21 ; return . read $ ['\'','\\',c,'\''] }
29 ; return . read $ ['\'','\\',c,'\''] }
22
30
23−var :: (Monad m) => ParsecT [Char] u m String
31+var :: IParser String
24var = makeVar (letter <|> char '_' <?> "variable")
32var = makeVar (letter <|> char '_' <?> "variable")
25
33
26−lowVar :: (Monad m) => ParsecT [Char] u m String
34+lowVar :: IParser String
27lowVar = makeVar (lower <?> "lower case variable")
35lowVar = makeVar (lower <?> "lower case variable")
28−capVar :: (Monad m) => ParsecT [Char] u m String
36+capVar :: IParser String
29capVar = makeVar (upper <?> "upper case variable")
37capVar = makeVar (upper <?> "upper case variable")
30
38
31−innerVarChar :: (Monad m) => ParsecT [Char] u m Char
39+innerVarChar :: IParser Char
32innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
40innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
33
41
42+makeVar :: IParser Char -> IParser String
34makeVar p = do v <- (:) <$> p <*> many innerVarChar
43makeVar p = do v <- (:) <$> p <*> many innerVarChar
35 guard (v `notElem` reserveds)
44 guard (v `notElem` reserveds)
36 return v
45 return v
37
46
47+reserved :: String -> IParser String
38reserved word =
48reserved word =
39 try (string word >> notFollowedBy innerVarChar) >> return word
49 try (string word >> notFollowedBy innerVarChar) >> return word
40 <?> "reserved word '" ++ word ++ "'"
50 <?> "reserved word '" ++ word ++ "'"
41
51
42−anyOp :: (Monad m) => ParsecT [Char] u m String
52+anyOp :: IParser String
43anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
53anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
44
54
45isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
55isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
46
56
47−symOp :: (Monad m) => ParsecT [Char] u m String
57+symOp :: IParser String
48symOp = do op <- many1 (satisfy isOp)
58symOp = do op <- many1 (satisfy isOp)
49 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
59 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
50 return op
60 return op
51
61
52−arrow :: (Monad m) => ParsecT [Char] u m String
62+arrow :: IParser String
53arrow = string "->" <|> string "\8594" <?> "arrow (->)"
63arrow = string "->" <|> string "\8594" <?> "arrow (->)"
54
64
55
65
56commitIf check p = commit <|> try p
66commitIf check p = commit <|> try p
57 where commit = do (try $ lookAhead check) >> p
67 where commit = do (try $ lookAhead check) >> p
58
68
59−spaceySepBy1 :: (Monad m) => ParsecT [Char] u m b -> ParsecT [Char] u m a -> ParsecT [Char] u m [a]
69+spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
60spaceySepBy1 sep p = do
70spaceySepBy1 sep p = do
61 a <- p
71 a <- p
62 (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))
72 (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))
63
73
64
74
65−commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
75+commaSep1 :: IParser a -> IParser [a]
66commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
76commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
67
77
68−commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
78+commaSep :: IParser a -> IParser [a]
69commaSep = option [] . commaSep1
79commaSep = option [] . commaSep1
70
80
71−semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
81+semiSep1 :: IParser a -> IParser [a]
72semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
82semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
73
83
74−pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
84+pipeSep1 :: IParser a -> IParser [a]
75pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
85pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
76
86
77−consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
87+consSep1 :: IParser a -> IParser [a]
78consSep1 = spaceySepBy1 (char ':' <?> "cons operator ':'")
88consSep1 = spaceySepBy1 (char ':' <?> "cons operator ':'")
79
89
80−dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
90+dotSep1 :: IParser a -> IParser [a]
81dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
91dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
82
92
83−spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
93+spaceSep1 :: IParser a -> IParser [a]
84spaceSep1 p = (:) <$> p <*> spacePrefix p
94spaceSep1 p = (:) <$> p <*> spacePrefix p
85
95
86−spacePrefix p = many (commitIf (whitespace >> (char '[' <|> char '(')) (whitespace >> p))
96+spacePrefix p = many (try (whitespace >> indented >> p))
87
97
88followedBy a b = do x <- a ; b ; return x
98followedBy a b = do x <- a ; b ; return x
89
99
@@ -95,15 +105,16 @@ surround a z name p = do
95 char z <?> unwords ["closing", name, show z]
105 char z <?> unwords ["closing", name, show z]
96 return v
106 return v
97
107
98−braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
108+braces :: IParser a -> IParser a
99braces = surround '[' ']' "brace"
109braces = surround '[' ']' "brace"
100
110
101−parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
111+parens :: IParser a -> IParser a
102parens = surround '(' ')' "paren"
112parens = surround '(' ')' "paren"
103
113
104−brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
114+brackets :: IParser a -> IParser a
105brackets = surround '{' '}' "bracket"
115brackets = surround '{' '}' "bracket"
106
116
117+accessible :: IParser Expr -> IParser Expr
107accessible expr = do
118accessible expr = do
108 e <- expr
119 e <- expr
109 access <- optionMaybe . try $
120 access <- optionMaybe . try $
@@ -113,34 +124,34 @@ accessible expr = do
113 Nothing -> return e
124 Nothing -> return e
114
125
115
126
116−spaces :: (Monad m) => ParsecT [Char] u m String
127+spaces :: IParser String
117spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
128spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
118
129
119−forcedWS :: (Monad m) => ParsecT [Char] u m [String]
130+forcedWS :: IParser [String]
120forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
131forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
121 where nl_space = try $ many1 newline >> spaces
132 where nl_space = try $ many1 newline >> spaces
122
133
123−whitespace :: (Monad m) => ParsecT [Char] u m ()
134+whitespace :: IParser ()
124whitespace = optional forcedWS <?> ""
135whitespace = optional forcedWS <?> ""
125
136
126−freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
137+freshLine :: IParser [[String]]
127freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
138freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
128 where space_nl = try $ spaces >> many1 newline
139 where space_nl = try $ spaces >> many1 newline
129
140
130−newline :: (Monad m) => ParsecT [Char] u m String
141+newline :: IParser String
131newline = simpleNewline <|> lineComment <?> ""
142newline = simpleNewline <|> lineComment <?> ""
132
143
133−simpleNewline :: (Monad m) => ParsecT [Char] u m String
144+simpleNewline :: IParser String
134simpleNewline = try (string "\r\n") <|> string "\n"
145simpleNewline = try (string "\r\n") <|> string "\n"
135
146
136−lineComment :: (Monad m) => ParsecT [Char] u m String
147+lineComment :: IParser String
137lineComment = do try (string "--")
148lineComment = do try (string "--")
138 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
149 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
139
150
140−multiComment :: (Monad m) => ParsecT [Char] u m String
151+multiComment :: IParser String
141multiComment = do { try (string "{-"); closeComment }
152multiComment = do { try (string "{-"); closeComment }
142
153
143−closeComment :: (Monad m) => ParsecT [Char] u m String
154+closeComment :: IParser String
144closeComment = manyTill anyChar . choice $
155closeComment = manyTill anyChar . choice $
145 [ try (string "-}") <?> "close comment"
156 [ try (string "-}") <?> "close comment"
146 , do { try $ string "{-"; closeComment; closeComment }
157 , do { try $ string "{-"; closeComment; closeComment }
elm/src/Parse/Modules.hs+7−7
@@ -8,10 +8,10 @@ import Text.Parsec hiding (newline,spaces)
8import Ast
8import Ast
9import Parse.Library
9import Parse.Library
10
10
11−varList :: (Monad m) => ParsecT [Char] u m [String]
11+varList :: IParser [String]
12varList = parens $ commaSep1 (var <|> parens symOp)
12varList = parens $ commaSep1 (var <|> parens symOp)
13
13
14−moduleDef :: (Monad m) => ParsecT [Char] u m ([String], [String])
14+moduleDef :: IParser ([String], [String])
15moduleDef = do
15moduleDef = do
16 try (reserved "module")
16 try (reserved "module")
17 whitespace
17 whitespace
@@ -22,11 +22,11 @@ moduleDef = do
22 reserved "where"
22 reserved "where"
23 return (names, exports)
23 return (names, exports)
24
24
25−imports :: (Monad m) => ParsecT [Char] u m Imports
25+imports :: IParser Imports
26imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
26imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
27
27
28
28
29−import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod)
29+import' :: IParser (String, ImportMethod)
30import' = do
30import' = do
31 reserved "import"
31 reserved "import"
32 whitespace
32 whitespace
@@ -36,12 +36,12 @@ import' = do
36 return (name, method)
36 return (name, method)
37
37
38
38
39−as' :: (Monad m) => ParsecT [Char] u m ImportMethod
39+as' :: IParser ImportMethod
40as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
40as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
41
41
42−hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod
42+hiding' :: IParser ImportMethod
43hiding' = reserved "hiding" >> whitespace >>
43hiding' = reserved "hiding" >> whitespace >>
44 Hiding <$> varList <?> "listing of hidden values"
44 Hiding <$> varList <?> "listing of hidden values"
45
45
46−importing' :: (Monad m) => ParsecT [Char] u m ImportMethod
46+importing' :: IParser ImportMethod
47importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
47importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
elm/src/Parse/Parser.hs+1−1
@@ -36,6 +36,6 @@ program = do
36 return $ Module names exports is statements
36 return $ Module names exports is statements
37
37
38parseProgram source =
38parseProgram source =
39− case parse program "" source of
39+ case iParse program "" source of
40 Right result -> Right result
40 Right result -> Right result
41 Left err -> Left $ "Parse error at " ++ show err
41 Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/Patterns.hs+9−7
@@ -4,30 +4,32 @@ import Ast
4import Data.Char (isUpper)
4import Data.Char (isUpper)
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad
6import Control.Monad
7+import Control.Monad.State
8+import Text.Parsec hiding (newline,spaces,State)
7−import Text.Parsec
9+import Text.Parsec.Indent
8import Parse.Library
10import Parse.Library
9
11
10−patternBasic :: Monad m => ParsecT [Char] u m Pattern
12+patternBasic :: IParser Pattern
11patternBasic =
13patternBasic =
12 choice [ char '_' >> return PAnything
14 choice [ char '_' >> return PAnything
13 , do x@(c:_) <- var
15 , do x@(c:_) <- var
14 return $ if isUpper c then PData x [] else PVar x
16 return $ if isUpper c then PData x [] else PVar x
15 ]
17 ]
16
18
17−patternTuple :: Monad m => ParsecT [Char] u m Pattern
19+patternTuple :: IParser Pattern
18patternTuple = do ps <- parens (commaSep patternExpr)
20patternTuple = do ps <- parens (commaSep patternExpr)
19 return $ case ps of { [p] -> p; _ -> ptuple ps }
21 return $ case ps of { [p] -> p; _ -> ptuple ps }
20
22
21−patternList :: Monad m => ParsecT [Char] u m Pattern
23+patternList :: IParser Pattern
22patternList = plist <$> braces (commaSep patternExpr)
24patternList = plist <$> braces (commaSep patternExpr)
23
25
24−patternTerm :: Monad m => ParsecT [Char] u m Pattern
26+patternTerm :: IParser Pattern
25patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
27patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
26
28
27−patternConstructor :: Monad m => ParsecT [Char] u m Pattern
29+patternConstructor :: IParser Pattern
28patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
30patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
29
31
30−patternExpr :: Monad m => ParsecT [Char] u m Pattern
32+patternExpr :: IParser Pattern
31patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
33patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
32
34
33
35
elm/src/Parse/Types.hs+10−9
@@ -7,6 +7,7 @@ import Data.Char (isUpper,isLower)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
8import Data.List (lookup)
8import Data.List (lookup)
9import Text.Parsec
9import Text.Parsec
10+import Text.Parsec.Indent
10
11
11import Parse.Library
12import Parse.Library
12import Types.Types hiding (string,parens)
13import Types.Types hiding (string,parens)
@@ -19,43 +20,43 @@ data ParseType = VarPT String
19listPT t = ADTPT "List" [t]
20listPT t = ADTPT "List" [t]
20tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
21tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
21
22
22−typeVar :: (Monad m) => ParsecT [Char] u m ParseType
23+typeVar :: IParser ParseType
23typeVar = VarPT <$> lowVar <?> "type variable"
24typeVar = VarPT <$> lowVar <?> "type variable"
24
25
25−typeList :: (Monad m) => ParsecT [Char] u m ParseType
26+typeList :: IParser ParseType
26typeList = listPT <$> braces typeExpr
27typeList = listPT <$> braces typeExpr
27
28
28−typeTuple :: (Monad m) => ParsecT [Char] u m ParseType
29+typeTuple :: IParser ParseType
29typeTuple = do ts <- parens (commaSep typeExpr)
30typeTuple = do ts <- parens (commaSep typeExpr)
30 return $ case ts of { [t] -> t ; _ -> tuplePT ts }
31 return $ case ts of { [t] -> t ; _ -> tuplePT ts }
31
32
32−typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType
33+typeUnambiguous :: IParser ParseType
33typeUnambiguous = typeList <|> typeTuple
34typeUnambiguous = typeList <|> typeTuple
34
35
35−typeSimple :: (Monad m) => ParsecT [Char] u m ParseType
36+typeSimple :: IParser ParseType
36typeSimple = dealias <$> var
37typeSimple = dealias <$> var
37 where dealias "String" = listPT (VarPT "Char")
38 where dealias "String" = listPT (VarPT "Char")
38 dealias v = VarPT v
39 dealias v = VarPT v
39
40
40−typeApp :: (Monad m) => ParsecT [Char] u m ParseType
41+typeApp :: IParser ParseType
41typeApp = do name <- capVar <?> "type constructor"
42typeApp = do name <- capVar <?> "type constructor"
42 args <- spacePrefix (typeUnambiguous <|> typeSimple)
43 args <- spacePrefix (typeUnambiguous <|> typeSimple)
43 return $ case args of
44 return $ case args of
44 [] -> VarPT name
45 [] -> VarPT name
45 _ -> ADTPT name args
46 _ -> ADTPT name args
46
47
47−typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
48+typeExpr :: IParser ParseType
48typeExpr = do
49typeExpr = do
49 t1 <- typeVar <|> typeApp <|> typeUnambiguous
50 t1 <- typeVar <|> typeApp <|> typeUnambiguous
50 whitespace ; arr <- optionMaybe arrow ; whitespace
51 whitespace ; arr <- optionMaybe arrow ; whitespace
51 case arr of Just _ -> LambdaPT t1 <$> typeExpr
52 case arr of Just _ -> LambdaPT t1 <$> typeExpr
52 Nothing -> return t1
53 Nothing -> return t1
53
54
54−typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
55+typeConstructor :: IParser (String, [ParseType])
55typeConstructor = (,) <$> (capVar <?> "another type constructor")
56typeConstructor = (,) <$> (capVar <?> "another type constructor")
56 <*> spacePrefix (typeSimple <|> typeUnambiguous)
57 <*> spacePrefix (typeSimple <|> typeUnambiguous)
57
58
58−datatype :: (Monad m) => ParsecT [Char] u m Statement
59+datatype :: IParser Statement
59datatype = do
60datatype = do
60 reserved "data" <?> "datatype definition (data T = A | B | ...)"
61 reserved "data" <?> "datatype definition (data T = A | B | ...)"
61 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
62 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
elm/src/Rename.hs+4
@@ -77,6 +77,10 @@ instance Rename Expr where
77 `ap` rnm e2
77 `ap` rnm e2
78 `ap` rnm e3
78 `ap` rnm e3
79
79
80+ Guard ps -> Guard `liftM` mapM grnm ps
81+ where grnm (b,e) = (,) `liftM` rnm b
82+ `ap` rnm e
83+
80 Lift e es -> Lift `liftM` rnm e
84 Lift e es -> Lift `liftM` rnm e
81 `ap` mapM rnm es
85 `ap` mapM rnm es
82
86
elm/src/Replace.hs+3
@@ -1,6 +1,7 @@
1module Replace (replace, depth) where
1module Replace (replace, depth) where
2
2
3import Ast
3import Ast
4+import Control.Arrow ((***))
4import Data.Set (singleton,empty,unions,member, Set)
5import Data.Set (singleton,empty,unions,member, Set)
5
6
6replace :: String -> Expr -> Expr -> Expr
7replace :: String -> Expr -> Expr -> Expr
@@ -12,6 +13,7 @@ replace y v expr =
12 Binop op e1 e2 -> Binop op (f e1) (f e2)
13 Binop op e1 e2 -> Binop op (f e1) (f e2)
13 App e1 e2 -> App (f e1) (f e2)
14 App e1 e2 -> App (f e1) (f e2)
14 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
15 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
16+ Guard ps -> map (f *** f) ps
15 Lift e es -> Lift (f e) (map f es)
17 Lift e es -> Lift (f e) (map f es)
16 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
18 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
17 Async e -> Async (f e)
19 Async e -> Async (f e)
@@ -44,6 +46,7 @@ depth' d expr =
44 Lambda x e -> f e
46 Lambda x e -> f e
45 App e1 e2 -> max (f e1) (f e2)
47 App e1 e2 -> max (f e1) (f e2)
46 If e1 e2 e3 -> maximum [f e1, f e2, f e3]
48 If e1 e2 e3 -> maximum [f e1, f e2, f e3]
49+ Guard ps -> maximum (map (uncurry max . f *** f) ps)
47 Lift e es -> maximum $ f e : map f es
50 Lift e es -> maximum $ f e : map f es
48 Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
51 Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
49 Async e -> f e
52 Async e -> f e
elm/src/Substitute.hs+2−1
@@ -1,6 +1,6 @@
1module Substitute (subst) where
1module Substitute (subst) where
2
2
3−import Control.Arrow (second)
3+import Control.Arrow (second, (***))
4
4
5import Ast
5import Ast
6
6
@@ -14,6 +14,7 @@ subst old new expr =
14 Lambda x e -> if x == old then expr else Lambda x (f e)
14 Lambda x e -> if x == old then expr else Lambda x (f e)
15 App e1 e2 -> App (f e1) (f e2)
15 App e1 e2 -> App (f e1) (f e2)
16 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
16 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
17+ Guard ps -> Guard (map (f *** f) ps)
17 Lift e es -> Lift (f e) (map f es)
18 Lift e es -> Lift (f e) (map f es)
18 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
19 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
19 Async e -> Async (f e)
20 Async e -> Async (f e)
elm/src/Types/Constrain.hs+11−1
@@ -122,6 +122,16 @@ gen (Range e1 e2) =
122 , ctx e2 (t2 :=: int) ] ]
122 , ctx e2 (t2 :=: int) ] ]
123 , listOf int )
123 , listOf int )
124
124
125+gen e@(Guard ps) = do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
126+ let cs = Set.fromList (map (ctx e . (t :=:)) ts)
127+ return (unionsA ass, Set.unions (cs:css), t)
128+ where genPair (b,e) = do
129+ (a1,c1,t1) <- gen b
130+ (a2,c2,t2) <- gen e
131+ return ( unionsA [a1,a2]
132+ , Set.unions [ c1, c2, Set.singleton (ctx b (t1 :=: bool)) ]
133+ , t2 )
134+
125gen other =
135gen other =
126 case other of
136 case other of
127 IntNum _ -> do t <- beta
137 IntNum _ -> do t <- beta
@@ -131,7 +141,7 @@ gen other =
131 Str _ -> primitive string
141 Str _ -> primitive string
132 Boolean _ -> primitive bool
142 Boolean _ -> primitive bool
133 Markdown _ -> primitive element
143 Markdown _ -> primitive element
134− _ -> beta >>= primitive
144+ -- _ -> beta >>= primitive
135
145
136primitive t = return (Map.empty, Set.empty, t)
146primitive t = return (Map.empty, Set.empty, t)
137
147