git.iko.soy/elk
on master help sign in
Rewrite parser. Provides much better error messages and pattern matching in anonymous functions.
6940dddevancz
elm/src/Parse/Binop.hs → elm/src/Parse/Binops.hsrenamed+16−11
compare with master
unifiedsplit
@@ -1,21 +1,23 @@
1−module Binop (binops) where
1+module Binops (binops) where
2
2
3import Ast
3import Ast
4−import Combinators
5import Control.Monad (liftM,guard)
4import Control.Monad (liftM,guard)
6import Control.Monad.Error
5import Control.Monad.Error
7import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
6import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
8import qualified Data.Map as Map
7import qualified Data.Map as Map
9import Data.Maybe (mapMaybe)
8import Data.Maybe (mapMaybe)
10
9
10+import Text.Parsec
11+import ParseLib
12+
11−data Assoc = L | Non | R deriving (Eq,Show)
13+data Assoc = L | N | R deriving (Eq,Show)
12
14
13table = [ (9, R, ".")
15table = [ (9, R, ".")
14 , (7, L, "*"), (7, L, "/"), (7, L, "mod")
16 , (7, L, "*"), (7, L, "/"), (7, L, "mod")
15 , (6, L, "+"), (6, L, "-")
17 , (6, L, "+"), (6, L, "-")
16 , (5, R, ":" ), (5, R, "++")
18 , (5, R, ":" ), (5, R, "++")
17− , (4, Non, "<="), (4, Non, ">="), (4, Non, "<")
19+ , (4, N, "<="), (4, N, ">="), (4, N, "<")
18− , (4, Non, "=="), (4, Non, "/="), (4, Non, ">")
20+ , (4, N, "=="), (4, N, "/="), (4, N, ">")
19 , (3, R, "&&")
21 , (3, R, "&&")
20 , (2, R, "||")
22 , (2, R, "||")
21 , (0, R, "$")
23 , (0, R, "$")
@@ -25,10 +27,14 @@ sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
25
27
26binops term anyOp = do
28binops term anyOp = do
27 e <- term
29 e <- term
28− (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) })
30+ (ops,es) <- liftM unzip $
31+ many (try $ do { whitespace
32+ ; op <- anyOp
33+ ; whitespace
34+ ; e <- term; return (op,e) })
29 case binopOf Map.empty (sortOps table) ops (e:es) of
35 case binopOf Map.empty (sortOps table) ops (e:es) of
30 Right e -> return e
36 Right e -> return e
31− Left msg -> zero
37+ Left msg -> fail msg
32
38
33binopSplit seen opTable i ops es =
39binopSplit seen opTable i ops es =
34 case (splitAt i ops, splitAt (i+1) es) of
40 case (splitAt i ops, splitAt (i+1) es) of
@@ -38,8 +44,7 @@ binopSplit seen opTable i ops es =
38 return $ Binop op e1 e2
44 return $ Binop op e1 e2
39
45
40binopOf _ _ _ [e] = return e
46binopOf _ _ _ [e] = return e
41−binopOf _ [] ops es =
47+binopOf seen [] ops es = binopOf seen [(9,L,head ops)] ops es
42− return $ foldl' (flip ($)) (head es) $ zipWith Binop ops (tail es)
43
48
44binopOf seen (tbl@((lvl, L, op):rest)) ops es =
49binopOf seen (tbl@((lvl, L, op):rest)) ops es =
45 case elemIndices op ops of
50 case elemIndices op ops of
@@ -52,9 +57,9 @@ binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
52 case elemIndices op ops of
57 case elemIndices op ops of
53 [] -> binopOf seen rest ops es
58 [] -> binopOf seen rest ops es
54 i:_ -> case Map.lookup lvl seen of
59 i:_ -> case Map.lookup lvl seen of
55− Nothing -> binopSplit (Map.insert lvl (R,op) seen) tbl i ops es
60+ Nothing -> binopSplit (Map.insert lvl (assoc,op) seen) tbl i ops es
56 Just (assoc',op') ->
61 Just (assoc',op') ->
57− if assoc == assoc' && assoc /= Non then
62+ if assoc == assoc' && assoc /= N then
58 binopSplit seen tbl i ops es
63 binopSplit seen tbl i ops es
59 else Left $ errorMessage lvl op assoc op' assoc'
64 else Left $ errorMessage lvl op assoc op' assoc'
60
65
elm/src/Parse/Combinators.hsdeleted−82
@@ -1,82 +0,0 @@
1−module Combinators where
2−import Control.Monad
3−import Data.Char
4−import Data.List (sortBy,foldl',foldl1')
5−
6−newtype Parser from to = Parser ([from] -> [(to,[from])])
7−--newtype Parser a = Parser (String -> [(a,String)])
8−
9−parse (Parser p) = p
10−
11−instance Monad (Parser from) where
12− return a = Parser (\cs -> [(a,cs)])
13− p >>= f = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs])
14−
15−instance MonadPlus (Parser from) where
16− mzero = Parser $ const []
17− mplus p q = Parser (\cs -> parse p cs ++ parse q cs)
18−
19−-- True recursive descent, tries everything.
20−p +++ q = mplus p q
21−
22−-- Get the first parse.
23−p +|+ q = Parser (\cs -> case parse (mplus p q) cs of
24− [] -> []
25− (x:xs) -> [x])
26−
27−zero = Parser $ const []
28−
29−item = Parser (\cs -> case cs of
30− [] -> []
31− (c:cs) -> [(c,cs)])
32−
33−sat p = do {c <- item; if p c then return c else mzero}
34−
35−char c = sat (c ==)
36−
37−string "" = return ""
38−string (c:cs) = do {char c; string cs; return (c:cs)}
39−
40−star p = plus p +++ return []
41−plus p = do {a <- p; as <- star p; return (a:as)}
42−
43−optional p = (Just `liftM` p) +++ return Nothing
44−
45−nospace = guard . (==0) . length =<< space
46−space = star $ sat isSpace
47−space1 = plus $ sat isSpace
48−newline = do
49− star $ char ' ' +++ char '\t'
50− char '\n'
51− space
52− return ""
53−
54−digit = do {x <- sat isDigit; return (ord x - ord '0')}
55−integer = do {i <- plus digit; return $ foldl' (\a d -> 10 * a + d) 0 i}
56−
57−variable = do
58− shd <- sat isLower;
59− stl <- star $ sat (\c -> isAlphaNum c || c == '_')
60− return $ shd:stl
61−
62−sepBy sep p = sepBy1 sep p +++ return []
63−
64−sepBy1 sep p = do
65− x <- p
66− xs <- star (sep >> p)
67− return $ x:xs
68−
69−select = foldl1' (+|+)
70−
71−chainl p op a = chainl1 p op +++ return a
72−chainl1 p op = do {a <- p; rest a}
73− where
74− rest a = (do f <- op
75− b <- p
76− rest (f a b)) +++ return a
77−
78−extractResult err parse =
79− case parse of
80− (r,[]) : _ -> Right r
81− _ : rest -> extractResult err rest
82− [] -> Left err
elm/src/Parse/Lexer.hsdeleted−84
@@ -1,84 +0,0 @@
1−
2−module Lexer (tokenize) where
3−
4−import Control.Applicative ((<|>), (<$>), (<*>))
5−import Data.Char (isSymbol)
6−import Text.Parsec (Parsec, alphaNum, anyChar, char, choice, digit, eof, letter,
7− many, many1, manyTill, newline, notFollowedBy, oneOf, parse,
8− satisfy, string, try, upper)
9−import Tokens
10−import Control.Monad (liftM)
11−
12−token :: Parsec String u Token
13−token = NUMBER <$> integer
14− <|> whitespace
15− <|> chrs [ ('(',LPAREN) , (')',RPAREN)
16− , ('{',LBRACE) , ('}',RBRACE)
17− , ('[',LBRACKET), (']',RBRACKET)
18− , (',',COMMA) , (';',SEMI), ('_',UNDERSCORE)
19− , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ]
20− <|> reserveds [ ("True",TRUE), ("False",FALSE)
21− , ("if",IF), ("then",THEN), ("else",ELSE)
22− , ("case",CASE), ("of",OF), ("data", DATA)
23− , ("let",LET), ("in",IN) ]
24− <|> do { char '`'; v <- variable; char '`'; return $ OP v }
25− <|> anyOp
26− <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"'
27− ; return $ STRING s}
28− <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
29− ; return $ CHAR c}
30− <|> (ID <$> variable)
31− <|> typeVar
32− <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
33−
34−chrs :: [(Char, Token)] -> Parsec String u Token
35−chrs = choice . map chr
36− where chr (c, t) = char c >> return t
37−
38−reserveds :: [(String, Token)] -> Parsec String u Token
39−reserveds = choice . map reserved
40− where reserved (s, t) = try $ string s >>
41− notFollowedBy (alphaNum <|> char '_') >>
42− return t
43−
44−anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
45− case op of { ".." -> return DOT2
46− ; "->" -> return ARROW; "\8594" -> return ARROW
47− ; _ -> return $ OP op }
48−
49−backslashed :: Parsec String u Char
50−backslashed = do { char '\\'; c <- anyChar
51− ; return . read $ ['\'','\\',c,'\''] }
52−
53−integer :: Parsec String u Int
54−integer = read <$> many1 digit
55−
56−variable :: Parsec String u String
57−variable = identifier $ letter <|> char '_'
58−
59−typeVar :: Parsec String u Token
60−typeVar = TYPE <$> identifier upper
61−
62−identifier :: Parsec String u Char -> Parsec String u String
63−identifier c = (:) <$> c <*> (many $ alphaNum <|> oneOf "_\'")
64−
65−---- White Space and comments ----
66−
67−whitespace = (lineComment >> return NEWLINE) <|>
68− (many1 (multiComment <|> many1 (char ' ')) >> return SPACES)
69−lineComment = do try $ string "--"
70− manyTill anyChar $ newline <|> (eof >> return '\n')
71−
72−multiComment = do { try $ string "{-"; closeComment }
73−closeComment = manyTill anyChar . choice $
74− [ try $ string "-}"
75− , do { try $ string "{-"; closeComment; closeComment }
76− ]
77−
78−tokenParser :: Parsec String u [Token]
79−tokenParser = many1 token
80−
81−tokenize :: String -> Either String [Token]
82−tokenize s = case parse tokenParser "" s of
83− Right ts -> Right ts
84− Left err -> Left $ "Syntax error: " ++ show err
elm/src/Parse/ParseLib.hsnew file+136
@@ -0,0 +1,136 @@
1+
2+module ParseLib where
3+
4+import Ast
5+import Control.Applicative ((<$>),(<*>))
6+import Control.Monad
7+import Data.Char (isSymbol)
8+import Text.Parsec hiding (newline,spaces)
9+
10+reserveds = [ "if", "then", "else"
11+ , "case", "of", "data"
12+ , "let", "in" ]
13+
14+expecting = flip (<?>)
15+
16+backslashed :: (Monad m) => ParsecT [Char] u m Char
17+backslashed = do { char '\\'; c <- anyChar
18+ ; return . read $ ['\'','\\',c,'\''] }
19+
20+var :: (Monad m) => ParsecT [Char] u m String
21+var = makeVar (letter <|> char '_' <?> "variable")
22+
23+lowVar :: (Monad m) => ParsecT [Char] u m String
24+lowVar = makeVar (lower <?> "lower case variable")
25+capVar :: (Monad m) => ParsecT [Char] u m String
26+capVar = makeVar (upper <?> "upper case variable")
27+
28+innerVarChar :: (Monad m) => ParsecT [Char] u m Char
29+innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
30+
31+makeVar p = do v <- (:) <$> p <*> many innerVarChar
32+ guard (v `notElem` reserveds)
33+ return v
34+
35+reserved word =
36+ try (string word >> notFollowedBy innerVarChar) >> return word
37+ <?> "reserved word '" ++ word ++ "'"
38+
39+anyOp :: (Monad m) => ParsecT [Char] u m String
40+anyOp = betwixt '`' '`' var <|>
41+ (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
42+ guard (op `notElem` [ "=", "..", "->", "--" ])
43+ return op) <?> "infix operator (e.g. x + y)"
44+
45+arrow :: (Monad m) => ParsecT [Char] u m String
46+arrow = string "->" <|> string "\8594" <?> "arrow (->)"
47+
48+commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
49+commaSep p = do
50+ x <- optionMaybe p
51+ case x of
52+ Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
53+ whitespace >> p)
54+ Nothing -> return []
55+
56+semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
57+semiSep1 p = do
58+ a <- p
59+ (a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
60+ whitespace >> p)
61+
62+pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
63+pipeSep1 p = do
64+ a <- p
65+ (a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >>
66+ whitespace >> p)
67+
68+consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
69+consSep1 p = do
70+ a <- p
71+ (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
72+ whitespace >> p)
73+
74+spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
75+spaceSep1 p = (:) <$> p <*> spacePrefix p
76+
77+spacePrefix p = many (try (whitespace >> p))
78+
79+betwixt a b c = do char a ; out <- c
80+ char b <?> "closing '" ++ [b] ++ "'" ; return out
81+
82+surround a z name p = do
83+ char a ; whitespace ; a <- p ; whitespace
84+ char z <?> unwords ["closing", name, show z]
85+ return a
86+
87+braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
88+braces = surround '[' ']' "brace"
89+
90+parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
91+parens = surround '(' ')' "paren"
92+
93+brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
94+brackets = surround '{' '}' "bracket"
95+
96+accessible expr = do
97+ e <- expr
98+ access <- optionMaybe . try $
99+ (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")
100+ case access of
101+ Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")
102+ Nothing -> return e
103+
104+
105+spaces :: (Monad m) => ParsecT [Char] u m String
106+spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
107+
108+forcedWS :: (Monad m) => ParsecT [Char] u m [String]
109+forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
110+ where nl_space = try $ many1 newline >> spaces
111+
112+whitespace :: (Monad m) => ParsecT [Char] u m ()
113+whitespace = optional forcedWS <?> ""
114+
115+freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
116+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
117+ where space_nl = try $ spaces >> many1 newline
118+
119+newline :: (Monad m) => ParsecT [Char] u m String
120+newline = simpleNewline <|> lineComment <?> ""
121+
122+simpleNewline :: (Monad m) => ParsecT [Char] u m String
123+simpleNewline = try (string "\r\n") <|> string "\n"
124+
125+lineComment :: (Monad m) => ParsecT [Char] u m String
126+lineComment = do try (string "--")
127+ manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
128+
129+multiComment :: (Monad m) => ParsecT [Char] u m String
130+multiComment = do { try (string "{-"); closeComment }
131+
132+closeComment :: (Monad m) => ParsecT [Char] u m String
133+closeComment = manyTill anyChar . choice $
134+ [ try (string "-}") <?> "close comment"
135+ , do { try $ string "{-"; closeComment; closeComment }
136+ ]
elm/src/Parse/ParsePatterns.hsdeleted−31
@@ -1,31 +0,0 @@
1−module ParsePatterns (patternTerm, patternExpr) where
2−
3−import Ast
4−import Combinators
5−import Data.Char (isUpper)
6−import ParserLib
7−import Tokens
8−import Control.Monad (liftM)
9−
10−patternBasic =
11− (t UNDERSCORE >> return PAnything) +|+
12− (do { x@(c:_) <- var ;
13− if isUpper c then PData x `liftM` star patternTerm
14− else return $ PVar x })
15−
16−patternTuple = do
17− t LPAREN; ps <- sepBy1 (t COMMA) patternExpr; t RPAREN
18− return $ case ps of { [p] -> p; _ -> ptuple ps }
19−
20−patternCons = do
21− p <- patternTerm
22− colon <- optional $ opParser (==":")
23− case colon of
24− Just ":" -> pcons p `liftM` patternExpr
25− Nothing -> return p
26−
27−patternList = do
28− t LBRACKET; ps <- sepBy (t COMMA) patternExpr; t RBRACKET; return (plist ps)
29−
30−patternTerm = patternTuple +|+ patternList +|+ patternBasic
31−patternExpr = patternTuple +|+ patternList +|+ patternCons
elm/src/Parse/ParseTypes.hs+37−23
@@ -1,15 +1,16 @@
1module ParseTypes where
1module ParseTypes where
2
2
3import Ast
3import Ast
4−import Combinators
4+import Control.Applicative ((<$>),(<*>))
5+import Control.Monad (liftM)
5import Data.Char (isUpper,isLower)
6import Data.Char (isUpper,isLower)
6import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
7import Data.List (lookup)
8import Data.List (lookup)
8−import ParserLib
9+import Text.Parsec
10+
9−import Tokens
11+import ParseLib
10−import Types
12+import Types hiding (string,parens)
11import Guid
13import Guid
12−import Control.Monad (liftM)
13
14
14data ParseType = VarPT String
15data ParseType = VarPT String
15 | LambdaPT ParseType ParseType
16 | LambdaPT ParseType ParseType
@@ -18,35 +19,48 @@ data ParseType = VarPT String
18listPT t = ADTPT "List" [t]
19listPT t = ADTPT "List" [t]
19tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
20tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
20
21
22+typeVar :: (Monad m) => ParsecT [Char] u m ParseType
21−typeVar = liftM VarPT lowVar
23+typeVar = VarPT <$> lowVar <?> "type variable"
22−typeList = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te
24+
23−typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN
25+typeList :: (Monad m) => ParsecT [Char] u m ParseType
24− ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } }
26+typeList = listPT <$> braces typeExpr
25−typeUnambiguous = typeList +|+ typeTuple
26
27
27−typeSimple = liftM VarPT var
28+typeTuple :: (Monad m) => ParsecT [Char] u m ParseType
29+typeTuple = do ts <- parens (commaSep typeExpr)
30+ return $ case ts of { [t] -> t ; _ -> tuplePT ts }
31+
32+typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType
33+typeUnambiguous = typeList <|> typeTuple
34+
35+typeSimple :: (Monad m) => ParsecT [Char] u m ParseType
36+typeSimple = VarPT <$> var
37+
38+typeApp :: (Monad m) => ParsecT [Char] u m ParseType
28typeApp = do name <- capVar
39typeApp = do name <- capVar
29− args <- star (typeSimple +|+ typeUnambiguous)
40+ args <- spacePrefix (typeUnambiguous <|> typeSimple)
30 return $ case args of
41 return $ case args of
31 [] -> VarPT name
42 [] -> VarPT name
32 _ -> ADTPT name args
43 _ -> ADTPT name args
33−
44+
45+typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
34typeExpr = do
46typeExpr = do
35− t1 <- typeVar +|+ typeApp +|+ typeUnambiguous
47+ t1 <- typeVar <|> typeApp <|> typeUnambiguous
36− arrow <- optional $ t ARROW
48+ whitespace ; arr <- optionMaybe arrow ; whitespace
37− case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr
49+ case arr of Just _ -> LambdaPT t1 <$> typeExpr
38− Nothing -> return t1
50+ Nothing -> return t1
39
51
40−typeConstructor = do name <- capVar
52+typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
41− args <- star (typeSimple +|+ typeUnambiguous)
53+typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
42− return $ (,) name args
43
54
55+datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
44datatype = do
56datatype = do
57+ reserved "data" <?> "datatype definition (data T = A | B | ...)"
45− t DATA ; name <- capVar ; args <- star lowVar ; assign
58+ forcedWS ; name <- capVar ; args <- spacePrefix lowVar
59+ whitespace ; string "=" ; whitespace
46− tcs <- sepBy1 (opParser (=="|")) typeConstructor
60+ tcs <- pipeSep1 typeConstructor
47 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
61 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
48
62
49−beta = VarT `liftM` guid
63+beta = liftM VarT guid
50
64
51toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames
65toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames
52 where argNames = map (("a"++) . show) [1..length args]
66 where argNames = map (("a"++) . show) [1..length args]
elm/src/Parse/Parser.hs+92−82
@@ -1,121 +1,131 @@
1−module Parser where
1+module Parser (toDefs) where
2
2
3import Ast
3import Ast
4−import Binop (binops)
4+import Control.Applicative ((<$>), (<*>))
5−import Combinators
6−import Control.Monad (liftM)
5+import Control.Monad
6+import Data.Char (isSymbol, isDigit)
7import Data.List (foldl')
7import Data.List (foldl')
8+import Text.Parsec hiding (newline,spaces)
9+
10+import ParseLib
11+import Patterns
12+import Binops
13+import ParseTypes
14+
8import Guid
15import Guid
9−import Lexer
10−import ParserLib
11−import ParseTypes (datatype)
12−import ParsePatterns
13−import Tokens
14import Types (Type (VarT))
16import Types (Type (VarT))
15
17
16-------- Basic Terms --------
18-------- Basic Terms --------
17
19
18−numTerm = do { whitespace; t <- item
20+numTerm :: (Monad m) => ParsecT [Char] u m Expr
19− ; case t of { NUMBER n -> return $ Number n; _ -> zero } }
21+numTerm = liftM (Number . read) (many1 digit) <?> "number"
20−strTerm = do { whitespace; t <- item
22+
21− ; case t of { STRING cs -> return $ Str cs
23+strTerm :: (Monad m) => ParsecT [Char] u m Expr
22− ; _ -> zero } }
24+strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
25+ backslashed <|> satisfy (/='"')
26+
27+varTerm :: (Monad m) => ParsecT [Char] u m Expr
28+varTerm = toVar <$> var <?> "variable"
23
29
24−varTerm = Var `liftM` var
30+toVar v = case v of "True" -> Boolean True
25−chrTerm = Chr `liftM` chr
31+ "False" -> Boolean False
32+ _ -> Var v
26
33
27−trueTerm = do { t TRUE; return $ Boolean True }
34+chrTerm :: (Monad m) => ParsecT [Char] u m Expr
28−falseTerm = do { t FALSE; return $ Boolean False }
35+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
36+ <?> "character"
29
37
30
38
31-------- Complex Terms --------
39-------- Complex Terms --------
32
40
33−listTerm = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET
41+listTerm = braces $ choice
34− ; return $ Range start end }) +|+
42+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
35− (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET
43+ ; Range lo <$> expr }
36− ; return $ list es })
44+ , list <$> commaSep expr
45+ ]
37
46
38−parensTerm = (do { t LPAREN; op <- anyOp; t RPAREN
47+parensTerm = parens $ choice
48+ [ do op <- anyOp
39− ; return . Lambda "x" . Lambda "y" $
49+ return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
40− Binop op (Var "x") (Var "y") }) +|+
50+ , do es <- commaSep expr
41− (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN
42− ; return $ case es of { [e] -> e; _ -> tuple es } })
51+ return $ case es of { [e] -> e; _ -> tuple es }
52+ ]
43
53
44−term = select [ numTerm
54+term = choice [ numTerm, strTerm, chrTerm
45− , strTerm
46 , accessible varTerm
55 , accessible varTerm
47− , chrTerm
48− , trueTerm
49− , falseTerm
50− , listTerm
56+ , listTerm, parensTerm ]
51− , accessible parensTerm
57+ <?> "basic term (number, variable, etc.)"
52− ]
53
58
54-------- Applications --------
59-------- Applications --------
55
60
56appExpr = do
61appExpr = do
57− tlist <- plus term
62+ tlist <- spaceSep1 term
58 return $ case tlist of
63 return $ case tlist of
59 t:[] -> t
64 t:[] -> t
60 t:ts -> foldl' App t ts
65 t:ts -> foldl' App t ts
61
66
62−
63−-------- Expressions with infix operators --------
64−
65−binaryExpr = binops appExpr anyOp
66−
67−
68-------- Normal Expressions --------
67-------- Normal Expressions --------
69
68
70−ifExpr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr
69+binaryExpr = binops appExpr anyOp
71− ; return $ If e1 e2 e3 }
72−
73−lambdaExpr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr
74− ; return $ foldr Lambda e vs }
75
70
71+ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
72+ reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
73+ reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
74+
75+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
76+ whitespace
77+ args <- spaceSep1 patternTerm
78+ whitespace ; arrow ; whitespace
79+ e <- expr
80+ return $ makeFunction args e
81+
76−assignExpr = whitespace >> assignExprNospace
82+assignExpr = do
77−assignExprNospace = do
83+ patterns <- spaceSep1 (patternTerm <?> "the definition of a variable (x = ...)")
78− p:ps <- plus patternTerm; assign; e <- expr
84+ whitespace; string "="; whitespace; exp <- expr
79− case p:ps of
85+ case patterns of
80− PVar x : _ -> return (x, foldr func e ps)
86+ PVar f : args -> return (f, makeFunction args exp)
81− where func PAnything e' = Lambda "_" e'
87+ [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then
82− func (PVar x) e' = Lambda x e'
88+ fail "matching tuples is not yet supported in this context"
83− func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')])
89+ else fail $ "Only tuples can be matched in this context, " ++
84−-- _ : [] -> return $ \hole -> Case e [(p,hole)]
90+ "not other abstract data types such as lists."
85− _ -> zero
91+ _ -> fail $ "Left-hand side of assign statement is not acceptable: " ++
92+ "only named variables, named functions, and tuples are okay."
86
93
87letExpr = do
94letExpr = do
88− t LET; brace <- optional $ t LBRACE
95+ reserved "let"
96+ brace <- optionMaybe . try $ do
97+ whitespace
98+ char '{' <?> "a set of definitions { x = ... ; y = ... }"
89 case brace of
99 case brace of
90− Nothing -> do f <- assignExpr; t IN; e <- expr; return (Let [f] e)
100+ Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
91− Just LBRACE -> do fs <- sepBy1 (t SEMI) assignExpr; t RBRACE; t IN;
101+ Let [f] <$> expr
102+ Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
103+ string "}" <?> "closing bracket '}'"
104+ whitespace; reserved "in"; whitespace; e <- expr
92− e <- expr; return (Let fs e)
105+ return (Let fs e)
93
106
94caseExpr = do
107caseExpr = do
95− t CASE; e <- expr; t OF; t LBRACE
108+ reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
96− cases <- sepBy1 (t SEMI)
109+ Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
97− (do { p <- patternExpr; t ARROW; e <- expr; return (p,e) })
110+ where case_ = do p <- patternExpr; whitespace; arrow; whitespace
98− t RBRACE
111+ (,) p <$> expr
99− return $ Case e cases
112+
100−
113+
101−-------- All Expressions --------
114+expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
102−
115+
103−expr = select [ letExpr
116+def = do (f,e) <- assignExpr
104− , binaryExpr
105− , ifExpr
106− , caseExpr
107− , lambdaExpr
108− ]
109−
110−def = do (f,e) <- assignExprNospace
111 return ([f], [e], guid >>= \x -> return [VarT x])
117 return ([f], [e], guid >>= \x -> return [VarT x])
112
118
119+defs1 = do optional freshLine
120+ d <- datatype <|> def
121+ (d:) <$> many (try (try freshLine >> (datatype <|> def)))
122+
113defs = do
123defs = do
114− (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)
124+ (fss,ess,tss) <- unzip3 <$> defs1
115 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
125 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
116− star $ sat (==NEWLINE) +|+ sat (==SPACES)
126+ optional freshLine ; optional spaces ; eof
117 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
127 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
118
128
119−err = "Parse Error: Better error messages to come!"
120−toExpr = extractResult err . parse expr
121−toDefs = extractResult err . parse defs . (NEWLINE:)
129+toDefs source = case parse defs "" source of
130+ Right result -> Right result
131+ Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/ParserLib.hsdeleted−38
@@ -1,38 +0,0 @@
1−module ParserLib where
2−
3−import Ast
4−import Combinators
5−import Data.Char (isUpper,isLower)
6−import Control.Monad (liftM,guard)
7−import Tokens
8−
9−varNoSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } }
10−var = whitespace >> varNoSpace
11−capVar = do whitespace; t <- item
12− case t of { ID (v:vs) -> guard (isUpper v) >> return (v:vs) ; _ -> zero }
13−lowVar = do whitespace; t <- item
14− case t of { ID (v:vs) -> guard (isLower v) >> return (v:vs) ; _ -> zero }
15−
16−chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } }
17−
18−tNoSpace token = sat (==token)
19−tWithSpace token = forcedWS >> sat (==token)
20−t token = whitespace >> sat (==token)
21−
22−forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space
23− where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES)
24−whitespace = optional forcedWS
25−
26−accessible exp = do
27− e <- exp
28− access <- optional $ opParserNospace (==".")
29− case access of
30− Just "." -> accessible (Access e `liftM` var)
31− Nothing -> return e
32−
33−opParserNospace pred =
34− do { t <- item
35− ; case t of { OP op -> if pred op then return op else zero; _ -> zero } }
36−opParser pred = whitespace >> opParserNospace pred
37−anyOp = opParser (const True)
38−assign = opParser (=="=")
elm/src/Parse/Patterns.hsnew file+34
@@ -0,0 +1,34 @@
1+module Patterns (patternTerm, patternExpr, makeFunction) where
2+
3+import Ast
4+import Data.Char (isUpper)
5+import Control.Applicative ((<$>))
6+import Control.Monad
7+import Text.Parsec
8+import ParseLib
9+
10+makeFunction args body = foldr func body args
11+ where func PAnything e = Lambda "_" e
12+ func (PVar x) e = Lambda x e
13+ func p e = "t" `Lambda` Case (Var "t") [(p,e)]
14+
15+patternBasic :: Monad m => ParsecT [Char] u m Pattern
16+patternBasic =
17+ choice [ char '_' >> return PAnything
18+ , do x@(c:_) <- var
19+ if isUpper c then PData x <$> spacePrefix patternTerm
20+ else return $ PVar x
21+ ]
22+
23+patternTuple :: Monad m => ParsecT [Char] u m Pattern
24+patternTuple = do ps <- parens (commaSep patternExpr)
25+ return $ case ps of { [p] -> p; _ -> ptuple ps }
26+
27+patternList :: Monad m => ParsecT [Char] u m Pattern
28+patternList = plist <$> braces (commaSep patternExpr)
29+
30+patternTerm :: Monad m => ParsecT [Char] u m Pattern
31+patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
32+
33+patternExpr :: Monad m => ParsecT [Char] u m Pattern
34+patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"
elm/src/Parse/Tokens.hsdeleted−17
@@ -1,17 +0,0 @@
1−
2−module Tokens where
3−
4−data Token =
5− NUMBER Int | ID String | TYPE String |
6− CHAR Char | STRING String |
7− LAMBDA | ARROW | OP String | DOT2 | UNDERSCORE |
8− LPAREN | RPAREN |
9− LBRACE | RBRACE |
10− LBRACKET | RBRACKET |
11− COMMA | SEMI |
12− TRUE | FALSE |
13− IF | THEN | ELSE |
14− CASE | OF | LET | IN |
15− SPACES | NEWLINE | DATA
16− deriving (Show, Eq)
17−