From 88ea5303ff3661556acd8aaa848edec0fc1584bb Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Sun, 18 Mar 2007 00:48:02 +0000 Subject: [PATCH] Tidy up error reporting (still based on error for now, though) --- fco2/Errors.hs | 26 ++++++++++++++++++++++++++ fco2/Main.hs | 2 +- fco2/Makefile | 1 + fco2/Metadata.hs | 25 +++++++++++-------------- fco2/Parse.hs | 46 +++++++++++++++++++++++++++------------------- 5 files changed, 66 insertions(+), 34 deletions(-) create mode 100644 fco2/Errors.hs diff --git a/fco2/Errors.hs b/fco2/Errors.hs new file mode 100644 index 0000000..9a6ffc1 --- /dev/null +++ b/fco2/Errors.hs @@ -0,0 +1,26 @@ +module Errors where + +import Data.Generics +import Control.Monad.Error + +import Metadata + +data OccError = OccError { + errorText :: String, + errorPos :: Maybe OccSourcePos + } + deriving (Show, Eq, Typeable, Data) + +type OccErrorT m a = ErrorT OccError m a + +die :: Monad m => String -> m a +die s = error $ "\n\nError:\n" ++ s + +dieInternal :: Monad m => String -> m a +dieInternal s = die $ "Internal error: " ++ s + +dieP :: Monad m => Meta -> String -> m a +dieP m s = case findSourcePos m of + Just (OccSourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s + Nothing -> die s + diff --git a/fco2/Main.hs b/fco2/Main.hs index 89ac4dc..907fd77 100644 --- a/fco2/Main.hs +++ b/fco2/Main.hs @@ -50,7 +50,7 @@ main = do progress "}}}" progress "{{{ Parser" - let (ast, state) = parseSource preprocessed fn + (ast, state) <- parseSource preprocessed fn progress $ pshow ast progress "}}}" diff --git a/fco2/Makefile b/fco2/Makefile index 4d210df..27a8de3 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -4,6 +4,7 @@ all: $(targets) sources = \ AST.hs \ + Errors.hs \ Main.hs \ Metadata.hs \ Parse.hs \ diff --git a/fco2/Metadata.hs b/fco2/Metadata.hs index fde8249..c8cedc7 100644 --- a/fco2/Metadata.hs +++ b/fco2/Metadata.hs @@ -7,24 +7,21 @@ import Data.List type Meta = [Metadatum] -data Metadatum = - SourcePos String Int Int +data OccSourcePos = OccSourcePos String Int Int deriving (Show, Eq, Typeable, Data) -findSourcePos :: Meta -> Maybe Metadatum -findSourcePos ms = find (\x -> case x of SourcePos _ _ _ -> True - otherwise -> False) ms +data Metadatum = + MdSourcePos OccSourcePos + deriving (Show, Eq, Typeable, Data) + +findSourcePos :: Meta -> Maybe OccSourcePos +findSourcePos ms + = do sps <- find (\x -> case x of MdSourcePos _ -> True + otherwise -> False) ms + return $ case sps of MdSourcePos sp -> sp formatSourcePos :: Meta -> String formatSourcePos m = case findSourcePos m of - Just (SourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">" + Just (OccSourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">" Nothing -> "" -die :: Monad m => String -> m a -die s = error $ "error: " ++ s - -dieP :: Monad m => Meta -> String -> m a -dieP m s = case findSourcePos m of - Just (SourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s - Nothing -> die $ "unknown position: " ++ s - diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 2fe5d47..56f1ece 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -1,6 +1,8 @@ -- vim:foldmethod=marker -- Parse occam code +-- FIXME: Can probably parse indentation using try and char ' ', watching the position? + module Parse (readSource, parseSource) where import Data.List @@ -13,9 +15,10 @@ import Numeric (readHex) import qualified AST as A import Metadata import ParseState +import Errors --{{{ setup stuff for Parsec -type OccParser a = GenParser Char ParseState a +type OccParser = GenParser Char ParseState occamStyle = emptyDef @@ -117,14 +120,14 @@ lexer = P.makeTokenParser occamStyle -- XXX replace whitespace with something that doesn't eat \ns whiteSpace = P.whiteSpace lexer -lexeme = P.lexeme lexer -symbol = P.symbol lexer -natural = P.natural lexer -parens = P.parens lexer -semi = P.semi lexer -identifier= P.identifier lexer -reserved = P.reserved lexer -reservedOp= P.reservedOp lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +natural = P.natural lexer +parens = P.parens lexer +semi = P.semi lexer +identifier = P.identifier lexer +reserved = P.reserved lexer +reservedOp = P.reservedOp lexer --}}} --{{{ symbols @@ -218,10 +221,15 @@ eol = symbol "@" --}}} --{{{ helper functions +getSourcePos :: OccParser OccSourcePos +getSourcePos + = do pos <- getPosition + return $ OccSourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos) + md :: OccParser Meta -md = do - pos <- getPosition - return $ [SourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos)] +md + = do pos <- getSourcePos + return [MdSourcePos pos] maybeSubscripted :: String -> OccParser a -> (Meta -> A.Subscript -> a -> a) -> OccParser a maybeSubscripted prodName inner subscripter @@ -255,7 +263,7 @@ findName :: A.Name -> OccParser A.Name findName n@(A.Name m nt s) = do st <- getState let s' = case lookup s (localNames st) of - Nothing -> error $ "name " ++ s ++ " is not defined" + Nothing -> die $ "Name " ++ s ++ " is not defined" Just (NameInfo _ n) -> n return $ A.Name m nt s' @@ -277,7 +285,7 @@ scopeOut n@(A.Name m nt s) = do st <- getState let lns' = case localNames st of (s, _):ns -> ns - otherwise -> error "scopeOut trying to scope out the wrong name" + otherwise -> dieInternal "scopeOut trying to scope out the wrong name" setState $ st { localNames = lns' } -- FIXME: Do these with generics? (going carefully to avoid nested code blocks) @@ -715,7 +723,7 @@ formalList markTypes :: Meta -> [(Maybe A.Type, A.Name)] -> A.Formals markTypes _ [] = [] - markTypes _ ((Nothing, _):_) = error "Formal list must start with a type" + markTypes _ ((Nothing, _):_) = die "Formal list must start with a type" markTypes m ((Just ft, fn):is) = markRest m ft [fn] is markRest :: Meta -> A.Type -> [A.Name] -> [(Maybe A.Type, A.Name)] -> A.Formals @@ -1114,10 +1122,10 @@ readSource fn = do --}}} --{{{ interface for other modules -parseSource :: String -> String -> (A.Process, ParseState) +parseSource :: String -> String -> IO (A.Process, ParseState) parseSource prep sourceFileName - = case (runParser sourceFile emptyState sourceFileName prep) of - Left err -> error ("Parsing error: " ++ (show err)) - Right result -> result + = case runParser sourceFile emptyState sourceFileName prep of + Left err -> die $ "Parse error: " ++ show err + Right result -> return result --}}}