diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for erebos-tester +## 0.2.4 -- 2024-08-13 + +* Fix build with mtl-2.3 +* Fix type error reporting for some command parameters + ## 0.2.3 -- 2024-08-10 * Added `network` member to the `node` object diff --git a/erebos-tester.cabal b/erebos-tester.cabal --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester -version: 0.2.3 +version: 0.2.4 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and diff --git a/src/Network.hs b/src/Network.hs --- a/src/Network.hs +++ b/src/Network.hs @@ -101,12 +101,10 @@ instance ExprType Network where textExprType _ = T.pack "network" textExprValue n = "s:" <> textNetworkName (netPrefix n) - emptyVarValue = Network (IpPrefix []) undefined undefined undefined undefined undefined undefined instance ExprType Node where textExprType _ = T.pack "node" textExprValue n = T.pack "n:" <> textNodeName (nodeName n) - emptyVarValue = Node (IpAddress (IpPrefix []) 0) (NodeName T.empty 0) undefined undefined undefined undefined recordMembers = map (first T.pack) [ ("ip", RecordSelector $ textIpAddress . nodeIp) diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -4,6 +4,7 @@ parseTestFile, ) where +import Control.Monad import Control.Monad.State import Control.Monad.Writer diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -6,7 +6,6 @@ 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 @@ , 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 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -26,7 +26,9 @@ 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 @@ 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 ] @@ -70,7 +72,7 @@ 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 + return $ Undefined "expansion not defined for type" maybe err return $ listToMaybe $ catMaybes $ conv e @@ -111,6 +113,7 @@ regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do + off <- stateOffset <$> getParserState void $ char '/' let inner = choice [ char '/' >> return [] @@ -129,9 +132,15 @@ ] (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 @@ 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) @@ -317,5 +326,5 @@ 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 + return $ Undefined "unexpected type" maybe err return $ cast e diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -123,7 +123,7 @@ type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b) parseParam _ = try' (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy) where - try' act = try $ do + try' act = try $ region id $ do x <- act (stateParseErrors <$> getParserState) >>= \case [] -> return x diff --git a/src/Process.hs b/src/Process.hs --- a/src/Process.hs +++ b/src/Process.hs @@ -50,7 +50,6 @@ instance ExprType Process where textExprType _ = T.pack "proc" textExprValue n = T.pack "p:" <> textProcName (procName n) - emptyVarValue = Process (ProcName T.empty) undefined undefined undefined undefined emptyVarValue recordMembers = map (first T.pack) [ ("node", RecordSelector $ procNode) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -84,7 +84,6 @@ class Typeable a => ExprType a where textExprType :: proxy a -> Text textExprValue :: a -> Text - emptyVarValue :: a recordMembers :: [(Text, RecordSelector a)] recordMembers = [] @@ -98,42 +97,35 @@ instance ExprType Integer where textExprType _ = T.pack "integer" textExprValue x = T.pack (show x) - emptyVarValue = 0 exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo instance ExprType Scientific where textExprType _ = T.pack "number" textExprValue x = T.pack (show x) - emptyVarValue = 0 instance ExprType Bool where textExprType _ = T.pack "bool" textExprValue True = T.pack "true" textExprValue False = T.pack "false" - emptyVarValue = False instance ExprType Text where textExprType _ = T.pack "string" textExprValue x = T.pack (show x) - emptyVarValue = T.empty instance ExprType Regex where textExprType _ = T.pack "regex" textExprValue _ = T.pack "" - emptyVarValue = either error id $ regexCompile T.empty instance ExprType a => ExprType [a] where textExprType _ = "[" <> textExprType @a Proxy <> "]" textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" - emptyVarValue = [] exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) instance ExprType TestBlock where textExprType _ = "test block" textExprValue _ = "" - emptyVarValue = TestBlock [] data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) @@ -171,6 +163,7 @@ Concat :: [Expr Text] -> Expr Text Regex :: [Expr Regex] -> Expr Regex RootNetwork :: Expr Network + Undefined :: String -> Expr a data AppAnnotation b = AnnNone | ExprType b => AnnRecord Text @@ -193,6 +186,7 @@ Left err -> fail err Right re -> return re eval (RootNetwork) = rootNetwork +eval (Undefined err) = fail err gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)] gatherVars = fmap (uniqOn fst . sortOn fst) . helper @@ -209,6 +203,7 @@ helper (Concat es) = concat <$> mapM helper es helper (Regex es) = concat <$> mapM helper es helper (RootNetwork) = return [] + helper (Undefined {}) = return [] gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) gatherSelectors = \case