sandwich 0.3.0.2 → 0.3.0.3
raw patch · 10 files changed
+126/−81 lines, 10 files
Files
- CHANGELOG.md +8/−0
- sandwich.cabal +1/−1
- src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +2/−2
- src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs +29/−10
- src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +4/−4
- src/Test/Sandwich/Golden.hs +2/−2
- src/Test/Sandwich/Interpreters/StartTree.hs +69/−52
- src/Test/Sandwich/Shutdown.hs +1/−1
- src/Test/Sandwich/Types/RunTree.hs +4/−3
- src/Test/Sandwich/Types/Spec.hs +6/−6
CHANGELOG.md view
@@ -2,7 +2,15 @@ ## Unreleased +## 0.3.0.3++* Add 'ContainerOptions' type to `Test.Sandwich.Contexts.Container`+* Improve display of setup/work/teardown in TUI++## 0.3.0.2+ * Re-fix compatibility for base < 4.14.0.0+* windows: fix Infinity -> maxBound for an Int ## 0.3.0.1
sandwich.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-version: 0.3.0.2+version: 0.3.0.3 synopsis: Yet another test framework for Haskell description: Please see the <https://codedownio.github.io/sandwich documentation>. category: Testing
src/Test/Sandwich/Formatters/TerminalUI/Draw.hs view
@@ -76,8 +76,8 @@ , str "]"] , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]") , if not (app ^. appShowRunTimes) then Nothing else case status of- Running {..} -> Just $ getRunTimes app statusStartTime (app ^. appCurrentTime) statusSetupTime Nothing True- Done {..} -> Just $ getRunTimes app statusStartTime statusEndTime statusSetupTime statusTeardownTime False+ Running {..} -> Just $ getRunTimes app statusStartTime statusSetupFinishTime statusTeardownStartTime (app ^. appCurrentTime) True+ Done {..} -> Just $ getRunTimes app statusStartTime statusSetupFinishTime statusTeardownStartTime statusEndTime False _ -> Nothing ]
src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE MultiWayIf #-} -module Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes (getRunTimes) where+module Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes (+ getRunTimes+ ) where import Brick import Data.Maybe@@ -16,20 +19,36 @@ minGray = 50 maxGray = 255 -getRunTimes :: AppState -> UTCTime -> UTCTime -> Maybe NominalDiffTime -> Maybe NominalDiffTime -> Bool -> Widget n-getRunTimes app startTime endTime statusSetupTime statusTeardownTime showEllipses = raw setupWork <+> raw actualWork <+> raw teardownWork+data Mode =+ NothingRunning+ | SetupRunning+ | WorkRunning+ | TeardownRunning+ deriving (Eq)++getRunTimes :: AppState -> UTCTime -> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Bool -> Widget n+getRunTimes app startTime statusSetupFinishTime statusTeardownStartTime endTime showEllipses = raw setupWork <+> raw actualWork <+> raw teardownWork where totalElapsed = diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime) - actualWorkTime = (diffUTCTime endTime startTime) - (fromMaybe 0 statusSetupTime) - (fromMaybe 0 statusTeardownTime)+ setupTime = diffUTCTime <$> statusSetupFinishTime <*> pure startTime+ teardownTime = diffUTCTime <$> pure endTime <*> statusTeardownStartTime - setupWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt) [i|(#{formatNominalDiffTime dt}) + |]) statusSetupTime- actualWork = V.string (getAttr totalElapsed actualWorkTime) (formatNominalDiffTime actualWorkTime <> (if showEllipses then "..." else ""))- teardownWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt) [i| + (#{formatNominalDiffTime dt})|]) statusTeardownTime+ actualWorkTime = (diffUTCTime endTime startTime) - (fromMaybe 0 setupTime) - (fromMaybe 0 teardownTime) -getAttr :: NominalDiffTime -> NominalDiffTime -> V.Attr-getAttr totalElapsed dt = V.Attr {- V.attrStyle = V.Default+ mode = if+ | not showEllipses -> NothingRunning+ | isJust statusTeardownStartTime -> TeardownRunning+ | isJust statusSetupFinishTime -> WorkRunning+ | otherwise -> SetupRunning++ setupWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt (mode == SetupRunning)) [i|(#{formatNominalDiffTime dt}) + |]) setupTime+ actualWork = V.string (getAttr totalElapsed actualWorkTime (mode == WorkRunning)) (formatNominalDiffTime actualWorkTime)+ teardownWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt (mode == TeardownRunning)) [i| + (#{formatNominalDiffTime dt})|]) teardownTime++getAttr :: NominalDiffTime -> NominalDiffTime -> Bool -> V.Attr+getAttr totalElapsed dt bold = V.Attr {+ V.attrStyle = if bold then (V.SetTo V.bold) else V.Default , V.attrForeColor = V.SetTo $ grayAt $ getLevel (realToFrac totalElapsed) (realToFrac dt) , V.attrBackColor = V.Default , V.attrURL = V.Default
src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs view
@@ -5,7 +5,6 @@ import Brick import Brick.Widgets.Border-import UnliftIO.Exception import Control.Monad.Reader import qualified Data.List as L import Data.Maybe@@ -20,6 +19,7 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Text.Show.Pretty as P+import UnliftIO.Exception class ToBrickWidget a where@@ -28,10 +28,10 @@ instance ToBrickWidget Status where toBrickWidget (NotStarted {}) = return $ strWrap "Not started." toBrickWidget (Running {statusStartTime}) = return $ strWrap [i|Started at #{statusStartTime}.|]- toBrickWidget (Done startTime endTime setupTime teardownTime Success) = return $ strWrap ([i|Succeeded in #{showTimeDiff startTime endTime}.#{setupTeardownInfo}|])+ toBrickWidget (Done startTime setupFinishTime teardownStartTime endTime Success) = return $ strWrap ([i|Succeeded in #{showTimeDiff startTime endTime}.#{setupTeardownInfo}|]) where- setupInfo :: Maybe T.Text = (\t -> [i|Setup: #{formatNominalDiffTime t}.|]) <$> setupTime- teardownInfo :: Maybe T.Text = (\t -> [i|Teardown: #{formatNominalDiffTime t}.|]) <$> teardownTime+ setupInfo :: Maybe T.Text = (\t -> [i|Setup: #{formatNominalDiffTime t}.|]) <$> (flip diffUTCTime startTime <$> setupFinishTime)+ teardownInfo :: Maybe T.Text = (\t -> [i|Teardown: #{formatNominalDiffTime t}.|]) <$> (diffUTCTime endTime <$> teardownStartTime) setupTeardownInfo = case catMaybes [setupInfo, teardownInfo] of [] -> "" xs -> " (" <> T.intercalate " " xs <> ")"
src/Test/Sandwich/Golden.hs view
@@ -8,14 +8,14 @@ -- * Main test function golden - -- * Built-in Goldens.+ -- * Built-in Goldens , goldenText , goldenString , goldenJSON , goldenShowable , mkGolden - -- * Parameters for a 'Golden'.+ -- * Parameters for a 'Golden' , goldenOutput , goldenWriteToFile , goldenReadFromFile
src/Test/Sandwich/Interpreters/StartTree.hs view
@@ -10,7 +10,6 @@ import Control.Concurrent.Async import Control.Concurrent.MVar-import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger@@ -41,6 +40,7 @@ import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util import UnliftIO.Exception+import UnliftIO.STM baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext@@ -53,20 +53,20 @@ let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case- (result@(Failure fr@(Pending {})), setupTime) -> do+ (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr)- return (result, mkSetupTimingInfo setupTime)- (result@(Failure fr), setupTime) -> do+ return (result, mkSetupTimingInfo setupFinishTime)+ (result@(Failure fr), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException fr))- return (result, mkSetupTimingInfo setupTime)- (Success, setupTime) -> do+ return (result, mkSetupTimingInfo setupFinishTime)+ (Success, _setupStartTime, setupFinishTime) -> do void $ runNodesSequentially runNodeChildren ctx- return (Success, mkSetupTimingInfo setupTime)- (Cancelled, setupTime) -> do- return (Cancelled, mkSetupTimingInfo setupTime)- (DryRun, setupTime) -> do+ return (Success, mkSetupTimingInfo setupFinishTime)+ (Cancelled, _setupStartTime, setupFinishTime) -> do+ return (Cancelled, mkSetupTimingInfo setupFinishTime)+ (DryRun, _setupStartTime, setupFinishTime) -> do void $ runNodesSequentially runNodeChildren ctx- return (DryRun, mkSetupTimingInfo setupTime)+ return (DryRun, mkSetupTimingInfo setupFinishTime) startTree node@(RunNodeAfter {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon@@ -74,8 +74,8 @@ result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx) (do- (ret, dt) <- timed (runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]))- writeIORef result (ret, mkTeardownTimingInfo dt)+ (ret, teardownStartTime, _teardownFinishTime) <- timed (runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]))+ writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) ) liftIO $ readIORef result startTree node@(RunNodeIntroduce {..}) ctx' = do@@ -87,27 +87,31 @@ let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ timed (runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])))- (\(ret, setupTime) -> case ret of- Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupTime)+ (\(ret, setupStartTime, setupFinishTime) -> case ret of+ Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) Right intro -> do- (ret', teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])- writeIORef result (ret', ExtraTimingInfo (Just setupTime) (Just teardownTime))+ teardownStartTime <- getCurrentTime+ addTeardownStartTimeToStatus runTreeStatus teardownStartTime+ ret' <- runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])+ writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) )- (\(ret, _setupTime) -> case ret of- Left failureReason@(Pending {}) -> do- -- TODO: add note about failure in allocation- markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)- Left failureReason -> do- -- TODO: add note about failure in allocation- markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason))- Right intro -> do- -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.- -- It would be better to track the profile at the type level- let ctxFinal = case cast intro of- Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t })- Nothing -> ctx+ (\(ret, _setupStartTime, setupFinishTime) -> do+ addSetupFinishTimeToStatus runTreeStatus setupFinishTime+ case ret of+ Left failureReason@(Pending {}) -> do+ -- TODO: add note about failure in allocation+ markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)+ Left failureReason -> do+ -- TODO: add note about failure in allocation+ markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason))+ Right intro -> do+ -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.+ -- It would be better to track the profile at the type level+ let ctxFinal = case cast intro of+ Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t })+ Nothing -> ctx - void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal)+ void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) ) readIORef result startTree node@(RunNodeIntroduceWith {..}) ctx' = do@@ -121,25 +125,24 @@ _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do beginningCleanupVar <- liftIO $ newIORef Nothing- startTime <- liftIO getCurrentTime results <- runNodeIntroduceAction $ \intro -> do- afterMakingIntroTime <- liftIO getCurrentTime- let setupTime = diffUTCTime afterMakingIntroTime startTime+ setupFinishTime <- liftIO getCurrentTime+ addSetupFinishTimeToStatus runTreeStatus setupFinishTime results <- liftIO $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctx) - beginningCleanupTs <- liftIO getCurrentTime- liftIO $ writeIORef beginningCleanupVar (Just beginningCleanupTs)+ teardownStartTime <- liftIO getCurrentTime+ addTeardownStartTimeToStatus runTreeStatus teardownStartTime+ liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime) - liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupTime)+ liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime) return results - endTime <- liftIO getCurrentTime liftIO (readIORef beginningCleanupVar) >>= \case Nothing -> return ()- Just beginningCleanupTs ->+ Just teardownStartTime -> liftIO $ modifyIORef' didRunWrappedAction $- \(ret, timingInfo) -> (ret, timingInfo { teardownTime = Just (diffUTCTime endTime beginningCleanupTs) })+ \(ret, timingInfo) -> (ret, timingInfo { teardownStartTime = Just teardownStartTime }) return results @@ -159,12 +162,11 @@ Just fr@(Pending {}) -> Failure fr _ -> Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildren ctx (failureResult e)) $ do- startTime <- liftIO getCurrentTime runNodeActionWith $ do- setupEndTime <- liftIO getCurrentTime- let setupTime = diffUTCTime setupEndTime startTime+ setupFinishTime <- liftIO getCurrentTime+ addSetupFinishTimeToStatus runTreeStatus setupFinishTime results <- liftIO $ runNodesSequentially runNodeChildren ctx- liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupTime)+ liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime) return results (liftIO $ readIORef didRunWrappedAction) >>= \case@@ -206,7 +208,7 @@ readMVar mvar (result, extraTimingInfo) <- timerFn action endTime <- liftIO getCurrentTime- liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime endTime (setupTime extraTimingInfo) (teardownTime extraTimingInfo) result+ liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime (setupFinishTime extraTimingInfo) (teardownStartTime extraTimingInfo) endTime result whenFailure result $ \reason -> do -- Make sure the folder exists, if configured@@ -260,7 +262,7 @@ printLogs runTreeLogs return result- liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing myAsync+ liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing Nothing myAsync liftIO $ putMVar mvar () return myAsync -- TODO: fix race condition with writing to runTreeStatus (here and above) @@ -282,7 +284,10 @@ markAllChildrenWithResult children baseContext status = do now <- liftIO getCurrentTime forM_ (L.filter (shouldRunChild' baseContext) $ concatMap getCommons children) $ \child ->- liftIO $ atomically $ writeTVar (runTreeStatus child) (Done now now Nothing Nothing status)+ liftIO $ atomically $ modifyTVar (runTreeStatus child) $ \case+ Running {..} -> Done now statusSetupFinishTime statusTeardownStartTime now status+ done@(Done {}) -> done { statusResult = status }+ _ -> Done now Nothing Nothing now status cancelAllChildrenWith :: [RunNode context] -> SomeAsyncException -> IO () cancelAllChildrenWith children e = do@@ -292,7 +297,7 @@ NotStarted -> do now <- getCurrentTime let reason = GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq e)- atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Nothing Nothing (Failure reason))+ atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now Nothing Nothing now (Failure reason)) _ -> return () shouldRunChild :: (HasBaseContext ctx) => ctx -> RunNodeWithStatus context s l t -> Bool@@ -343,6 +348,18 @@ Just (SomeExceptionWithCallStack e' cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e')) _ -> GotException Nothing msg (SomeExceptionWithEq e) +addSetupFinishTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()+addSetupFinishTimeToStatus statusVar setupFinishTime = atomically $ modifyTVar statusVar $ \case+ status@(Running {}) -> status { statusSetupFinishTime = Just setupFinishTime }+ status@(Done {}) -> status { statusSetupFinishTime = Just setupFinishTime }+ x -> x++addTeardownStartTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()+addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar statusVar $ \case+ status@(Running {}) -> status { statusTeardownStartTime = Just t }+ status@(Done {}) -> status { statusTeardownStartTime = Just t }+ x -> x+ recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m () recordExceptionInStatus status e = do endTime <- liftIO getCurrentTime@@ -352,12 +369,12 @@ Just (e' :: FailureReason) -> Failure e' _ -> Failure (GotException Nothing Nothing (SomeExceptionWithEq e)) liftIO $ atomically $ modifyTVar status $ \case- Running {statusStartTime, statusSetupTime} -> Done statusStartTime endTime statusSetupTime Nothing ret- _ -> Done endTime endTime Nothing Nothing ret+ Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret+ _ -> Done endTime Nothing Nothing endTime ret -timed :: (MonadIO m) => m a -> m (a, NominalDiffTime)+timed :: (MonadIO m) => m a -> m (a, UTCTime, UTCTime) timed action = do startTime <- liftIO getCurrentTime ret <- action endTime <- liftIO getCurrentTime- pure (ret, diffUTCTime endTime startTime)+ pure (ret, startTime, endTime)
src/Test/Sandwich/Shutdown.hs view
@@ -13,5 +13,5 @@ Running {..} -> cancel statusAsync NotStarted -> do now <- getCurrentTime- atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Nothing Nothing Cancelled)+ atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now Nothing Nothing now Cancelled) Done {} -> return ()
src/Test/Sandwich/Types/RunTree.hs view
@@ -30,12 +30,13 @@ data Status = NotStarted | Running { statusStartTime :: UTCTime- , statusSetupTime :: Maybe NominalDiffTime+ , statusSetupFinishTime :: Maybe UTCTime+ , statusTeardownStartTime :: Maybe UTCTime , statusAsync :: Async Result } | Done { statusStartTime :: UTCTime+ , statusSetupFinishTime :: Maybe UTCTime+ , statusTeardownStartTime :: Maybe UTCTime , statusEndTime :: UTCTime- , statusSetupTime :: Maybe NominalDiffTime- , statusTeardownTime :: Maybe NominalDiffTime , statusResult :: Result } deriving (Show, Eq)
src/Test/Sandwich/Types/Spec.hs view
@@ -87,18 +87,18 @@ deriving (Show, Eq) data ExtraTimingInfo = ExtraTimingInfo {- setupTime :: Maybe NominalDiffTime- , teardownTime :: Maybe NominalDiffTime+ setupFinishTime :: Maybe UTCTime+ , teardownStartTime :: Maybe UTCTime } emptyExtraTimingInfo :: ExtraTimingInfo emptyExtraTimingInfo = ExtraTimingInfo Nothing Nothing -mkSetupTimingInfo :: NominalDiffTime -> ExtraTimingInfo-mkSetupTimingInfo dt = ExtraTimingInfo (Just dt) Nothing+mkSetupTimingInfo :: UTCTime -> ExtraTimingInfo+mkSetupTimingInfo setupFinishTime = ExtraTimingInfo (Just setupFinishTime) Nothing -mkTeardownTimingInfo :: NominalDiffTime -> ExtraTimingInfo-mkTeardownTimingInfo dt = ExtraTimingInfo Nothing (Just dt)+mkTeardownTimingInfo :: UTCTime -> ExtraTimingInfo+mkTeardownTimingInfo teardownStartTime = ExtraTimingInfo Nothing (Just teardownStartTime) data ShowEqBox = forall s. (Show s, Eq s) => SEB s instance Show ShowEqBox where show (SEB x) = show x