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.
This commit is contained in:
Neil Brown
parent
1baecd7955
commit
c97d1d00c8
8
Main.hs
8
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
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ identifyParProcs = everywhereM (mkM doProcess)
|
|||
type CGen = WriterT [String] PassM
|
||||
|
||||
instance Die CGen where
|
||||
die = throwError
|
||||
dieReport = throwError
|
||||
--}}}
|
||||
|
||||
--{{{ generator ops
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -19,25 +19,36 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
-- | 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user