diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## Unreleased changes +## 0.2.1.0 + +* Improve clock management; don't keep incrementing it when nothing and restart it when r/R are pressed. + ## 0.2.0.0 * Allow any formatter except TUI to be used with --repeat N. diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Yet another test framework for Haskell description: Please see the . category: Testing diff --git a/src/Test/Sandwich/Formatters/TerminalUI.hs b/src/Test/Sandwich/Formatters/TerminalUI.hs --- a/src/Test/Sandwich/Formatters/TerminalUI.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI.hs @@ -35,6 +35,8 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) +import Control.Monad.Trans +import Control.Monad.Trans.State hiding (get, put) import Data.Either import Data.Foldable import qualified Data.List as L @@ -81,7 +83,7 @@ liftIO $ setInitialFolding terminalUIInitialFolding rts - rtsFixed <- liftIO $ atomically $ mapM fixRunTree rts + (rtsFixed, initialSomethingRunning) <- liftIO $ atomically $ runStateT (mapM fixRunTree' rts) False let initialState = updateFilteredTree $ AppState { @@ -92,6 +94,7 @@ , _appStartTime = startTime , _appCurrentTime = startTime + , _appSomethingRunning = initialSomethingRunning , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : (fmap runTreeVisibilityLevel $ concatMap getCommons rts) , _appVisibilityThreshold = terminalUIVisibilityThreshold @@ -114,13 +117,13 @@ eventAsync <- liftIO $ async $ forever $ do handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do - newFixedTree <- atomically $ do - currentFixed <- readTVar currentFixedTree - newFixed <- mapM fixRunTree rts - when (fmap getCommons newFixed == fmap getCommons currentFixed) retry - writeTVar currentFixedTree newFixed + (newFixedTree, somethingRunning) <- atomically $ flip runStateT False $ do + currentFixed <- lift $ readTVar currentFixedTree + newFixed <- mapM fixRunTree' rts + when (fmap getCommons newFixed == fmap getCommons currentFixed) (lift retry) + lift $ writeTVar currentFixedTree newFixed return newFixed - writeBChan eventChan (RunTreeUpdated newFixedTree) + writeBChan eventChan (RunTreeUpdated newFixedTree somethingRunning) threadDelay terminalUIRefreshPeriod let buildVty = do @@ -175,15 +178,17 @@ #else appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName (Next AppState) #endif -appEvent s (AppEvent (RunTreeUpdated newTree)) = do +appEvent s (AppEvent (RunTreeUpdated newTree somethingRunning)) = do now <- liftIO getCurrentTime continue $ s & appRunTree .~ newTree & appCurrentTime .~ now + & appSomethingRunning .~ somethingRunning & updateFilteredTree appEvent s (AppEvent (CurrentTimeUpdated ts)) = do - continue $ s - & appCurrentTime .~ ts + continue $ case (s ^. appSomethingRunning) of + True -> s & appCurrentTime .~ ts + False -> s appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do lookupExtent ColorBar >>= \case @@ -255,25 +260,33 @@ (readTVarIO $ runTreeStatus node) >>= \case Running {..} -> cancel statusAsync _ -> return () - V.EvKey c [] | c == runAllKey -> withContinueS s $ do + V.EvKey c [] | c == runAllKey -> do + now <- liftIO getCurrentTime when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do mapM_ clearRecursively (s ^. appRunTreeBase) void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext) - V.EvKey c [] | c == runSelectedKey -> withContinueS s $ + continue $ s + & appStartTime .~ now + & appCurrentTime .~ now + V.EvKey c [] | c == runSelectedKey -> whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of - Running {} -> return () + Running {} -> continue s _ -> do -- Get the set of IDs for only this node's ancestors and children let ancestorIds = S.fromList $ toList $ runTreeAncestors node case findRunNodeChildrenById ident (s ^. appRunTree) of - Nothing -> return () + Nothing -> continue s Just childIds -> do let allIds = ancestorIds <> childIds -- Clear the status of all affected nodes liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` allIds)) (s ^. appRunTreeBase) -- Start a run for all affected nodes + now <- liftIO getCurrentTime let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds } void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc + continue $ s + & appStartTime .~ now + & appCurrentTime .~ now V.EvKey c [] | c == clearSelectedKey -> withContinueS s $ do whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of Running {} -> return () diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs @@ -86,8 +86,9 @@ | CustomTUIExceptionBrick (forall n. B.Widget n) data AppEvent = - RunTreeUpdated [RunNodeFixed BaseContext] - | CurrentTimeUpdated UTCTime + RunTreeUpdated { runTreeUpdateTree :: [RunNodeFixed BaseContext] + , runTreeUpdateSomethingRunning :: Bool } + | CurrentTimeUpdated { currentTimeUpdatedTs :: UTCTime} instance Show AppEvent where show (RunTreeUpdated {}) = "" @@ -117,8 +118,11 @@ , _appMainList :: L.List ClickableName MainListElem , _appBaseContext :: BaseContext + -- | Set at formatter initialization and never changed , _appStartTime :: UTCTime + -- | Only incremented when some test is running , _appCurrentTime :: UTCTime + , _appSomethingRunning :: Bool , _appVisibilityThresholdSteps :: [Int] , _appVisibilityThreshold :: Int diff --git a/src/Test/Sandwich/RunTree.hs b/src/Test/Sandwich/RunTree.hs --- a/src/Test/Sandwich/RunTree.hs +++ b/src/Test/Sandwich/RunTree.hs @@ -1,8 +1,25 @@ {-# LANGUAGE RankNTypes #-} -module Test.Sandwich.RunTree where +module Test.Sandwich.RunTree ( + fixRunTree + , unFixRunTree + , fixRunTree' + , extractValues + , extractValuesControlRecurse + , getCommons + + , isDone + , isFailure + , isRunning + + , whenFailure + , isFailureStatus + ) where + import Control.Concurrent.STM +import Control.Monad.Trans +import Control.Monad.Trans.State import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec @@ -29,12 +46,19 @@ getCommons = extractValues runNodeCommon fixRunTree :: RunNode context -> STM (RunNodeFixed context) -fixRunTree node@(runNodeCommon -> (RunNodeCommonWithStatus {..})) = do - status <- readTVar runTreeStatus - logs <- readTVar runTreeLogs - toggled <- readTVar runTreeToggled - open <- readTVar runTreeOpen +fixRunTree node = evalStateT (fixRunTree' node) False +fixRunTree' :: RunNode context -> StateT Bool STM (RunNodeFixed context) +fixRunTree' node@(runNodeCommon -> (RunNodeCommonWithStatus {..})) = do + status <- lift $ readTVar runTreeStatus + logs <- lift $ readTVar runTreeLogs + toggled <- lift $ readTVar runTreeToggled + open <- lift $ readTVar runTreeOpen + + case status of + Running {} -> put True -- Note that something is running + _ -> return () + let common' = RunNodeCommonWithStatus { runTreeStatus = status , runTreeLogs = logs @@ -45,25 +69,25 @@ case node of RunNodeBefore {..} -> do - children <- mapM fixRunTree runNodeChildren + children <- mapM fixRunTree' runNodeChildren return $ RunNodeBefore { runNodeCommon=common', runNodeChildren=children, .. } RunNodeAfter {..} -> do - children <- mapM fixRunTree runNodeChildren + children <- mapM fixRunTree' runNodeChildren return $ RunNodeAfter { runNodeCommon=common', runNodeChildren=children, .. } RunNodeIntroduce {..} -> do - children <- mapM fixRunTree runNodeChildrenAugmented + children <- mapM fixRunTree' runNodeChildrenAugmented return $ RunNodeIntroduce { runNodeCommon=common', runNodeChildrenAugmented=children, .. } RunNodeIntroduceWith {..} -> do - children <- mapM fixRunTree runNodeChildrenAugmented + children <- mapM fixRunTree' runNodeChildrenAugmented return $ RunNodeIntroduceWith { runNodeCommon=common', runNodeChildrenAugmented=children, .. } RunNodeAround {..} -> do - children <- mapM fixRunTree runNodeChildren + children <- mapM fixRunTree' runNodeChildren return $ RunNodeAround { runNodeCommon=common', runNodeChildren=children, .. } RunNodeDescribe {..} -> do - children <- mapM fixRunTree runNodeChildren + children <- mapM fixRunTree' runNodeChildren return $ RunNodeDescribe { runNodeCommon=common', runNodeChildren=children, .. } RunNodeParallel {..} -> do - children <- mapM fixRunTree runNodeChildren + children <- mapM fixRunTree' runNodeChildren return $ RunNodeParallel { runNodeCommon=common', runNodeChildren=children, .. } RunNodeIt {..} -> do return $ RunNodeIt { runNodeCommon=common', .. } @@ -126,9 +150,9 @@ isFailure (Failure {}) = True isFailure _ = False -isPending :: Result -> Bool -isPending (Failure (Pending {})) = True -isPending _ = False +-- isPending :: Result -> Bool +-- isPending (Failure (Pending {})) = True +-- isPending _ = False whenFailure :: (Monad m) => Result -> (FailureReason -> m ()) -> m () whenFailure (Failure (Pending {})) _ = return ()