From e6bab9cb2aabafb27324f7d923739a8f4a96ad97 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 11 Aug 2024 10:32:50 +0200
Subject: Remove MonadEval instance for TestParser

---
 src/Parser/Core.hs |  9 ++-------
 src/Parser/Expr.hs | 21 +++++++++++++++------
 2 files changed, 17 insertions(+), 13 deletions(-)

(limited to 'src')

diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 341d9ca..2a74d3d 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -6,7 +6,6 @@ import Control.Monad.Writer
 
 import Data.Text (Text)
 import qualified Data.Text.Lazy as TL
-import Data.Typeable
 import Data.Void
 
 import Text.Megaparsec hiding (State)
@@ -28,15 +27,11 @@ data TestParserState = TestParserState
     , testContext :: SomeExpr
     }
 
-someEmptyVar :: SomeExprType -> SomeVarValue
-someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a
-
 textSomeExprType :: SomeExprType -> Text
 textSomeExprType (SomeExprType p) = textExprType p
 
-instance MonadEval TestParser where
-    lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)
-    rootNetwork = return emptyVarValue
+lookupVarType :: VarName -> TestParser SomeExprType
+lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars)
 
 skipLineComment :: TestParser ()
 skipLineComment = L.skipLineComment $ TL.pack "#"
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 6659895..9c0a1de 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -26,7 +26,9 @@ import Data.Void
 
 import Text.Megaparsec hiding (State)
 import Text.Megaparsec.Char
-import qualified Text.Megaparsec.Char.Lexer as L
+import Text.Megaparsec.Char.Lexer qualified as L
+import Text.Regex.TDFA qualified as RE
+import Text.Regex.TDFA.Text qualified as RE
 
 import Parser.Core
 import Test
@@ -58,7 +60,7 @@ someExpansion = do
     void $ char '$'
     choice
         [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
-            SomeVarValue (_ :: a) <- lookupVar name
+            SomeExprType (_ :: Proxy a) <- lookupVarType name
             return $ SomeExpr $ Variable @a name
         , between (char '{') (char '}') someExpr
         ]
@@ -111,6 +113,7 @@ quotedString = label "string" $ lexeme $ do
 
 regex :: TestParser (Expr Regex)
 regex = label "regular expression" $ lexeme $ do
+    off <- stateOffset <$> getParserState
     void $ char '/'
     let inner = choice
             [ char '/' >> return []
@@ -129,9 +132,15 @@ regex = label "regular expression" $ lexeme $ do
                     ]
                 (e:) <$> inner
             ]
-    expr <- Regex <$> inner
-    _ <- eval expr -- test regex parsing with empty variables
-    return expr
+    parts <- inner
+    let testEval = \case
+            Pure (RegexPart p) -> p
+            _ -> ""
+    case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of
+        Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+            [ "failed to parse regular expression: ", T.pack err ]
+        Right _ -> return ()
+    return $ Regex parts
 
 list :: TestParser SomeExpr
 list = label "list" $ do
@@ -307,7 +316,7 @@ someExpr = join inner <?> "expression"
 
     variable = label "variable" $ do
         name <- varName
-        SomeVarValue (_ :: a) <- lookupVar name
+        SomeExprType (_ :: Proxy a) <- lookupVarType name
         return $ return $ SomeExpr $ Variable @a name
 
 typedExpr :: forall a. ExprType a => TestParser (Expr a)
-- 
cgit v1.2.3