From c97d1d00c86d7a583274ac7a9190735253c023ee Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 18 Sep 2007 10:17:38 +0000 Subject: [PATCH] Changed the error type from String to ErrorReport throughout the code ErrorReport is of type (Maybe Meta, String), thereby adding an optional code position to error messages. Die has been changed so that die and dieP are now implemented in terms of dieReport (:: ErrorReport -> m a). This involved changing less code than changing die to be of type ErrorReport -> m a. All that had to be changed directly was that Die instances now implement dieReport instead of die. Any bits of code that "caught" errors has been changed so that it handles ErrorReport instead of String. This ErrorReport is eventually, in Main, passed to dieIO, which will soon be changed to read the file in and provide the context. Accordingly, MonadIO m has been added as a constraint to dieIO, and dieInternal has been changed to no longer use dieIO (because really we can't add the MonadIO constraint to dieInternal). Various error messages have been changed. Notably, all instances of fail in ParseOccam have been changed to use die or, wherever possible, dieP. A similar thing has been done in EvalConstants and EvalLiterals. --- Main.hs | 8 ++++--- backends/GenerateC.hs | 2 +- common/CompState.hs | 4 ++-- common/Errors.hs | 21 ++++++++++++---- common/EvalConstants.hs | 48 ++++++++++++++++++------------------- common/EvalLiterals.hs | 19 ++++++++------- common/Metadata.hs | 8 +++---- common/Pass.hs | 6 ++--- common/TestUtil.hs | 7 +++--- frontends/ParseOccam.hs | 33 ++++++++++++------------- frontends/RainPassesTest.hs | 2 +- frontends/RainTypes.hs | 2 +- frontends/RainTypesTest.hs | 3 ++- 13 files changed, 90 insertions(+), 73 deletions(-) diff --git a/Main.hs b/Main.hs index 122a527..fc5d0f4 100644 --- a/Main.hs +++ b/Main.hs @@ -68,7 +68,7 @@ optMode s ps "parse" -> return ModeParse "compile" -> return ModeCompile "post-c" -> return ModePostC - _ -> dieIO $ "Unknown mode: " ++ s + _ -> dieIO (Nothing, "Unknown mode: " ++ s) return $ ps { csMode = mode } optBackend :: String -> OptFunc @@ -76,7 +76,7 @@ optBackend s ps = do backend <- case s of "c" -> return BackendC "cppcsp" -> return BackendCPPCSP - _ -> dieIO $ "Unknown backend: " ++ s + _ -> dieIO (Nothing, "Unknown backend: " ++ s) return $ ps { csBackend = backend } optFrontend :: String -> OptFunc @@ -84,7 +84,7 @@ optFrontend s ps = do frontend <- case s of "occam" -> return FrontendOccam "rain" -> return FrontendRain - _ -> dieIO $ "Unknown frontend: " ++ s + _ -> dieIO (Nothing, "Unknown frontend: " ++ s) return $ ps { csFrontend = frontend } optVerbose :: OptFunc @@ -148,6 +148,8 @@ compile fn FrontendOccam -> preprocessOccamProgram fn >>= parseOccamProgram FrontendRain -> parseRainProgram fn debugAST ast1 + shownAST <- pshowCode ast1 + liftIO $ putStr shownAST debug "}}}" showWarnings diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 0617f98..b1e6aa9 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -69,7 +69,7 @@ identifyParProcs = everywhereM (mkM doProcess) type CGen = WriterT [String] PassM instance Die CGen where - die = throwError + dieReport = throwError --}}} --{{{ generator ops diff --git a/common/CompState.hs b/common/CompState.hs index 473f5aa..b744e25 100644 --- a/common/CompState.hs +++ b/common/CompState.hs @@ -253,5 +253,5 @@ diePC m str = str >>= (dieP m) dieC :: (CSM m, Die m) => m String -> m a dieC str = str >>= die -throwErrorC :: (CSM m,MonadError String m) => m String -> m a -throwErrorC str = str >>= throwError +throwErrorC :: (CSM m,MonadError ErrorReport m) => (Maybe Meta,m String) -> m a +throwErrorC (m,str) = str >>= ((curry throwError) m) diff --git a/common/Errors.hs b/common/Errors.hs index 5f2cb08..59be590 100644 --- a/common/Errors.hs +++ b/common/Errors.hs @@ -19,25 +19,36 @@ with this program. If not, see . -- | Error handling and reporting. module Errors where +import Control.Monad.Error +import Control.Monad.Trans + import qualified AST as A import Metadata +type ErrorReport = (Maybe Meta, String) + +instance Error ErrorReport where + strMsg s = (Nothing, s) + -- | Class of monads that can fail. class Monad m => Die m where + dieReport :: ErrorReport -> m a + -- | Fail, giving an error message. die :: String -> m a + die s = dieReport (Nothing, s) -- | Fail, giving a position and an error message. dieP :: Die m => Meta -> String -> m a - dieP m s = die $ show m ++ ": " ++ s + dieP m s = dieReport (Just m,s) -- | Wrapper around error that gives nicer formatting. -dieIO :: Monad m => String -> m a -dieIO s = error $ "\n\nError: " ++ s ++ "\n" +dieIO :: (Monad m, MonadIO m) => ErrorReport -> m a +dieIO (_,s) = error $ "\n\nError: " ++ s ++ "\n" -- | Fail after an internal error. -dieInternal :: Monad m => String -> m a -dieInternal s = dieIO $ "Internal error: " ++ s +dieInternal :: Monad m => ErrorReport -> m a +dieInternal (m,s) = error $ "\n\n" ++ (maybe "" show m) ++ "Internal error: " ++ s -- | Extract a value from a Maybe type, dying with the given error if it's Nothing. checkJust :: Die m => String -> Maybe t -> m t diff --git a/common/EvalConstants.hs b/common/EvalConstants.hs index 21035b7..3c51cc6 100644 --- a/common/EvalConstants.hs +++ b/common/EvalConstants.hs @@ -42,12 +42,12 @@ import Types -- | Simplify an expression by constant folding, and also return whether it's a -- constant after that. -constantFold :: CSM m => A.Expression -> m (A.Expression, Bool, String) +constantFold :: CSM m => A.Expression -> m (A.Expression, Bool, ErrorReport) constantFold e = do ps <- get let (e', msg) = case simplifyExpression ps e of Left err -> (e, err) - Right val -> (val, "already folded") + Right val -> (val, (Nothing, "already folded")) return (e', isConstant e', msg) -- | Is a name defined as a constant expression? If so, return its definition. @@ -70,7 +70,7 @@ isConstantName n -- | Attempt to simplify an expression as far as possible by precomputing -- constant bits. -simplifyExpression :: CompState -> A.Expression -> Either String A.Expression +simplifyExpression :: CompState -> A.Expression -> Either ErrorReport A.Expression simplifyExpression ps e = case runEvaluator ps (evalExpression e) of Left err -> Left err @@ -78,8 +78,8 @@ simplifyExpression ps e --{{{ expression evaluator evalLiteral :: A.Expression -> EvalM OccValue -evalLiteral (A.Literal _ _ (A.ArrayLiteral _ [])) - = throwError "empty array" +evalLiteral (A.Literal m _ (A.ArrayLiteral _ [])) + = throwError (Just m, "empty array") evalLiteral (A.Literal _ _ (A.ArrayLiteral _ aes)) = liftM OccArray (mapM evalLiteralArray aes) evalLiteral (A.Literal _ (A.Record n) (A.RecordLiteral _ es)) @@ -91,11 +91,11 @@ evalLiteralArray (A.ArrayElemArray aes) = liftM OccArray (mapM evalLiteralArray evalLiteralArray (A.ArrayElemExpr e) = evalExpression e evalVariable :: A.Variable -> EvalM OccValue -evalVariable (A.Variable _ n) +evalVariable (A.Variable m n) = do me <- getConstantName n case me of Just e -> evalExpression e - Nothing -> throwError $ "non-constant variable " ++ show n ++ " used" + Nothing -> throwError (Just m, "non-constant variable " ++ show n ++ " used") evalVariable (A.SubscriptedVariable _ sub v) = evalVariable v >>= evalSubscript sub evalVariable (A.DirectedVariable _ _ v) = evalVariable v @@ -104,15 +104,15 @@ evalIndex e = do index <- evalExpression e case index of OccInt n -> return $ fromIntegral n - _ -> throwError $ "index has non-INT type" + _ -> throwError (Just $ findMeta e, "index has non-INT type") evalSubscript :: A.Subscript -> OccValue -> EvalM OccValue -evalSubscript (A.Subscript _ e) (OccArray vs) +evalSubscript (A.Subscript m e) (OccArray vs) = do index <- evalIndex e if index >= 0 && index < length vs then return $ vs !! index - else throwError $ "subscript out of range" -evalSubscript _ _ = throwError $ "invalid subscript" + else throwError (Just m, "subscript out of range") +evalSubscript s _ = throwError (Just $ findMeta s, "invalid subscript") evalExpression :: A.Expression -> EvalM OccValue evalExpression (A.Monadic _ op e) @@ -140,7 +140,7 @@ evalExpression (A.MostPos _ A.Int32) = return $ OccInt32 maxBound evalExpression (A.MostNeg _ A.Int32) = return $ OccInt32 minBound evalExpression (A.MostPos _ A.Int64) = return $ OccInt64 maxBound evalExpression (A.MostNeg _ A.Int64) = return $ OccInt64 minBound -evalExpression (A.SizeExpr _ e) +evalExpression (A.SizeExpr m e) = do t <- typeOfExpression e >>= underlyingType case t of A.Array (A.Dimension n:_) _ -> return $ OccInt (fromIntegral n) @@ -148,28 +148,28 @@ evalExpression (A.SizeExpr _ e) do v <- evalExpression e case v of OccArray vs -> return $ OccInt (fromIntegral $ length vs) - _ -> throwError $ "size of non-constant expression " ++ show e ++ " used" + _ -> throwError (Just m, "size of non-constant expression " ++ show e ++ " used") evalExpression (A.SizeVariable m v) = do t <- typeOfVariable v >>= underlyingType case t of A.Array (A.Dimension n:_) _ -> return $ OccInt (fromIntegral n) - _ -> throwError $ "size of non-fixed-size variable " ++ show v ++ " used" + _ -> throwError (Just m, "size of non-fixed-size variable " ++ show v ++ " used") evalExpression e@(A.Literal _ _ _) = evalLiteral e evalExpression (A.ExprVariable _ v) = evalVariable v evalExpression (A.True _) = return $ OccBool True evalExpression (A.False _) = return $ OccBool False evalExpression (A.SubscriptedExpr _ sub e) = evalExpression e >>= evalSubscript sub -evalExpression (A.BytesInExpr _ e) +evalExpression (A.BytesInExpr m e) = do b <- typeOfExpression e >>= underlyingType >>= bytesInType case b of BIJust n -> return $ OccInt (fromIntegral $ n) - _ -> throwError $ "BYTESIN non-constant-size expression " ++ show e ++ " used" -evalExpression (A.BytesInType _ t) + _ -> throwError (Just m, "BYTESIN non-constant-size expression " ++ show e ++ " used") +evalExpression (A.BytesInType m t) = do b <- underlyingType t >>= bytesInType case b of BIJust n -> return $ OccInt (fromIntegral $ n) - _ -> throwErrorC $ formatCode "BYTESIN non-constant-size type % used" t -evalExpression e = throwError "bad expression" + _ -> throwErrorC (Just m, formatCode "BYTESIN non-constant-size type % used" t) +evalExpression e = throwError (Just $ findMeta e, "bad expression") evalMonadicOp :: (forall t. (Num t, Integral t, Bits t) => t -> t) -> OccValue -> EvalM OccValue evalMonadicOp f (OccByte a) = return $ OccByte (f a) @@ -181,7 +181,7 @@ evalMonadicOp f (OccInt a) = return $ OccInt (f a) evalMonadicOp f (OccInt16 a) = return $ OccInt16 (f a) evalMonadicOp f (OccInt32 a) = return $ OccInt32 (f a) evalMonadicOp f (OccInt64 a) = return $ OccInt64 (f a) -evalMonadicOp _ _ = throwError "monadic operator not implemented for this type" +evalMonadicOp _ v = throwError (Nothing, "monadic operator not implemented for this type: " ++ show v) evalMonadic :: A.MonadicOp -> OccValue -> EvalM OccValue -- This, oddly, is probably the most important rule here: "-4" isn't a literal @@ -190,7 +190,7 @@ evalMonadic A.MonadicSubtr a = evalMonadicOp negate a evalMonadic A.MonadicMinus a = evalMonadicOp negate a evalMonadic A.MonadicBitNot a = evalMonadicOp complement a evalMonadic A.MonadicNot (OccBool b) = return $ OccBool (not b) -evalMonadic _ _ = throwError "bad monadic op" +evalMonadic op _ = throwError (Nothing, "bad monadic op: " ++ show op) evalDyadicOp :: (forall t. (Num t, Integral t, Bits t) => t -> t -> t) -> OccValue -> OccValue -> EvalM OccValue evalDyadicOp f (OccByte a) (OccByte b) = return $ OccByte (f a b) @@ -202,7 +202,7 @@ evalDyadicOp f (OccInt a) (OccInt b) = return $ OccInt (f a b) evalDyadicOp f (OccInt16 a) (OccInt16 b) = return $ OccInt16 (f a b) evalDyadicOp f (OccInt32 a) (OccInt32 b) = return $ OccInt32 (f a b) evalDyadicOp f (OccInt64 a) (OccInt64 b) = return $ OccInt64 (f a b) -evalDyadicOp _ _ _ = throwError "dyadic operator not implemented for this type" +evalDyadicOp _ v0 v1 = throwError (Nothing, "dyadic operator not implemented for these types: " ++ show v0 ++ " and " ++ show v1) evalCompareOp :: (forall t. (Eq t, Ord t) => t -> t -> Bool) -> OccValue -> OccValue -> EvalM OccValue evalCompareOp f (OccByte a) (OccByte b) = return $ OccBool (f a b) @@ -214,7 +214,7 @@ evalCompareOp f (OccInt a) (OccInt b) = return $ OccBool (f a b) evalCompareOp f (OccInt16 a) (OccInt16 b) = return $ OccBool (f a b) evalCompareOp f (OccInt32 a) (OccInt32 b) = return $ OccBool (f a b) evalCompareOp f (OccInt64 a) (OccInt64 b) = return $ OccBool (f a b) -evalCompareOp _ _ _ = throwError "comparison operator not implemented for this type" +evalCompareOp _ v0 v1 = throwError (Nothing, "comparison operator not implemented for these types: " ++ show v0 ++ " and " ++ show v1) evalDyadic :: A.DyadicOp -> OccValue -> OccValue -> EvalM OccValue -- FIXME These should check for overflow. @@ -243,7 +243,7 @@ evalDyadic A.More a b = evalCompareOp (>) a b evalDyadic A.LessEq a b = evalCompareOp (<=) a b evalDyadic A.MoreEq a b = evalCompareOp (>=) a b evalDyadic A.After (OccInt a) (OccInt b) = return $ OccBool ((a - b) > 0) -evalDyadic _ _ _ = throwError "bad dyadic op" +evalDyadic op _ _ = throwError (Nothing, "bad dyadic op: " ++ show op) --}}} --{{{ rendering values diff --git a/common/EvalLiterals.hs b/common/EvalLiterals.hs index f6cc26c..a69af0e 100644 --- a/common/EvalLiterals.hs +++ b/common/EvalLiterals.hs @@ -33,11 +33,12 @@ import Numeric import qualified AST as A import CompState import Errors +import Metadata -type EvalM = ErrorT String (StateT CompState Identity) +type EvalM = ErrorT ErrorReport (StateT CompState Identity) instance Die EvalM where - die = throwError + dieReport = throwError -- | Occam values of various types. data OccValue = @@ -80,7 +81,7 @@ evalIntExpression :: (CSM m, Die m) => A.Expression -> m Int evalIntExpression e = do ps <- get case runEvaluator ps (evalSimpleExpression e) of - Left err -> die $ "cannot evaluate expression: " ++ err + Left (m,err) -> dieReport (m,"cannot evaluate expression: " ++ err) Right (OccInt val) -> return $ fromIntegral val Right _ -> die "expression is not of INT type" @@ -89,18 +90,18 @@ evalByte :: (CSM m, Die m) => String -> m Char evalByte s = do ps <- get case runEvaluator ps (evalByteLiteral s) of - Left err -> die $ "cannot evaluate byte literal: " ++ err + Left (m,err) -> dieReport (m,"cannot evaluate byte literal: " ++ err) Right (OccByte ch) -> return (chr $ fromIntegral ch) -- | Run an evaluator operation. -runEvaluator :: CompState -> EvalM OccValue -> Either String OccValue +runEvaluator :: CompState -> EvalM OccValue -> Either ErrorReport OccValue runEvaluator ps func = runIdentity (evalStateT (runErrorT func) ps) -- | Evaluate a simple literal expression. evalSimpleExpression :: A.Expression -> EvalM OccValue evalSimpleExpression e@(A.Literal _ _ _) = evalSimpleLiteral e -evalSimpleExpression _ = throwError "not a literal" +evalSimpleExpression e = throwError (Just $ findMeta e,"not a literal") -- | Turn the result of one of the read* functions into an OccValue, -- or throw an error if it didn't parse. @@ -108,7 +109,7 @@ fromRead :: (t -> OccValue) -> (String -> [(t, String)]) -> String -> EvalM OccV fromRead cons reader s = case reader s of [(v, "")] -> return $ cons v - _ -> throwError $ "cannot parse literal: " ++ s + _ -> throwError (Nothing,"cannot parse literal: " ++ s) -- | Evaluate a simple (non-array) literal. evalSimpleLiteral :: A.Expression -> EvalM OccValue @@ -150,7 +151,7 @@ evalSimpleLiteral (A.Literal _ A.Int64 (A.IntLiteral _ s)) = fromRead OccInt64 (readSigned readDec) s evalSimpleLiteral (A.Literal _ A.Int64 (A.HexLiteral _ s)) = fromRead OccInt64 readHex s -evalSimpleLiteral l = throwError $ "bad literal: " ++ show l +evalSimpleLiteral l = throwError (Just $ findMeta l,"bad literal: " ++ show l) -- | Evaluate a byte literal. evalByteLiteral :: String -> EvalM OccValue @@ -168,4 +169,4 @@ evalByteLiteral ['*', ch] star c = c evalByteLiteral [ch] = return $ OccByte (fromIntegral $ ord ch) -evalByteLiteral _ = throwError "bad BYTE literal" +evalByteLiteral _ = throwError (Nothing,"bad BYTE literal") diff --git a/common/Metadata.hs b/common/Metadata.hs index 3ef3c6b..44823e5 100644 --- a/common/Metadata.hs +++ b/common/Metadata.hs @@ -44,7 +44,7 @@ emptyMeta = Meta { instance Show Meta where show m = case metaFile m of - Just s -> basenamePath s ++ ":" ++ show (metaLine m) ++ ":" ++ show (metaColumn m) + Just s -> s ++ ":" ++ show (metaLine m) ++ ":" ++ show (metaColumn m) Nothing -> "no source position" --emptyMeta is equal to any meta tag: @@ -63,8 +63,8 @@ packMeta m s (metaLine m) (metaColumn m) fn s -- | Extract a Meta (encoded by packMeta) from a String. -unpackMeta :: String -> (Meta, String) -unpackMeta ('~':s) = (m, rest) +unpackMeta :: String -> (Maybe Meta, String) +unpackMeta ('~':s) = (Just m, rest) where (ls, _:s') = break (== '\0') s (cs, _:s'') = break (== '\0') s' @@ -74,7 +74,7 @@ unpackMeta ('~':s) = (m, rest) metaLine = read ls, metaColumn = read cs } -unpackMeta s = (emptyMeta, s) +unpackMeta s = (Nothing, s) -- | Find the first Meta value in some part of the AST. findMeta :: (Data t, Typeable t) => t -> Meta diff --git a/common/Pass.hs b/common/Pass.hs index 43d7331..2465284 100644 --- a/common/Pass.hs +++ b/common/Pass.hs @@ -33,10 +33,10 @@ import PrettyShow import TreeUtil -- | The monad in which AST-mangling passes operate. -type PassM = ErrorT String (StateT CompState IO) +type PassM = ErrorT ErrorReport (StateT CompState IO) instance Die PassM where - die = throwError + dieReport = throwError -- | The type of an AST-mangling pass. type Pass = A.Process -> PassM A.Process @@ -108,6 +108,6 @@ makeGeneric top excludeConstr :: Data a => [Constr] -> a -> PassM a excludeConstr cons x - = if null items then return x else dieInternal $ "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x + = if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x) where items = checkTreeForConstr cons x diff --git a/common/TestUtil.hs b/common/TestUtil.hs index 1a146ab..a07ae5f 100644 --- a/common/TestUtil.hs +++ b/common/TestUtil.hs @@ -52,6 +52,7 @@ import CompState import PrettyShow import Utils import qualified Data.Map as Map +import Errors -- | An abbreviation for using 'emptyMeta'. TODO: This should really be removed (and all uses of it replaced with 'emptyMeta') for clarity. m :: Meta @@ -232,7 +233,7 @@ testPassGetItems testName expected actualPass startStateTrans = --passResult :: Either String b do passResult <- runPass actualPass startState case passResult of - (st,Left err) -> return (st, Left $ assertFailure (testName ++ "; pass actually failed: " ++ err) ) + (st,Left (_,err)) -> return (st, Left $ assertFailure (testName ++ "; pass actually failed: " ++ err)) (st,Right resultItem) -> return (st, transformEither (sequence_ . map (assertFailure . ((++) testName))) (id) $ getMatchedItems expected resultItem ) where startState :: CompState @@ -242,7 +243,7 @@ testPassGetItems testName expected actualPass startStateTrans = runPass :: PassM b -- ^ The actual pass. -> CompState -- ^ The state to use to run the pass. - -> IO (CompState, Either String b) -- ^ The resultant state, and either an error or the successful outcome of the pass. + -> IO (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass. runPass actualPass startState = (liftM (\(x,y) -> (y,x))) (runStateT (runErrorT actualPass) startState) -- | A test that runs a given AST pass and checks that it succeeds. @@ -268,7 +269,7 @@ testPassWithCheck :: testPassWithCheck testName expected actualPass startStateTrans checkFunc = do passResult <- runPass actualPass (execState startStateTrans emptyState) case snd passResult of - Left err -> assertFailure (testName ++ "; pass actually failed: " ++ err) + Left (_,err) -> assertFailure (testName ++ "; pass actually failed: " ++ err) Right result -> (assertPatternMatch testName expected result) >> (checkFunc result) -- | A test that runs a given AST pass, checks that it succeeds, and checks the resulting 'Items' with a given function. diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 457a590..20a4ecc 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -53,7 +53,8 @@ instance MonadState st (GenParser tok st) where put = setState instance Die (GenParser tok st) where - die = fail + dieReport (Just m, err) = fail $ packMeta m err + dieReport (Nothing, err) = fail err --}}} --{{{ matching rules for raw tokens @@ -273,7 +274,7 @@ maybeSliced inner subscripter typer t <- typer v >>= underlyingType case t of (A.Array _ _) -> return () - _ -> fail $ "slice of non-array type " ++ showOccam t + _ -> dieP m $ "slice of non-array type " ++ showOccam t e <- intExpr sub <- case ff1 of @@ -371,7 +372,7 @@ matchType et rt else bad _ -> if rt == et then return () else bad where - bad = fail $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")" + bad = die $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")" -- | Check that two lists of types match (for example, for parallel assignment). matchTypes :: [A.Type] -> [A.Type] -> OccParser () @@ -397,10 +398,10 @@ findName :: A.Name -> OccParser A.Name findName thisN = do st <- getState origN <- case lookup (A.nameName thisN) (csLocalNames st) of - Nothing -> fail $ "name " ++ A.nameName thisN ++ " not defined" + Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined" Just n -> return n if A.nameType thisN /= A.nameType origN - then fail $ "expected " ++ show (A.nameType thisN) ++ " (" ++ A.nameName origN ++ " is " ++ show (A.nameType origN) ++ ")" + then dieP (A.nameMeta thisN) $ "expected " ++ show (A.nameType thisN) ++ " (" ++ A.nameName origN ++ " is " ++ show (A.nameType origN) ++ ")" else return $ thisN { A.nameName = A.nameName origN } makeUniqueName :: String -> OccParser String @@ -444,7 +445,7 @@ scopeOut n@(A.Name m nt s) = do st <- getState let lns' = case csLocalNames st of (s, _):ns -> ns - otherwise -> dieInternal "scopeOut trying to scope out the wrong name" + otherwise -> dieInternal (Just m, "scopeOut trying to scope out the wrong name") setState $ st { csLocalNames = lns' } -- FIXME: Do these with generics? (going carefully to avoid nested code blocks) @@ -632,7 +633,7 @@ makeArrayElem t@(A.Array _ _) (A.ArrayElemArray aes) = do elemT <- trivialSubscriptType t liftM A.ArrayElemArray $ mapM (makeArrayElem elemT) aes makeArrayElem _ (A.ArrayElemArray _) - = fail $ "unexpected nested array literal" + = die $ "unexpected nested array literal" -- A nested array literal that's still of array type (i.e. it's not a -- record inside the array) -- collapse it. makeArrayElem t@(A.Array _ _) (A.ArrayElemExpr (A.Literal _ _ (A.ArrayLiteral _ aes))) @@ -905,9 +906,9 @@ booleanExpr = expressionOfType A.Bool "boolean expression" constExprOfType :: A.Type -> OccParser A.Expression constExprOfType wantT = do e <- expressionOfType wantT - (e', isConst, msg) <- constantFold e + (e', isConst, (m,msg)) <- constantFold e when (not isConst) $ - fail $ "expression is not constant (" ++ msg ++ ")" + dieReport (m,"expression is not constant (" ++ msg ++ ")") return e' constIntExpr = constExprOfType A.Int "constant integer expression" @@ -1047,7 +1048,7 @@ conversion baseOT <- underlyingType ot c <- case (isPreciseConversion baseOT baseT, c) of (False, A.DefaultConversion) -> - fail "imprecise conversion must specify ROUND or TRUNC" + dieP m "imprecise conversion must specify ROUND or TRUNC" (False, _) -> return c (True, A.DefaultConversion) -> return c (True, _) -> @@ -1284,7 +1285,7 @@ chanArrayAbbrev t <- tableType m ts case t of (A.Array _ (A.Chan {})) -> return () - _ -> fail $ "types do not match in channel array abbreviation" + _ -> dieP m $ "types do not match in channel array abbreviation" return $ A.Specification m n $ A.IsChannelArray m t cs <|> do m <- md (ct, s, n) <- try (do s <- channelSpecifier @@ -1385,11 +1386,11 @@ checkRetypes fromT toT bt <- bytesInType toT case (bf, bt) of (BIJust a, BIJust b) -> - when (a /= b) $ fail "size mismatch in RETYPES" + when (a /= b) $ die "size mismatch in RETYPES" (BIJust a, BIOneFree b _) -> - when (not ((b <= a) && (a `mod` b == 0))) $ fail "size mismatch in RETYPES" + when (not ((b <= a) && (a `mod` b == 0))) $ die "size mismatch in RETYPES" (_, BIManyFree) -> - fail "multiple free dimensions in RETYPES/RESHAPES type" + die "multiple free dimensions in RETYPES/RESHAPES type" -- Otherwise we have to do a runtime check. _ -> return () @@ -1628,7 +1629,7 @@ caseInputItems :: A.Variable -> OccParser [(A.Name, [A.Type])] caseInputItems c = do pis <- protocolItems c case pis of - Left _ -> fail "CASE input on channel of non-variant protocol" + Left _ -> dieP (findMeta c) "CASE input on channel of non-variant protocol" Right nts -> return nts caseInput :: OccParser A.Process @@ -1755,7 +1756,7 @@ caseProcess sel <- expression t <- typeOfExpression sel t' <- underlyingType t - when (not $ isCaseableType t') $ fail "case selector has non-CASEable type" + when (not $ isCaseableType t') $ dieP m "case selector has non-CASEable type" eol os <- maybeIndentedList m "empty CASE" (caseOption t) return $ A.Case m sel (A.Several m os) diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs index af97694..0386d79 100644 --- a/frontends/RainPassesTest.hs +++ b/frontends/RainPassesTest.hs @@ -44,7 +44,7 @@ skipP = A.OnlyP m (A.Skip m) castAssertADI :: (Typeable b) => Maybe AnyDataItem -> IO b castAssertADI x = case (castADI x) of Just y -> return y - Nothing -> dieInternal "Pattern successfully matched but did not find item afterwards" + Nothing -> dieInternal (Nothing, "Pattern successfully matched but did not find item afterwards") testEachPass0 :: Test testEachPass0 = TestCase $ testPassWithItemsStateCheck "testEachPass0" exp (transformEach orig) startState' check diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index d90f3b2..4fb1d02 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -229,7 +229,7 @@ checkAssignmentTypes = everywhereASTM checkAssignment then return ass else do rhs' <- coerceType " in assignment" tlhs trhs e return $ A.Assign m [v] (A.ExpressionList m' [rhs']) - checkAssignment (A.Assign {}) = dieInternal "Rain checker found occam-style assignment" + checkAssignment (A.Assign m _ _) = dieInternal (Just m,"Rain checker found occam-style assignment") checkAssignment st = return st -- | Checks the types in if and while conditionals diff --git a/frontends/RainTypesTest.hs b/frontends/RainTypesTest.hs index 214817f..0be0aff 100644 --- a/frontends/RainTypesTest.hs +++ b/frontends/RainTypesTest.hs @@ -29,6 +29,7 @@ import Control.Monad.State import Control.Monad.Error import Types import Pass +import Errors constantFoldTest :: Test constantFoldTest = TestList @@ -297,7 +298,7 @@ checkExpressionTest = TestList --Now feed it through again, to make sure it isn't changed: if (e /= act) then pass' (10000 + n) t (mkPattern e) e else return () where - errorOrType :: IO (Either String A.Type) + errorOrType :: IO (Either ErrorReport A.Type) errorOrType = evalStateT (runErrorT $ typeOfExpression e) (execState state emptyState)