diff options
Diffstat (limited to 'test-framework/Test/Framework.hs')
| -rw-r--r-- | test-framework/Test/Framework.hs | 167 |
1 files changed, 112 insertions, 55 deletions
diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs index 5ceb866..b7d0dc2 100644 --- a/test-framework/Test/Framework.hs +++ b/test-framework/Test/Framework.hs @@ -1,38 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Test.Framework ( TestTree, testGroup, groupSetCollapse, testProperty, - withResource, - withResource', runTests, defaultMain, Options(..), + -- * Resources + withResource, + withResource', + TestCtx, + outputWarningText, + -- * Compatibility TestName, ) where -import Control.Concurrent (setNumCapabilities, forkIO, killThread, forkOn) +import Control.Concurrent (setNumCapabilities, forkIO, forkOn, killThread) import Control.Concurrent.MVar import Control.Concurrent.STM -import Control.Exception (finally) -import Control.Monad (forM, when, forM_, replicateM_) +import Control.Exception (SomeException, throw, try, throwIO) +import Control.Monad (forM, when, forM_) import Control.Monad.IO.Class import Data.IORef import Data.List (isInfixOf, intercalate) -import Data.Maybe (isJust, mapMaybe, fromJust) +import Data.Maybe (mapMaybe, fromJust) +import Data.Monoid (All(..), Any(..), Sum(..)) import Data.PQueue.Prio.Min qualified as PQ import Data.String (fromString) import Data.Time.Clock import GHC.Conc (getNumProcessors) +import GHC.Generics (Generic, Generically(..)) import System.Console.ANSI qualified as ANSI import System.Console.Concurrent (outputConcurrent) import System.Console.Regions @@ -49,14 +59,23 @@ import Hedgehog.Internal.Runner qualified as H import Hedgehog.Internal.Seed qualified as H.Seed +-- TODO: with GHC 9.12 we have tryWithContext and rethrowIO, which is better for rethrowing exceptions + + type TestName = String data TestTree = Group GroupOpts String [TestTree] - | forall a. Resource String (IO a) (a -> IO ()) (a -> TestTree) + | forall a. Resource String ((?testCtx :: TestCtx) => IO a) ((?testCtx :: TestCtx) => a -> IO ()) (a -> TestTree) -- ^ Name is not specified by user, but inherited from the tree below | HP String H.Property +data TestCtx = TestCtx + { tctxOutput :: String -> IO () } + +outputWarningText :: (?testCtx :: TestCtx) => String -> IO () +outputWarningText = tctxOutput ?testCtx + -- Not exported because a Resource is not supposed to have a name in the first place treeName :: TestTree -> String treeName (Group _ name _) = name @@ -78,13 +97,13 @@ groupSetCollapse (Group opts name trees) = Group opts { goCollapse = True } name groupSetCollapse _ = error "groupSetCollapse: not called on a Group" -- | The @a -> TestTree@ function must use the @a@ only inside properties: the --- functoin will be passed 'undefined' when exploring the test tree (without +-- function will be passed 'undefined' when exploring the test tree (without -- running properties). -withResource :: IO a -> (a -> IO ()) -> (a -> TestTree) -> TestTree +withResource :: ((?testCtx :: TestCtx) => IO a) -> ((?testCtx :: TestCtx) => a -> IO ()) -> (a -> TestTree) -> TestTree withResource make cleanup fun = Resource (treeName (fun undefined)) make cleanup fun -- | Same caveats as 'withResource'. -withResource' :: IO a -> (a -> TestTree) -> TestTree +withResource' :: ((?testCtx :: TestCtx) => IO a) -> (a -> TestTree) -> TestTree withResource' make fun = withResource make (\_ -> return ()) fun testProperty :: String -> H.Property -> TestTree @@ -107,6 +126,11 @@ filterTree (Options { optsPattern = pat }) = go [] renderPath comps = "^" ++ intercalate "/" (reverse comps) ++ "$" +treeNumTests :: TestTree -> Int +treeNumTests (Group _ _ ts) = sum (map treeNumTests ts) +treeNumTests (Resource _ _ _ fun) = treeNumTests (fun undefined) +treeNumTests HP{} = 1 + computeMaxLen :: TestTree -> Int computeMaxLen = go 0 where @@ -217,10 +241,10 @@ runTests options = \tree' -> successVar <- newEmptyMVar runTreePar Nothing [] [] tree successVar readMVar successVar - else isJust <$> runTreeSeq 0 [] tree + else getAll . seqresAllSuccess <$> runTreeSeq 0 [] tree stats <- readIORef statsRef endtm <- getCurrentTime - let ?istty = isterm in printStats stats (diffUTCTime endtm starttm) + let ?istty = isterm in printStats (treeNumTests tree) stats (diffUTCTime endtm starttm) return (if success then ExitSuccess else ExitFailure 1) -- | Returns when all jobs in this tree have been scheduled. When all jobs are @@ -275,31 +299,37 @@ runTreePar topmparregion revidxlist revpath toptree@Resource{} topoutvar = runRe let pathitem = '[' : show depth ++ "](" ++ inhname ++ ")" path = intercalate "/" (reverse (pathitem : revpath)) idxlist = reverse revidxlist - -- outputConcurrent $ "! " ++ path ++ ": R Submitting\n" + let ?testCtx = TestCtx (\str -> + outputConcurrent (ansiYellow ++ "## Warning for " ++ path ++ ":" ++ ansiReset ++ + "\n" ++ str ++ "\n")) submitOrRunIn mparregion idxlist Nothing $ \makeRegion -> do setConsoleRegion makeRegion ('|' : path ++ " [R] making...") - -- outputConcurrent $ "! " ++ path ++ ": R Making\n" - value <- make -- TODO: catch exceptions - -- outputConcurrent $ "! " ++ path ++ ": R Made\n" - - -- outputConcurrent $ "! " ++ path ++ ": R Running subtree\n" - suboutvar <- newEmptyMVar - runResource (Just makeRegion) (depth + 1) (fun value) suboutvar -- will consume makeRegion - -- outputConcurrent $ "! " ++ path ++ ": R Scheduled subtree\n" + evalue <- try make + case evalue of + Left (err :: SomeException) -> do + finishConsoleRegion makeRegion $ + ansiRed ++ "Exception building resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err + putMVar outvar False + Right value -> do + suboutvar <- newEmptyMVar + runResource (Just makeRegion) (depth + 1) (fun value) suboutvar -- will consume makeRegion - _ <- forkIO $ do - success <- readMVar suboutvar - -- outputConcurrent $ "! " ++ path ++ ": R Subtree done, scheduling cleanup\n" - poolSubmit ?pool idxlist (Just outvar) $ do - cleanupRegion <- openConsoleRegion Linear - setConsoleRegion cleanupRegion ('|' : path ++ " [R] cleanup...") - -- outputConcurrent $ "! " ++ path ++ ": R Cleaning up\n" - cleanup value -- TODO: catch exceptions - -- outputConcurrent $ "! " ++ path ++ ": R Cleanup done\n" - closeConsoleRegion cleanupRegion - return success - return () + _ <- forkIO $ do + success <- readMVar suboutvar + poolSubmit ?pool idxlist Nothing $ do + cleanupRegion <- openConsoleRegion Linear + setConsoleRegion cleanupRegion ('|' : path ++ " [R] cleanup...") + eres <- try (cleanup value) + case eres of + Left (err :: SomeException) -> do + finishConsoleRegion cleanupRegion $ + ansiRed ++ "Exception cleaning up resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err + putMVar outvar False + Right () -> do + closeConsoleRegion cleanupRegion + putMVar outvar success + return () runResource mparregion _ tree outvar = runTreePar mparregion revidxlist revpath tree outvar runTreePar mparregion revidxlist revpath (HP name prop) outvar = do @@ -325,37 +355,51 @@ submitOrRunIn (Just reg) _idxlist outvar fun = do result <- fun reg forM_ outvar $ \mvar -> putMVar mvar result +data SeqRes = SeqRes + { seqresHaveWarnings :: Any + , seqresAllSuccess :: All + , seqresNumLines :: Sum Int } + deriving (Generic) + deriving (Semigroup, Monoid) via Generically SeqRes + -- | If all tests are successful, returns the number of output lines produced runTreeSeq :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int, ?istty :: Bool) - => Int -> [String] -> TestTree -> IO (Maybe Int) + => Int -> [String] -> TestTree -> IO SeqRes runTreeSeq indent revpath (Group opts name trees) = do putStrLn (replicate (2 * indent) ' ' ++ name) >> hFlush stdout starttm <- getCurrentTime - mlns <- fmap (fmap sum . sequence) . forM trees $ - runTreeSeq (indent + 1) (name : revpath) + res <- fmap mconcat . forM trees $ + runTreeSeq (indent + 1) (name : revpath) endtm <- getCurrentTime - case mlns of - Just lns | goCollapse opts, ?istty -> do + if not (getAny (seqresHaveWarnings res)) && getAll (seqresAllSuccess res) && goCollapse opts && ?istty + then do let thislen = 2*indent + length name + let Sum lns = seqresNumLines res putStrLn $ concat (replicate (lns+1) (ANSI.cursorUpCode 1 ++ ANSI.clearLineCode)) ++ ANSI.setCursorColumnCode 0 ++ replicate (2 * indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' ++ ansiGreen ++ "OK" ++ ansiReset ++ prettyDuration False (realToFrac (diffUTCTime endtm starttm)) - return (Just 1) - _ -> return ((+1) <$> mlns) + return (mempty { seqresNumLines = 1 }) + else return (res <> (mempty { seqresNumLines = 1 })) runTreeSeq indent path (Resource _ make cleanup fun) = do + outputted <- newIORef False + let ?testCtx = TestCtx (\str -> do + atomicModifyIORef' outputted (\_ -> (True, ())) + putStrLn (ansiYellow ++ "## Warning for " ++ (intercalate "/" (reverse path)) ++ + ":" ++ ansiReset ++ "\n" ++ str)) value <- make - success <- runTreeSeq indent path (fun value) + res <- runTreeSeq indent path (fun value) cleanup value - return success + warnings <- readIORef outputted + return (res <> (mempty { seqresHaveWarnings = Any warnings })) runTreeSeq indent path (HP name prop) = do let thislen = 2*indent + length name let prefix = replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' when ?istty $ putStr prefix >> hFlush stdout (ok, rendered) <- runHP (outputProgress (?maxlen + 2)) path name prop putStrLn ((if ?istty then ANSI.clearFromCursorToLineEndCode else prefix) ++ rendered) >> hFlush stdout - return (if ok then Just 1 else Nothing) + return (mempty { seqresAllSuccess = All ok, seqresNumLines = 1 }) runHP :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int) => (H.Report H.Progress -> IO ()) @@ -407,15 +451,19 @@ renderResult report path timeTaken = do return (str ++ suffix) _ -> return str -printStats :: (?istty :: Bool) => Stats -> NominalDiffTime -> IO () -printStats stats timeTaken - | statsOK stats == statsTotal stats = do +printStats :: (?istty :: Bool) => Int -> Stats -> NominalDiffTime -> IO () +printStats numTests stats timeTaken + | statsOK stats == numTests = do putStrLn $ ansiGreen ++ "All " ++ show (statsTotal stats) ++ " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ ansiReset + | statsOK stats == statsTotal stats = + putStrLn $ ansiRed ++ "Failed (" ++ show (numTests - statsTotal stats) ++ " tests could not run)." ++ + prettyDuration True (realToFrac timeTaken) ++ ansiReset | otherwise = let nfailed = statsTotal stats - statsOK stats - in putStrLn $ ansiRed ++ "Failed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ - " tests." ++ prettyDuration True (realToFrac timeTaken) ++ ansiReset + in putStrLn $ ansiRed ++ "Failed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ " tests" ++ + (if statsTotal stats /= numTests then " (" ++ show (numTests - statsTotal stats) ++ " could not run)" else "") ++ + "." ++ prettyDuration True (realToFrac timeTaken) ++ ansiReset newtype WorkerPool k = WorkerPool (TVar (PQ.MinPQueue k (Terminate PoolJob))) @@ -427,9 +475,17 @@ withWorkerPool :: Ord k => Int -> (WorkerPool k -> IO a) -> IO a withWorkerPool numWorkers k = do chan <- newTVarIO PQ.empty threads <- forM [0..numWorkers-1] (\i -> forkOn i (worker i chan)) - k (WorkerPool chan) `finally` do - replicateM_ numWorkers (atomically $ writeTVar chan PQ.empty) - forM_ threads killThread + eres <- try (k (WorkerPool chan)) + case eres of + Left (err :: SomeException) -> do + atomically $ writeTVar chan PQ.empty + forM_ threads killThread + throw err + Right res -> do + readTVarIO chan >>= \case + PQ.Empty -> return () + _ -> throwIO (userError "withWorkerPool: computation exited before all jobs were handled") + return res where worker :: Ord k => Int -> TVar (PQ.MinPQueue k (Terminate PoolJob)) -> IO () worker idx chan = do @@ -465,10 +521,11 @@ ansi :: (?istty :: Bool) => String -> String ansi | ?istty = id | otherwise = const "" -ansiRed, ansiGreen, ansiReset :: (?istty :: Bool) => String -ansiRed = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]) -ansiGreen = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green]) -ansiReset = ansi (ANSI.setSGRCode [ANSI.Reset]) +ansiRed, ansiYellow, ansiGreen, ansiReset :: (?istty :: Bool) => String +ansiRed = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]) +ansiYellow = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow]) +ansiGreen = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green]) +ansiReset = ansi (ANSI.setSGRCode [ANSI.Reset]) -- getTermIsDark :: IO Bool -- getTermIsDark = do |