summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Parser.hs2
-rw-r--r--src/Parser/Expr.hs14
-rw-r--r--src/Parser/Statement.hs10
3 files changed, 18 insertions, 8 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index cd9b590..4fd60b5 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -39,7 +39,7 @@ parseTestModule absPath = do
x <- identifier
name <- (x:) <$> many (symbol "." >> identifier)
when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
- parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"module name does not match file path"
eol >> scn
return name
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index fee5c25..6659895 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -48,7 +48,7 @@ newVarName = do
addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser ()
addVarName off (TypedVarName name) = do
gets (lookup name . testVars) >>= \case
- Just _ -> parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
modify $ \s -> s { testVars = (name, SomeExprType @a Proxy) : testVars s }
@@ -67,8 +67,10 @@ stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [May
stringExpansion tname conv = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
+ let err = do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
+ return $ Pure emptyVarValue
maybe err return $ listToMaybe $ catMaybes $ conv e
@@ -312,6 +314,8 @@ typedExpr :: forall a. ExprType a => TestParser (Expr a)
typedExpr = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpr
- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]
+ let err = do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]
+ return $ Pure emptyVarValue
maybe err return $ cast e
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index eef0848..8906cec 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -116,7 +116,13 @@ instance ParamType a => ParamType (Maybe a) where
instance (ParamType a, ParamType b) => ParamType (Either a b) where
type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b)
- parseParam _ = try (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)
+ parseParam _ = try' (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)
+ where
+ try' act = try $ do
+ x <- act
+ (stateParseErrors <$> getParserState) >>= \case
+ [] -> return x
+ (_ : _) -> fail ""
showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy
paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se)
@@ -255,7 +261,7 @@ testWith = do
notAllowed <- flip allM expected $ \case
SomeExprType (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False
_ -> return True
- when notAllowed $ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ when notAllowed $ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"expected " <> T.intercalate ", " (map (("'"<>) . (<>"'") . textSomeExprType) expected) <> ", expression has type '" <> textExprType @ctxe Proxy <> "'"
symbol ":"