diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/GDB.hs-boot | 6 | ||||
| -rw-r--r-- | src/Main.hs | 67 | ||||
| -rw-r--r-- | src/Process.hs | 1 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 91 | ||||
| -rw-r--r-- | src/Test.hs | 4 |
6 files changed, 100 insertions, 70 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index f869075..47c3639 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -39,6 +39,7 @@ executable erebos-tester-core Output Parser Process + Run.Monad Test Util other-extensions: TemplateHaskell diff --git a/src/GDB.hs-boot b/src/GDB.hs-boot new file mode 100644 index 0000000..608ba7c --- /dev/null +++ b/src/GDB.hs-boot @@ -0,0 +1,6 @@ +module GDB where + +import Output + +data GDB +gdbSession :: MonadOutput m => GDB -> m () diff --git a/src/Main.hs b/src/Main.hs index 8864883..1c1f03c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,7 +9,6 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader -import Data.Map (Map) import Data.Map qualified as M import Data.Maybe import Data.Scientific @@ -35,74 +34,10 @@ import Network import Output import Parser import Process +import Run.Monad import Test import Util -data Options = Options - { optDefaultTool :: String - , optProcTools :: [(ProcName, String)] - , optTestDir :: FilePath - , optVerbose :: Bool - , optTimeout :: Scientific - , optGDB :: Bool - , optForce :: Bool - } - -defaultOptions :: Options -defaultOptions = Options - { optDefaultTool = "" - , optProcTools = [] - , optTestDir = ".test" - , optVerbose = False - , optTimeout = 1 - , optGDB = False - , optForce = False - } - -data TestEnv = TestEnv - { teOutput :: Output - , teFailed :: TVar (Maybe Failed) - , teOptions :: Options - , teProcesses :: MVar [Process] - , teGDB :: Maybe (MVar GDB) - } - -data TestState = TestState - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] - , tsNodePacketLoss :: Map NodeName Scientific - } - -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } - deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) - -instance MonadFail TestRun where - fail str = do - outLine OutputError Nothing $ T.pack str - throwError Failed - -instance MonadError Failed TestRun where - throwError failed = do - failedVar <- asks $ teFailed . fst - liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed) - - te <- asks fst - case failed of - ProcessCrashed _ | Just mgdb <- teGDB te -> do - maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb) - _ -> return () - - TestRun $ throwError failed - - catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler - -instance MonadEval TestRun where - lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) - rootNetwork = asks $ tsNetwork . snd - -instance MonadOutput TestRun where - getOutput = asks $ teOutput . fst - withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s }) diff --git a/src/Process.hs b/src/Process.hs index a1a421f..9979f41 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -26,6 +26,7 @@ import System.Process import Network import Output +import Run.Monad import Test data Process = Process diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs new file mode 100644 index 0000000..77e47ea --- /dev/null +++ b/src/Run/Monad.hs @@ -0,0 +1,91 @@ +module Run.Monad ( + TestRun(..), + TestEnv(..), + TestState(..), + Options(..), defaultOptions, + Failed(..), +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Map (Map) +import Data.Scientific +import qualified Data.Text as T + +import {-# SOURCE #-} GDB +import {-# SOURCE #-} Network +import Output +import {-# SOURCE #-} Process +import Test + +newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } + deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) + +data TestEnv = TestEnv + { teOutput :: Output + , teFailed :: TVar (Maybe Failed) + , teOptions :: Options + , teProcesses :: MVar [Process] + , teGDB :: Maybe (MVar GDB) + } + +data TestState = TestState + { tsNetwork :: Network + , tsVars :: [(VarName, SomeVarValue)] + , tsNodePacketLoss :: Map NodeName Scientific + } + +data Options = Options + { optDefaultTool :: String + , optProcTools :: [(ProcName, String)] + , optTestDir :: FilePath + , optVerbose :: Bool + , optTimeout :: Scientific + , optGDB :: Bool + , optForce :: Bool + } + +defaultOptions :: Options +defaultOptions = Options + { optDefaultTool = "" + , optProcTools = [] + , optTestDir = ".test" + , optVerbose = False + , optTimeout = 1 + , optGDB = False + , optForce = False + } + +data Failed = Failed + | ProcessCrashed Process + +instance MonadFail TestRun where + fail str = do + outLine OutputError Nothing $ T.pack str + throwError Failed + +instance MonadError Failed TestRun where + throwError failed = do + failedVar <- asks $ teFailed . fst + liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed) + + te <- asks fst + case failed of + ProcessCrashed _ | Just mgdb <- teGDB te -> do + maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb) + _ -> return () + + TestRun $ throwError failed + + catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler + +instance MonadEval TestRun where + lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) + rootNetwork = asks $ tsNetwork . snd + +instance MonadOutput TestRun where + getOutput = asks $ teOutput . fst diff --git a/src/Test.hs b/src/Test.hs index 16936bb..11cbca8 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,7 +1,6 @@ module Test ( Test(..), TestStep(..), - Failed(..), SourceLine(..), MonadEval(..), @@ -42,9 +41,6 @@ data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestSte | PacketLoss (Expr Scientific) (Expr Node) [TestStep] | Wait -data Failed = Failed - | ProcessCrashed Process - newtype SourceLine = SourceLine Text |