Better errors

1 files changed, 34 insertions, 15 deletions

diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index 92bc08f..e730313 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -14,6 +14,8 @@ import Data.Maybe
 
 import Sil.Error
 
+instance getPos ParsePosition where getPos pp = pp
+
 :: *ParseState a =
 	{ ps_line    :: Int
 	, ps_input   :: [ParseInput a]
@@ -56,27 +58,31 @@ dropCommit ps = {ps & ps_commits=tl ps.ps_commits}
 restoreCommit :: (ParseState a) -> ParseState a
 restoreCommit ps=:{ps_commits=[c:cs]} = iter (ps.ps_pos - c) tokenBack {ps & ps_commits=cs}
 
-instance Functor (Parser a) where
+instance Functor (Parser a)
+where
 	fmap f m = liftM f m
 
-instance Applicative (Parser a) where
+instance Applicative (Parser a)
+where
 	pure a     = Parser \st -> (Ok a, st)
 	(<*>) sf p = ap sf p
 
-instance Monad (Parser a) where
+instance Monad (Parser a)
+where
 	bind p f = Parser \st -> case runParser p (commit st) of
 		(Error e, st) -> (Error e, restoreCommit st)
 		(Ok r,    st) -> case runParser (f r) st of
 			(Ok r,    st) -> (Ok r,    dropCommit    st)
 			(Error e, st) -> (Error e, restoreCommit st)
 
-instance Alternative (Parser a) where
+instance Alternative (Parser a)
+where
 	empty       = Parser \st -> (Error $ UnknownError "empty in Parser", st)
 	(<|>) p1 p2 = Parser \st -> case runParser p1 (commit st) of
 		(Ok r,     st) -> (Ok r, dropCommit st)
 		(Error e1, st) -> case runParser p2 (commit $ restoreCommit st) of
 			(Ok r,     st) -> (Ok r, dropCommit st)
-			(Error e2, st) -> (Error e2, restoreCommit st)
+			(Error e2, st) -> (Error $ max e1 e2, restoreCommit st)
 
 instance name String where name s = s
 
@@ -87,13 +93,16 @@ runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a
 runParser (Parser f) i = f i
 
 getPosition :: Parser a ParsePosition
-getPosition = Parser \st=:{ps_line} -> (Ok {pp_line=ps_line}, st)
+getPosition = Parser \st=:{ps_line,ps_pos} -> (Ok {pp_line=ps_line,pp_token=ps_pos}, st)
 
 (<?>) :: (Parser a b) Error -> Parser a b
 (<?>) p e = Parser \i -> case runParser p i of
 	(Error _, st) -> (Error e, st)
 	o             -> o
 
+(<#>) :: (Parser a b) String -> Parser a b | toString a
+(<#>) p what = p <|> (getPosition >>= \pos -> peek >>= \e -> Parser \st -> (Error $ P_Expected (errpos pos) what e, st))
+
 fail :: Parser a b
 fail = empty
 
@@ -128,18 +137,28 @@ where
 		(Error e, st) -> (Error e, st)
 		(Ok r,    st) -> (Ok r, st)
 
-item :: a -> Parser a a | ==, name a
-item a = satisfy ((==) a) <?> P_Expected (name a)
+item :: a -> Parser a a | ==, name, toString a
+item a = satisfy ((==) a) <#> name a
 
-list :: [a] -> Parser a [a] | ==, name a
+list :: [a] -> Parser a [a] | ==, name, toString a
 list as = mapM item as
 
-seplist :: a (Parser a b) -> Parser a [b] | ==, name a
-seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
-	<|> liftM pure p
+seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a
+seplist sep p = liftM2 (\e es -> [e:es]) p (many (p <* item sep))
 	<|> pure empty
 
-eof :: Parser a ()
-eof = Parser \st -> case nextToken st of
+seplistUntil :: a a (Parser a b) -> Parser a [b] | ==, name, toString a
+seplistUntil end sep p =
+	liftM2 (\e es -> [e:es]) p ((item sep *> p) until` (item end))
+	<|> liftM pure (p <* item end)
+	<|> (pure empty <* item end)
+where
+	(until`) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
+	(until`) p1 guard = (p1 until guard) >>= \xs -> case xs of
+		[] -> fail
+		xs -> pure xs
+
+eof :: Parser a () | toString a
+eof = Parser \st=:{ps_line,ps_pos} -> case nextToken st of
 	(Nothing, st) -> (Ok (), st)
-	(t, st)       -> (Error $ P_Expected "eof", st)
+	(Just t, st)  -> (Error $ P_Expected (errpos {pp_line=ps_line,pp_token=ps_pos}) "eof" t, st)