sandwich 0.2.0.0 → 0.2.1.0
raw patch · 5 files changed
+78/−33 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- sandwich.cabal +1/−1
- src/Test/Sandwich/Formatters/TerminalUI.hs +27/−14
- src/Test/Sandwich/Formatters/TerminalUI/Types.hs +6/−2
- src/Test/Sandwich/RunTree.hs +40/−16
CHANGELOG.md view
@@ -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.
sandwich.cabal view
@@ -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 <https://codedownio.github.io/sandwich documentation>. category: Testing
src/Test/Sandwich/Formatters/TerminalUI.hs view
@@ -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 ()
src/Test/Sandwich/Formatters/TerminalUI/Types.hs view
@@ -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 {}) = "<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
src/Test/Sandwich/RunTree.hs view
@@ -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 ()