Object type with constructors and destructorsHEADmaster

4 files changed, 75 insertions, 7 deletions

diff --git a/src/Run.hs b/src/Run.hs
index 32b04c6..2d5029d 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -12,15 +12,16 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Fix
 import Control.Monad.Reader
+import Control.Monad.Writer
 
 import Data.Bifunctor
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Proxy
 import Data.Scientific
 import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text qualified as T
-import Text.Megaparsec (errorBundlePretty, showErrorComponent)
 
 import System.Directory
 import System.Exit
@@ -29,6 +30,8 @@ import System.Posix.Process
 import System.Posix.Signals
 import System.Process
 
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
+
 import GDB
 import Network
 import Network.Ip
@@ -38,6 +41,7 @@ import Process
 import Run.Monad
 import Script.Expr
 import Script.Module
+import Script.Object
 import Script.Shell
 import Test
 import Test.Builtins
@@ -53,6 +57,7 @@ runTest out opts gdefs test = do
     createDirectoryIfMissing True testDir
 
     failedVar <- newTVarIO Nothing
+    objIdVar <- newMVar 1
     procVar <- newMVar []
 
     mgdb <- if optGDB opts
@@ -65,6 +70,7 @@ runTest out opts gdefs test = do
             { teOutput = out
             , teFailed = failedVar
             , teOptions = opts
+            , teNextObjId = objIdVar
             , teProcesses = procVar
             , teGDB = fst <$> mgdb
             }
@@ -94,7 +100,7 @@ runTest out opts gdefs test = do
     oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
 
     resetOutputTime out
-    res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
+    ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
         withInternet $ \_ -> do
             runStep =<< eval (testSteps test)
             when (optWait opts) $ do
@@ -144,7 +150,15 @@ runBlock (TestBlockStep prev step) = runBlock prev >> runStep step
 runStep :: TestStep () -> TestRun ()
 runStep = \case
     Scope block -> do
-        runBlock block
+        ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left)
+        mapM_ destroySomeObject (reverse objs)
+        either throwError return x
+
+    CreateObject (Proxy :: Proxy o) cargs -> do
+        objIdVar <- asks (teNextObjId . fst)
+        oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x ))
+        obj <- createObject @TestRun @o (ObjectId oid) cargs
+        tell [ toSomeObject obj ]
 
     Subnet name parent inner -> do
         withSubnet parent (Just name) $ runStep . inner
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index abef32d..aeab7e4 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -15,6 +15,7 @@ import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.Writer
 
 import Data.Map (Map)
 import Data.Scientific
@@ -26,15 +27,22 @@ import Network.Ip
 import Output
 import {-# SOURCE #-} Process
 import Script.Expr
+import Script.Object
 
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
-    deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }
+  deriving
+    ( Functor, Applicative, Monad
+    , MonadReader ( TestEnv, TestState )
+    , MonadWriter [ SomeObject TestRun ]
+    , MonadIO
+    )
 
 data TestEnv = TestEnv
     { teOutput :: Output
     , teFailed :: TVar (Maybe Failed)
     , teOptions :: TestOptions
-    , teProcesses :: MVar [Process]
+    , teNextObjId :: MVar Int
+    , teProcesses :: MVar [ Process ]
     , teGDB :: Maybe (MVar GDB)
     }
 
@@ -117,6 +125,7 @@ forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
 forkTestUsing fork act = do
     tenv <- ask
     liftIO $ fork $ do
-        runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+        ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+        case res of
             Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
             Right () -> return ()
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..9232b21
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,42 @@
+module Script.Object (
+    ObjectId(..),
+    ObjectType(..),
+    Object(..), SomeObject(..),
+    toSomeObject, fromSomeObject,
+    destroySomeObject,
+) where
+
+import Data.Kind
+import Data.Typeable
+
+
+newtype ObjectId = ObjectId Int
+
+class Typeable a => ObjectType m a where
+    type ConstructorArgs a :: Type
+    type ConstructorArgs a = ()
+
+    createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
+    destroyObject :: Object m a -> m ()
+
+data Object m a = ObjectType m a => Object
+    { objId :: ObjectId
+    , objImpl :: a
+    }
+
+data SomeObject m = forall a. ObjectType m a => SomeObject
+    { sobjId :: ObjectId
+    , sobjImpl :: a
+    }
+
+toSomeObject :: Object m a -> SomeObject m
+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }
+
+fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)
+fromSomeObject SomeObject {..} = do
+    let objId = sobjId
+    objImpl <- cast sobjImpl
+    return Object {..}
+
+destroySomeObject :: SomeObject m -> m ()
+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
diff --git a/src/Test.hs b/src/Test.hs
index a9a2cdb..6c44e94 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -10,7 +10,9 @@ import Data.Typeable
 
 import Network
 import Process
+import Run.Monad
 import Script.Expr
+import Script.Object
 import Script.Shell
 
 data Test = Test
@@ -32,6 +34,7 @@ instance Monoid (TestBlock ()) where
 
 data TestStep a where
     Scope :: TestBlock a -> TestStep a
+    CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep ()
     Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a
     DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a
     Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a