summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-08-07 20:59:18 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-08-07 21:51:10 +0200
commitdc2202f36f8ee220293cc6f230be604a19be8cbb (patch)
tree5201a7751ad655460d48d5e6456f8546179c25b5
parent18ced99f826746a19aa6c0b351673d132f86421a (diff)
Replace first command (wait) with a builtin
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/Parser.hs3
-rw-r--r--src/Parser/Core.hs3
-rw-r--r--src/Parser/Statement.hs12
-rw-r--r--src/Run.hs3
-rw-r--r--src/Test.hs21
-rw-r--r--src/Test/Builtins.hs13
7 files changed, 41 insertions, 15 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index c9e90b5..b1afc76 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -87,6 +87,7 @@ executable erebos-tester-core
Run
Run.Monad
Test
+ Test.Builtins
Util
Version
Version.Git
diff --git a/src/Parser.hs b/src/Parser.hs
index 4fd60b5..405622e 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -22,6 +22,7 @@ import Parser.Core
import Parser.Expr
import Parser.Statement
import Test
+import Test.Builtins
parseTestDefinition :: TestParser Test
parseTestDefinition = label "test definition" $ toplevel $ do
@@ -55,7 +56,7 @@ parseTestFile path = do
content <- TL.readFile path
absPath <- makeAbsolute path
let initState = TestParserState
- { testVars = []
+ { testVars = map (fmap someVarValueType) builtins
, testContext = SomeExpr RootNetwork
}
case evalState (runParserT (parseTestModule absPath) path content) initState of
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index da93905..b932523 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -24,9 +24,6 @@ data TestParserState = TestParserState
, testContext :: SomeExpr
}
-data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
-data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)
-
someEmptyVar :: SomeExprType -> SomeVarValue
someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 8906cec..8dd285a 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -75,6 +75,11 @@ forStatement = do
body <- testBlock indent
return [For line tname (unpack <$> e) body]
+exprStatement :: TestParser [ TestStep ]
+exprStatement = do
+ expr <- typedExpr
+ return [ ExprStatement expr ]
+
class (Typeable a, Typeable (ParamRep a)) => ParamType a where
type ParamRep a :: Type
type ParamRep a = a
@@ -335,11 +340,6 @@ testPacketLoss = command "packet_loss" $ PacketLoss
<*> innerBlock
-testWait :: TestParser [TestStep]
-testWait = do
- wsymbol "wait"
- return [Wait]
-
testBlock :: Pos -> TestParser [TestStep]
testBlock indent = concat <$> go
where
@@ -369,5 +369,5 @@ testStep = choice
, testDisconnectNodes
, testDisconnectUpstream
, testPacketLoss
- , testWait
+ , exprStatement
]
diff --git a/src/Run.hs b/src/Run.hs
index a69ba75..2bee6ec 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -32,6 +32,7 @@ import Output
import Process
import Run.Monad
import Test
+import Test.Builtins
runTest :: Output -> TestOptions -> Test -> IO Bool
runTest out opts test = do
@@ -60,7 +61,7 @@ runTest out opts test = do
}
tstate = TestState
{ tsNetwork = error "network not initialized"
- , tsVars = []
+ , tsVars = builtins
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
diff --git a/src/Test.hs b/src/Test.hs
index a54bbbd..e2f829b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -7,8 +7,8 @@ module Test (
MonadEval(..),
VarName(..), TypedVarName(..), textVarName, unpackVarName,
- ExprType(..),
- SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
+ ExprType(..), SomeExpr(..), SomeExprType(..), someExprType,
+ SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType,
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
@@ -135,9 +135,16 @@ instance ExprType TestBlock where
textExprValue _ = "<test block>"
emptyVarValue = TestBlock []
-data SomeVarValue = forall a. ExprType a => SomeVarValue a
-data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
+data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
+
+data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)
+
+someExprType :: SomeExpr -> SomeExprType
+someExprType (SomeExpr (_ :: Expr a)) = SomeExprType (Proxy @a)
+
+
+data SomeVarValue = forall a. ExprType a => SomeVarValue a
fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a
fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value
@@ -146,6 +153,12 @@ fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast valu
textSomeVarValue :: SomeVarValue -> Text
textSomeVarValue (SomeVarValue value) = textExprValue value
+someVarValueType :: SomeVarValue -> SomeExprType
+someVarValueType (SomeVarValue (_ :: a)) = SomeExprType (Proxy @a)
+
+
+data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
+
data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
new file mode 100644
index 0000000..9deb2df
--- /dev/null
+++ b/src/Test/Builtins.hs
@@ -0,0 +1,13 @@
+module Test.Builtins (
+ builtins,
+) where
+
+import Test
+
+builtins :: [ ( VarName, SomeVarValue ) ]
+builtins =
+ [ ( VarName "wait", SomeVarValue builtinWait )
+ ]
+
+builtinWait :: TestBlock
+builtinWait = TestBlock [ Wait ]