From c5c4788b282a371fdc989e2d13430701f3457441 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Sun, 30 Jul 2017 11:35:16 +0200 Subject: Better errors --- Sil/Error.dcl | 11 +++++++++-- Sil/Error.icl | 44 +++++++++++++++++++++++++++++++++++++++++--- Sil/Parse.icl | 47 ++++++++++++++++++++++------------------------- Sil/Util/Parser.dcl | 16 ++++++++++------ Sil/Util/Parser.icl | 49 ++++++++++++++++++++++++++++++++++--------------- 5 files changed, 116 insertions(+), 51 deletions(-) (limited to 'Sil') diff --git a/Sil/Error.dcl b/Sil/Error.dcl index c37e445..bdfa390 100644 --- a/Sil/Error.dcl +++ b/Sil/Error.dcl @@ -1,7 +1,9 @@ definition module Sil.Error from StdFile import class <<< -from StdOverloaded import class toString +from StdOverloaded import class toString, class < + +from Data.Maybe import :: Maybe from Sil.Syntax import :: Expression from Sil.Types import :: Type @@ -9,10 +11,12 @@ from Sil.Util.Parser import :: ParsePosition, class getPos :: ErrorPosition +instance < ErrorPosition + :: Error // Parser errors = E.a: P_Invalid String a & toString a - | P_Expected String + | E.a: P_Expected ErrorPosition String a & toString a // Type errors | T_IllegalApplication Type Type | T_IllegalField String Type @@ -39,5 +43,8 @@ from Sil.Util.Parser import :: ParsePosition, class getPos instance toString Error instance <<< Error +instance < Error // Based on position in file, to choose the furthest error in the parser + +getErrorPosition :: Error -> Maybe ErrorPosition errpos :: a -> ErrorPosition | getPos a diff --git a/Sil/Error.icl b/Sil/Error.icl index 36a614b..fde96ee 100644 --- a/Sil/Error.icl +++ b/Sil/Error.icl @@ -1,8 +1,10 @@ implementation module Sil.Error import StdFile +import StdInt import StdString +import Data.Maybe import Text import Sil.Syntax @@ -10,9 +12,12 @@ import Sil.Types import Sil.Util.Parser :: ErrorPosition = - { ep_line :: Int + { ep_line :: Int + , ep_token :: Int } +instance < ErrorPosition where < p1 p2 = p1.ep_token < p2.ep_token + instance toString ErrorPosition where toString ep = ep.ep_line <+ ":\t" @@ -20,7 +25,7 @@ where instance toString Error where toString (P_Invalid w tk) = "\tInvalid token '" <+ tk <+ "' while parsing a " <+ w <+ "." - toString (P_Expected s) = "\tExpected " <+ s <+ "." + toString (P_Expected p s h) = p <+ "Expected " <+ s <+ " near '" <+ h <+ "'." toString (T_IllegalApplication ft et) = "\tCannot apply a " <+ et <+ " to a " <+ ft <+ "." toString (T_IllegalField f t) = "\tIllegal field '" <+ f <+ "' on type " <+ t <+ "." toString (T_TooHighTupleArity i) = "\tToo high tuple arity " <+ i <+ " (maximum is 32)." @@ -43,5 +48,38 @@ where instance <<< Error where <<< f e = f <<< toString e <<< "\r\n" +instance < Error +where + < _ (UnknownError _) = False + < (UnknownError _) _ = True + < e1 e2 = case (getErrorPosition e1, getErrorPosition e2) of + (Just p1, Just p2) -> p1 < p2 + (_ , Nothing) -> False + (Nothing, _ ) -> True + +getErrorPosition :: Error -> Maybe ErrorPosition +getErrorPosition (P_Invalid w tk) = Nothing +getErrorPosition (P_Expected p s h) = Just p +getErrorPosition (T_IllegalApplication ft et) = Nothing +getErrorPosition (T_IllegalField f t) = Nothing +getErrorPosition (T_TooHighTupleArity i) = Nothing +getErrorPosition Ck_NoMainFunction = Nothing +getErrorPosition (Ck_MainFunctionInvalidType p t) = Just p +getErrorPosition (Ck_DuplicateFunctionName p n) = Just p +getErrorPosition (Ck_DuplicateLocalName p f arg) = Just p +getErrorPosition (Ck_ReturnExpressionFromVoid p f) = Just p +getErrorPosition (Ck_NoReturnFromNonVoid p f) = Just p +getErrorPosition (Ck_LocalVoid f l) = Nothing +getErrorPosition (Ck_BasicGlobal p g) = Just p +getErrorPosition (C_UndefinedName n) = Nothing +getErrorPosition (C_UndefinedField f) = Nothing +getErrorPosition C_VariableLabel = Nothing +getErrorPosition C_FunctionOnStack = Nothing +getErrorPosition (C_CouldNotDeduceType e) = Nothing +getErrorPosition (C_TypeMisMatch t e u) = Nothing +getErrorPosition (C_BasicInitWithoutValue n) = Nothing +getErrorPosition (UnknownError e) = Nothing + errpos :: a -> ErrorPosition | getPos a -errpos x = {ep_line=(getPos x).pp_line} +errpos x = {ep_line=p.pp_line, ep_token=p.pp_token} +where p = getPos x diff --git a/Sil/Parse.icl b/Sil/Parse.icl index 6a3999d..2c8272d 100644 --- a/Sil/Parse.icl +++ b/Sil/Parse.icl @@ -141,17 +141,17 @@ parse = fst o runParser program o makeParseState program :: Parser Token Program program = many initialisation >>= \globss -> - some function >>= \fs -> - eof $> - {p_globals=flatten globss, p_funs=fs} + function until eof >>= \fs -> + pure {p_globals=flatten globss, p_funs=reverse fs} function :: Parser Token Function function = type >>= \t -> getPosition >>= \pos -> name >>= \n -> - parenthised (seplist TComma arg) >>= \args -> - braced codeblock >>= \cb -> pure + item TParenOpen *> + seplistUntil TParenClose TComma arg >>= \args -> + codeblock >>= \cb -> pure { f_type = t , f_name = n , f_args = args @@ -160,8 +160,10 @@ function = } codeblock :: Parser Token CodeBlock -codeblock = many initialisation >>= \is -> - many statement >>= \s -> +codeblock = + item TBraceOpen *> + many initialisation >>= \is -> + statement until (item TBraceClose) >>= \s -> pure {cb_init=flatten is, cb_content=s} initialisation :: Parser Token [Initialisation] @@ -182,7 +184,7 @@ statement = <|> if` pos <|> while pos <|> machinecode pos - ) + ) <#> "statement" where declaration :: ParsePosition -> Parser Token Statement declaration p = liftM2 (Declaration p) name (item TAssign *> expression <* item TSemicolon) @@ -197,20 +199,20 @@ where if` :: ParsePosition -> Parser Token Statement if` p = item TIf *> parenthised expression >>= \cond -> - braced codeblock >>= \iftrue -> + codeblock >>= \iftrue -> many elseif >>= \elseifs -> - optional (item TElse *> braced codeblock) >>= \iffalse -> + optional (item TElse *> codeblock) >>= \iffalse -> pure $ If p [(cond,iftrue):elseifs] iffalse where elseif = list [TElse, TIf] *> parenthised expression >>= \cond -> - braced codeblock >>= \block -> + codeblock >>= \block -> pure (cond, block) while :: ParsePosition -> Parser Token Statement while p = item TWhile *> parenthised expression >>= \cond -> - braced codeblock >>= \do -> + codeblock >>= \do -> pure $ While p cond do expression :: Parser Token Expression @@ -244,7 +246,7 @@ where noInfix :: Parser Token Expression noInfix - = liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose) + = liftM2 App name (item TParenOpen *> seplistUntil TParenClose TComma expression) <|> op TTilde Neg <|> op TExclamation Not <|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field) @@ -258,29 +260,27 @@ where simpleExpr :: Parser Token Expression simpleExpr = liftM Literal literal <|> liftM Name name - <|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es) <|> flip List [] o pure <$> bracked type <|> List Nothing <$> bracked (seplist TComma expression) - <|> parenthised expression + <|> (item TParenOpen *> seplistUntil TParenClose TComma expression >>= \es -> pure $ case es of [x] -> x; _ -> Tuple (length es) es) name :: Parser Token Name -name = liftM (\(TName s) -> s) $ satisfy isName P_Expected "name" +name = (\(TName n) -> n) <$> satisfy isName <#> "name" where isName (TName _) = True isName _ = False arg :: Parser Token Arg -arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name}) - P_Expected "argument" +arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name}) <#> "argument" type :: Parser Token Type type = simpletype "Bool" TBool <|> simpletype "Int" TInt <|> simpletype "Void" TVoid - <|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts) + <|> (parenthised (min1seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts) <|> TList <$> bracked type - P_Expected "type" + <#> "type" where simpletype s t = item (TName s) $> t @@ -297,11 +297,8 @@ parenthised p = item TParenOpen *> p <* item TParenClose bracked :: (Parser Token a) -> Parser Token a bracked p = item TBrackOpen *> p <* item TBrackClose -braced :: (Parser Token a) -> Parser Token a -braced p = item TBraceOpen *> p <* item TBraceClose - -min2seplist :: a (Parser a b) -> Parser a [b] | ==, name a -min2seplist sep val = +min1seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a +min1seplist sep val = val >>= \v1 -> item sep *> seplist sep val >>= \vs -> diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl index e5d1cce..14dc022 100644 --- a/Sil/Util/Parser.dcl +++ b/Sil/Util/Parser.dcl @@ -1,6 +1,6 @@ definition module Sil.Util.Parser -from StdOverloaded import class == +from StdOverloaded import class ==, class toString from Control.Applicative import class Applicative, class Alternative from Control.Monad import class Monad @@ -13,10 +13,12 @@ from Sil.Error import :: Error :: *ParseState a :: ParsePosition = - { pp_line :: Int + { pp_line :: Int + , pp_token :: Int } class getPos a :: a -> ParsePosition +instance getPos ParsePosition :: ParseInput a = PI_NewLine @@ -37,13 +39,15 @@ instance name String runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a) getPosition :: Parser a ParsePosition () :: (Parser a b) Error -> Parser a b +(<#>) :: (Parser a b) String -> Parser a b | toString a fail :: Parser a b top :: Parser a a peek :: Parser a a satisfy :: (a -> Bool) -> Parser a a check :: (a -> Bool) -> Parser a a (until) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b] -item :: a -> Parser a a | ==, name a -list :: [a] -> Parser a [a] | ==, name a -seplist :: a (Parser a b) -> Parser a [b] | ==, name a -eof :: Parser a () +item :: a -> Parser a a | ==, name, toString a +list :: [a] -> Parser a [a] | ==, name, toString a +seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a +seplistUntil :: a a (Parser a b) -> Parser a [b] | ==, name, toString a +eof :: Parser a () | toString a 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) -- cgit v1.2.3