From 18ced99f826746a19aa6c0b351673d132f86421a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 5 Aug 2024 20:28:06 +0200
Subject: Parser: report multiple errors in some cases

Changelog: Report multiple parsing errors in single pass
---
 src/Parser.hs           |  2 +-
 src/Parser/Expr.hs      | 14 +++++++++-----
 src/Parser/Statement.hs | 10 ++++++++--
 3 files changed, 18 insertions(+), 8 deletions(-)

(limited to 'src')

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 ":"
-- 
cgit v1.2.3