@@ -2,6 +2,7 @@
22module ParseLib where
33
44import Ast
5+import Control.Applicative ((<$>))
56import Control.Monad
67import Data.Char (isSymbol)
78import Text.Parsec hiding (newline,spaces)
@@ -17,7 +18,7 @@ backslashed = do { char '\\'; c <- anyChar
1718 ; return . read $ ['\'','\\',c,'\''] }
1819
1920var :: (Monad m) => ParsecT [Char] u m String
20−var = makeVar $ letter <|> char '_'
21+var = makeVar (letter <|> char '_' <?> "variable")
2122
2223lowVar :: (Monad m) => ParsecT [Char] u m String
2324lowVar = makeVar (lower <?> "lower case variable")
@@ -26,7 +27,7 @@ capVar = makeVar (upper <?> "upper case variable")
2627
2728makeVar p = do
2829 c <- p
29− cs <- many $ alphaNum <|> char '_' <|> char '\''
30+ cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
3031 guard $ c:cs `notElem` reserved
3132 return $ c:cs
3233
@@ -34,64 +35,86 @@ makeVar p = do
3435anyOp :: (Monad m) => ParsecT [Char] u m String
3536anyOp = betwixt '`' '`' var <|>
3637 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
37− guard (op `notElem` [ "=", "..", "->" ])
38+ guard (op `notElem` [ "=", "..", "->", "--" ])
3839 return op) <?> "infix operator"
3940
40−lexeme p = do whitespace ; p
41+arrow :: (Monad m) => ParsecT [Char] u m String
42+arrow = string "->" <|> string "\8594" <?> "arrow (->)"
4143
42−symbol :: (Monad m) => String -> ParsecT [Char] u m String
43−symbol s = whitespace >> string s
44+commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
45+commaSep p = do
46+ x <- optionMaybe p
47+ case x of
48+ Just a -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
49+ Nothing -> return []
4450
45−arrow :: (Monad m) => ParsecT [Char] u m String
46−arrow = symbol "->" <|> symbol "\8594"
51+semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
52+semiSep1 p = do a <- p
53+ (a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
54+
55+pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
56+pipeSep1 p = do a <- p
57+ (a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
4758
48−commaSep p = p `sepBy` lexeme (char ',')
59+spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
60+spaceSep1 p = do a <- p
61+ (a:) <$> many (try (forcedWS >> p))
4962
50−
5163betwixt a b c = do char a ; out <- c
5264 char b <?> "closing '" ++ [b] ++ "'" ; return out
53−betwixtSpcs a b c = do char a ; whitespace ; out <- c ; whitespace
54− char b <?> "closing '" ++ [b] ++ "'" ; return out
5565
56−listOf p = betwixtSpcs '[' ']' $ p `sepBy` lexeme (char ',')
66+surround a z name p = do
67+ char a ; whitespace ; a <- p ; whitespace
68+ char z <?> unwords ["closing", name, show z]
69+ return a
70+
71+braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
72+braces = surround '[' ']' "brace"
73+
74+parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
75+parens = surround '(' ')' "paren"
76+
77+brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
78+brackets = surround '{' '}' "bracket"
5779
5880accessible expr = do
5981 e <- expr
60− access <- optionMaybe (char '.')
82+ access <- optionMaybe . try $
83+ (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")
6184 case access of
62− Just '.' -> accessible (Access e `liftM` var)
85+ Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")
6386 Nothing -> return e
6487
6588
6689spaces :: (Monad m) => ParsecT [Char] u m String
67−spaces = many1 ((multiComment <|> string " ") >> return ' ') <?> "spaces"
90+spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
6891
6992forcedWS :: (Monad m) => ParsecT [Char] u m [String]
7093forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
7194 where nl_space = try $ many1 newline >> spaces
7295
7396whitespace :: (Monad m) => ParsecT [Char] u m ()
74−whitespace = optional forcedWS <?> "whitespace"
97+whitespace = optional forcedWS <?> ""
7598
7699freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
77−freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> "fresh line"
100+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
78101 where space_nl = try $ spaces >> many1 newline
79102
80103newline :: (Monad m) => ParsecT [Char] u m String
81−newline = simpleNewline <|> lineComment <?> "newline"
104+newline = simpleNewline <|> lineComment <?> ""
82105
83106simpleNewline :: (Monad m) => ParsecT [Char] u m String
84107simpleNewline = try (string "\r\n") <|> string "\n"
85108
86109lineComment :: (Monad m) => ParsecT [Char] u m String
87−lineComment = do try $ string "--"
110+lineComment = do try (string "--")
88111 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
89112
90113multiComment :: (Monad m) => ParsecT [Char] u m String
91−multiComment = do { try $ string "{-"; closeComment }
114+multiComment = do { try (string "{-"); closeComment }
92115
93116closeComment :: (Monad m) => ParsecT [Char] u m String
94117closeComment = manyTill anyChar . choice $
95− [ try $ string "-}"
118+ [ try (string "-}") <?> "close comment"
96119 , do { try $ string "{-"; closeComment; closeComment }
97120 ]