module Test.Sandwich.Shutdown where import Control.Concurrent.Async import Control.Concurrent.STM import Data.Time import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec cancelNode :: RunNode context -> IO () cancelNode :: forall context. RunNode context -> IO () cancelNode RunNode context node = forall a. TVar a -> IO a readTVarIO (forall s l t. RunNodeCommonWithStatus s l t -> s runTreeStatus forall a b. (a -> b) -> a -> b $ forall s l t context. RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t runNodeCommon RunNode context node) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Running {UTCTime Async Result statusAsync :: Status -> Async Result statusStartTime :: Status -> UTCTime statusAsync :: Async Result statusStartTime :: UTCTime ..} -> forall a. Async a -> IO () cancel Async Result statusAsync Status NotStarted -> do UTCTime now <- IO UTCTime getCurrentTime forall a. STM a -> IO a atomically forall a b. (a -> b) -> a -> b $ forall a. TVar a -> a -> STM () writeTVar (forall s l t. RunNodeCommonWithStatus s l t -> s runTreeStatus forall a b. (a -> b) -> a -> b $ forall s l t context. RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t runNodeCommon RunNode context node) (UTCTime -> UTCTime -> Result -> Status Done UTCTime now UTCTime now Result Cancelled) Done {} -> forall (m :: * -> *) a. Monad m => a -> m a return ()