Tidy up error reporting (still based on error for now, though)

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
+

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 "}}}"
 

fco2/Makefile

@@ -4,6 +4,7 @@ all: $(targets)
 
 sources = \
 	AST.hs \
+	Errors.hs \
 	Main.hs \
 	Metadata.hs \
 	Parse.hs \

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
-

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
 --}}}