summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Process.hs3
-rw-r--r--src/Script/Expr/Class.hs4
-rw-r--r--src/Script/Object.hs11
-rw-r--r--src/Test.hs7
4 files changed, 23 insertions, 2 deletions
diff --git a/src/Process.hs b/src/Process.hs
index 57411d7..1389987 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -199,6 +199,9 @@ data IgnoreProcessOutput = IgnoreProcessOutput Process Int
instance ObjectType TestRun IgnoreProcessOutput where
type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex )
+ textObjectType _ _ = "IgnoreProcessOutput"
+ textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>"
+
createObject oid ( process@Process {..}, regex ) = do
liftIO $ atomically $ do
flushProcessOutput process regex
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
index 20a92b4..005b6a8 100644
--- a/src/Script/Expr/Class.hs
+++ b/src/Script/Expr/Class.hs
@@ -39,6 +39,10 @@ data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (P
data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
+instance ExprType () where
+ textExprType _ = "Unit"
+ textExprValue () = "()"
+
instance ExprType Integer where
textExprType _ = T.pack "integer"
textExprValue x = T.pack (show x)
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
index 9232b21..7e60f80 100644
--- a/src/Script/Object.hs
+++ b/src/Script/Object.hs
@@ -7,8 +7,11 @@ module Script.Object (
) where
import Data.Kind
+import Data.Text (Text)
import Data.Typeable
+import Script.Expr.Class
+
newtype ObjectId = ObjectId Int
@@ -16,9 +19,17 @@ class Typeable a => ObjectType m a where
type ConstructorArgs a :: Type
type ConstructorArgs a = ()
+ textObjectType :: proxy (m a) -> proxy a -> Text
+ textObjectValue :: proxy (m a) -> a -> Text
+
createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
destroyObject :: Object m a -> m ()
+instance (Typeable m, ObjectType m a) => ExprType (Object m a) where
+ textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a)
+ textExprValue = textObjectValue (Proxy @(m a)) . objImpl
+
+
data Object m a = ObjectType m a => Object
{ objId :: ObjectId
, objImpl :: a
diff --git a/src/Test.hs b/src/Test.hs
index 1481b2b..9ba185b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -12,7 +12,7 @@ import Control.Monad.Reader
import Data.Bifunctor
import Data.Scientific
-import Data.Text (Text)
+import Data.Text (Text, pack)
import Data.Typeable
import Network
@@ -57,7 +57,7 @@ data TestStep a where
PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a
Wait :: TestStep ()
-instance Typeable a => ExprType (TestBlock a) where
+instance ExprType a => ExprType (TestBlock a) where
textExprType _ = "test block"
textExprValue _ = "<test block>"
@@ -67,6 +67,9 @@ data MultiplyTimeout = MultiplyTimeout Scientific
instance ObjectType TestRun MultiplyTimeout where
type ConstructorArgs MultiplyTimeout = Scientific
+ textObjectType _ _ = "MultiplyTimeout"
+ textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout"
+
createObject oid timeout
| timeout >= 0 = do
var <- asks (teTimeout . fst)