diff options
| -rw-r--r-- | src/Parser.hs | 2 | ||||
| -rw-r--r-- | src/Parser/Expr.hs | 14 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 10 |
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 ":" |