diff --git a/sandwich/package.yaml b/sandwich/package.yaml index d0dfaec9..c046201e 100644 --- a/sandwich/package.yaml +++ b/sandwich/package.yaml @@ -74,7 +74,7 @@ when: library: source-dirs: src ghc-options: - - -W + - -Wall exposed-modules: - Test.Sandwich - Test.Sandwich.Contexts diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal index 45a17011..39bab2e1 100644 --- a/sandwich/sandwich.cabal +++ b/sandwich/sandwich.cabal @@ -107,7 +107,7 @@ library RecordWildCards ScopedTypeVariables ViewPatterns - ghc-options: -W + ghc-options: -Wall build-depends: aeson , ansi-terminal diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs index 2378eb61..65369862 100644 --- a/sandwich/src/Test/Sandwich/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/ArgParsing.hs @@ -10,6 +10,7 @@ import Data.Function import qualified Data.List as L import Data.Maybe import qualified Data.Text as T +import Data.Time (UTCTime) import Data.Time.Clock.POSIX import Data.Typeable import Options.Applicative @@ -29,8 +30,10 @@ import Test.Sandwich.Types.Spec #if MIN_VERSION_time(1,9,0) import Data.Time.Format.ISO8601 +formatTime :: UTCTime -> String formatTime = T.unpack . T.replace ":" "_" . T.pack . iso8601Show #else +formatTime :: UTCTime -> String formatTime = show #endif diff --git a/sandwich/src/Test/Sandwich/Formatters/Common/Util.hs b/sandwich/src/Test/Sandwich/Formatters/Common/Util.hs index 633ad175..bcaaa3ad 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Common/Util.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Common/Util.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} --- | module Test.Sandwich.Formatters.Common.Util ( formatNominalDiffTime @@ -10,13 +9,14 @@ import Data.Time.Clock import Text.Printf formatNominalDiffTime :: NominalDiffTime -> String -formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^15)) <> "ps" -formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^12)) <> "ns" -formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^9)) <> "ns" -formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^6)) <> "us" -formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^3)) <> "ms" +formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(15 :: Integer))) <> "ps" +formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(12 :: Integer))) <> "ns" +formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(9 :: Integer))) <> "ns" +formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(6 :: Integer))) <> "us" +formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(3 :: Integer))) <> "ms" formatNominalDiffTime diff = (roundFixed (nominalDiffTimeToSeconds diff)) <> "s" +second, ms, us, ns, ps :: NominalDiffTime second = secondsToNominalDiffTime 1 ms = secondsToNominalDiffTime 0.001 us = secondsToNominalDiffTime 0.000001 diff --git a/sandwich/src/Test/Sandwich/Formatters/Print.hs b/sandwich/src/Test/Sandwich/Formatters/Print.hs index d649ce1c..18dec13d 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | The print formatter prints all results from the test tree from top to bottom, as they become available. -- @@ -44,7 +45,7 @@ instance Formatter PrintFormatter where finalizeFormatter _ _ _ = return () runApp :: (MonadIO m, MonadLogger m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m () -runApp pf@(PrintFormatter {..}) rts _maybeCommandLineOptions bc = liftIO $ do +runApp pf rts _maybeCommandLineOptions bc = liftIO $ do let total = countWhere isItBlock rts startTime <- getCurrentTime diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Color.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Color.hs index fda3f180..89598a8d 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/Color.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print/Color.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.Print.Color where diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs index dca0a854..4e677f6f 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs +++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Sandwich.Formatters.TerminalUI ( -- | The terminal UI formatter produces an interactive UI for running tests and inspecting their results. @@ -165,11 +166,13 @@ continue = put continueNoChange :: AppState -> EventM ClickableName AppState () continueNoChange _ = return () +doHalt :: p -> EventM n s () doHalt _ = halt #else continueNoChange :: AppState -> EventM ClickableName (Next AppState) continueNoChange = continue +doHalt :: p -> EventM n s doHalt = halt #endif @@ -209,8 +212,8 @@ appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do appEvent s (MouseDown (ListRow _i) V.BScrollDown _ _) = do vScrollBy (viewportScroll MainList) 1 continueNoChange s -appEvent s (MouseDown (ListRow i) V.BLeft _ _) = do - continue (s & appMainList %~ (listMoveTo i)) +appEvent s (MouseDown (ListRow n) V.BLeft _ _) = do + continue (s & appMainList %~ (listMoveTo n)) appEvent s (VtyEvent e) = case e of -- Column 1 @@ -219,7 +222,7 @@ appEvent s (VtyEvent e) = V.EvKey c [] | c == nextFailureKey -> do let ls = Vec.toList $ listElements (s ^. appMainList) let listToSearch = case listSelectedElement (s ^. appMainList) of - Just (i, MainListElem {}) -> let (front, back) = L.splitAt (i + 1) (zip [0..] ls) in back <> front + Just (n, MainListElem {}) -> let (front, back) = L.splitAt (n + 1) (zip [0..] ls) in back <> front Nothing -> zip [0..] ls case L.find (isFailureStatus . status . snd) listToSearch of Nothing -> continue s @@ -227,7 +230,7 @@ appEvent s (VtyEvent e) = V.EvKey c [] | c == previousFailureKey -> do let ls = Vec.toList $ listElements (s ^. appMainList) let listToSearch = case listSelectedElement (s ^. appMainList) of - Just (i, MainListElem {}) -> let (front, back) = L.splitAt i (zip [0..] ls) in (L.reverse front) <> (L.reverse back) + Just (n, MainListElem {}) -> let (front, back) = L.splitAt n (zip [0..] ls) in (L.reverse front) <> (L.reverse back) Nothing -> L.reverse (zip [0..] ls) case L.find (isFailureStatus . status . snd) listToSearch of Nothing -> continue s @@ -325,7 +328,7 @@ appEvent s (VtyEvent e) = -- Column 3 V.EvKey c [] | c == cycleVisibilityThresholdKey -> do - let newVisibilityThreshold = case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps) + let newVisibilityThreshold = case [(n, x) | (n, x) <- zip [(0 :: Integer)..] (s ^. appVisibilityThresholdSteps) , x > s ^. appVisibilityThreshold] of [] -> 0 xs -> minimum $ fmap snd xs @@ -354,19 +357,21 @@ appEvent s (VtyEvent e) = ev -> handleEventLensed s appMainList handleListEvent ev >>= continue #endif - where withContinueS s action = action >> continue s + where withContinueS s' action = action >> continue s' #if MIN_VERSION_brick(1,0,0) appEvent _ _ = return () #else appEvent s _ = continue s #endif +modifyToggled :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState () modifyToggled s f = case listSelectedElement (s ^. appMainList) of Nothing -> continue s Just (_i, MainListElem {..}) -> do liftIO $ atomically $ modifyTVar (runTreeToggled node) f continue s +modifyOpen :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState () modifyOpen s f = case listSelectedElement (s ^. appMainList) of Nothing -> continue s Just (_i, MainListElem {..}) -> do @@ -455,6 +460,7 @@ withScroll s action = do continue s #endif +openSrcLoc :: Ord n => AppState -> SrcLoc -> EventM n AppState () openSrcLoc s loc' = do -- Try to make the file path in the SrcLoc absolute loc <- case isRelative (srcLocFile loc') of diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs index 3a222896..6ac84882 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs @@ -18,7 +18,7 @@ import Data.String.Interpolate import qualified Data.Text.Encoding as E import Data.Time.Clock import GHC.Stack -import Lens.Micro +import Lens.Micro hiding (ix) import Safe import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Formatters.Common.Util @@ -43,6 +43,7 @@ drawUI app = [ui] , clickable ColorBar $ bottomProgressBarColored app ] +mainList :: AppState -> Widget ClickableName mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (app ^. appMainList) where listDrawElement ix isSelected x@(MainListElem {..}) = clickable (ListRow ix) $ padLeft (Pad (4 * depth)) $ (if isSelected then border else id) $ vBox $ catMaybes [ @@ -121,6 +122,7 @@ mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True ( logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|] +borderWithCounts :: AppState -> Widget n borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |] , withAttr totalAttr $ str $ show totalNumTests , str [i| in |] diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs index dee8d4aa..36d12776 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs +++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs @@ -12,9 +12,11 @@ import Test.Sandwich.Formatters.TerminalUI.AttrMap import Test.Sandwich.Formatters.TerminalUI.Types -minGray :: Int = 50 -maxGray :: Int = 255 +minGray, maxGray :: Int +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 where totalElapsed = diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime) diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 5ebe9020..c19e844a 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -65,13 +65,13 @@ runWithRepeat 0 totalTests action = do | otherwise -> exitFailure -- | For 1 repeat, run once and return runWithRepeat n totalTests action = do - (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n -> do + (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do (exitReason, numFailures) <- liftIO action modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1) if | exitReason == SignalExit -> return () - | n > 0 -> loop (n - 1) + | n' > 0 -> loop (n' - 1) | otherwise -> return () putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|] @@ -98,8 +98,8 @@ baseContextFromOptions options@(Options {..}) = do here <- getCurrentDirectory return $ here base' - name <- f - let dir = base name + name' <- f + let dir = base name' createDirectoryIfMissing True dir return $ Just dir diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index c02cdf31..0780a27a 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -53,7 +53,7 @@ startTree node@(RunNodeBefore {..}) ctx' = do 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 {})), setupTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr) return (result, mkSetupTimingInfo setupTime) (result@(Failure fr), setupTime) -> do @@ -90,8 +90,8 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do (\(ret, setupTime) -> case ret of Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupTime) 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)) + (ret', teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) + writeIORef result (ret', ExtraTimingInfo (Just setupTime) (Just teardownTime)) ) (\(ret, _setupTime) -> case ret of Left failureReason@(Pending {}) -> do @@ -340,7 +340,7 @@ runExampleM' ex ctx logs exceptionMessage = do wrapInFailureReasonIfNecessary msg e = return $ Left $ case fromException e of Just (x :: FailureReason) -> x _ -> case fromException e of - Just (SomeExceptionWithCallStack e cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e)) + Just (SomeExceptionWithCallStack e' cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e')) _ -> GotException Nothing msg (SomeExceptionWithEq e) recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m () diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 1fe8f106..7507de61 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -23,7 +23,6 @@ import Control.Concurrent.QSem import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Control (MonadBaseControl) import Test.Sandwich.Contexts import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree @@ -33,12 +32,12 @@ import Test.Sandwich.Types.Spec -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. parallelN :: ( - MonadBaseControl IO m, MonadIO m, MonadMask m + MonadIO m, MonadMask m ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( - MonadBaseControl IO m, MonadIO m, MonadMask m + MonadIO m, MonadMask m ) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $ parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children @@ -48,12 +47,12 @@ parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" par -- | Same as 'parallelN', but extracts the semaphore size from the command line options. parallelNFromArgs :: forall context a m. ( - MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a + MonadIO m, MonadMask m, HasCommandLineOptions context a ) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions parallelNFromArgs' :: forall context a m. ( - MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a + MonadIO m, MonadMask m, HasCommandLineOptions context a ) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $ parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children