diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras -version: 0.5.1.0 +version: 0.6.0.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -28,6 +28,9 @@ common filepath { build-depends: filepath } common hedgehog { build-depends: hedgehog } common http-conduit { build-depends: http-conduit } +common lifted-async { build-depends: lifted-async } +common lifted-base { build-depends: lifted-base } +common monad-control { build-depends: monad-control } common mmorph { build-depends: mmorph } common mtl { build-depends: mtl } common network { build-depends: network } @@ -39,6 +42,7 @@ common text { build-depends: text } common time { build-depends: time >= 1.9.1 } common transformers { build-depends: transformers } +common transformers-base { build-depends: transformers-base } common unliftio { build-depends: unliftio } common yaml { build-depends: yaml } common zlib { build-depends: zlib } @@ -71,6 +75,9 @@ filepath, hedgehog, http-conduit, + lifted-async, + lifted-base, + monad-control, mmorph, mtl, network, @@ -82,6 +89,7 @@ text, time, transformers, + transformers-base, unliftio, Win32, yaml, diff --git a/src/Hedgehog/Extras/Test/Concurrent.hs b/src/Hedgehog/Extras/Test/Concurrent.hs --- a/src/Hedgehog/Extras/Test/Concurrent.hs +++ b/src/Hedgehog/Extras/Test/Concurrent.hs @@ -1,16 +1,101 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + + +{- | This modules provides concurrency abstractions for hedgehog tests. Using "lifted-base" one can execute +expensive test actions concurrently. + +For example, the actions invoked inside 'mapConcurrently_' are invoked in the same 'MonadTest' as the outer +monad of 'mapConcurrently_'. + +@ +import qualified Hedgehog.Extras.Test.Concurrent as H + +setUpEnvironment = H.mapConcurrently_ id + [ H.threadDelay 100 >> pure 1 + , H.threadDelay 200 >> pure 2 + , H.threadDelay 300 >> pure 3 + ] +@ + + +__Warning: Do not use this module for running concurrent checks!__ The 'MonadBaseControl' instance does not +aggregate effects for 'PropertyT'. Consider the following code: + +@ + LA.mapConcurrently_ id + [ do + H.note_ \"FAIL1\" + success + , do + IO.threadDelay 1_000_000 + H.note_ \"FAIL2\" + failure + , do + H.note_ \"FAIL3\" + failure + ] +@ + +Executing this code will give you the following output in the test report: + +@ +66 ┃ LA.mapConcurrently_ id +67 ┃ [ do +68 ┃ H.note_ \"FAIL1\" + ┃ │ FAIL1 +69 ┃ success +70 ┃ , do +71 ┃ IO.threadDelay 1_000_000 +72 ┃ H.note_ \"FAIL2\" + ┃ │ FAIL2 +73 ┃ failure + ┃ ^^^^^^^ +74 ┃ , do +75 ┃ H.note_ \"FAIL3\" +76 ┃ failure +77 ┃ ] +@ +Please note that only @FAIL1@ and @FAIL2@ annotations were reported - @FAIL3@ annotation and the failure +below was swallowed without any information. + +__Don't use concurrency abstractions from this module, when you need to aggregate and report failures!__ + +-} module Hedgehog.Extras.Test.Concurrent ( threadDelay + -- * Re-exports of concurrency abstractions from @lifted-base@ + , module Control.Concurrent.Async.Lifted + , module System.Timeout.Lifted ) where -import Control.Monad.IO.Class (MonadIO) -import Data.Function (($), (.)) +import Control.Applicative +import Control.Concurrent.Async.Lifted +import qualified Control.Concurrent.Lifted as IO +import Control.Monad.Base +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Data.Function import Data.Int -import Hedgehog (MonadTest) - -import qualified Control.Concurrent as IO import qualified GHC.Stack as GHC +import System.IO (IO) +import System.Timeout.Lifted +import qualified UnliftIO + +import Hedgehog import qualified Hedgehog as H --- Delay the thread by 'n' milliseconds. +-- | Delay the thread by 'n' milliseconds. threadDelay :: (MonadTest m, MonadIO m) => Int -> m () threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n + +instance MonadBase IO (ResourceT IO) where + liftBase = liftIO + +instance MonadBaseControl IO (ResourceT IO) where + type StM (ResourceT IO) a = a + liftBaseWith = UnliftIO.withRunInIO + restoreM = pure diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs --- a/src/Hedgehog/Extras/Test/Process.hs +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -6,9 +6,11 @@ module Hedgehog.Extras.Test.Process ( createProcess , exec + , execAny , exec_ , execFlex , execFlex' + , execFlexAny' , procFlex , binFlex @@ -43,7 +45,7 @@ import Hedgehog.Extras.Internal.Cli (argQuote) import Hedgehog.Extras.Internal.Plan (Component (..), Plan (..)) import Hedgehog.Extras.Stock.IO.Process (TimedOut (..)) -import Prelude (error) +import Prelude (error, (++)) import System.Exit (ExitCode) import System.FilePath (takeDirectory) import System.FilePath.Posix (()) @@ -164,27 +166,36 @@ -> [String] -> m String execFlex' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do - cp <- procFlex' execConfig pkgBin envBin arguments - H.annotate . ("Command: " <>) $ case IO.cmdspec cp of - IO.ShellCommand cmd -> cmd - IO.RawCommand cmd args -> cmd <> " " <> L.unwords args - (exitResult, stdout, stderr) <- H.evalIO $ IO.readCreateProcessWithExitCode cp "" + (exitResult, stdout, stderr) <- execFlexAny' execConfig pkgBin envBin arguments case exitResult of IO.ExitFailure exitCode -> do H.annotate $ L.unlines $ - [ "Process exited with non-zero exit-code" + [ "Process exited with non-zero exit-code: " ++ show @Int exitCode , "━━━━ command ━━━━" , pkgBin <> " " <> L.unwords (fmap argQuote arguments) - , "━━━━ stdout ━━━━" - , stdout - , "━━━━ stderr ━━━━" - , stderr - , "━━━━ exit code ━━━━" - , show @Int exitCode ] + ++ if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout] + ++ if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr] H.failMessage GHC.callStack "Execute process failed" IO.ExitSuccess -> return stdout +-- | Run a process, returning its exit code, its stdout, and its stderr. +-- Contrary to @execFlex'@, this function doesn't fail if the call fails. +-- So, if you want to test something negative, this is the function to use. +execFlexAny' + :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) + => ExecConfig + -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec' + -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix + -> [String] + -> m (ExitCode, String, String) -- ^ exit code, stdout, stderr +execFlexAny' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do + cp <- procFlex' execConfig pkgBin envBin arguments + H.annotate . ("Command: " <>) $ case IO.cmdspec cp of + IO.ShellCommand cmd -> cmd + IO.RawCommand cmd args -> cmd <> " " <> L.unwords args + H.evalIO $ IO.readCreateProcessWithExitCode cp "" + -- | Execute a process, returning '()'. exec_ :: (MonadTest m, MonadIO m, HasCallStack) @@ -194,7 +205,9 @@ -> m () exec_ execConfig bin arguments = void $ exec execConfig bin arguments --- | Execute a process +-- | Execute a process, returning the stdout. Fail if the call returns +-- with a non-zero exit code. For a version that doesn't fail upon receiving +-- a non-zero exit code, see 'execAny'. exec :: (MonadTest m, MonadIO m, HasCallStack) => ExecConfig @@ -202,25 +215,31 @@ -> [String] -> m String exec execConfig bin arguments = GHC.withFrozenCallStack $ do - let cp = (IO.proc bin arguments) - { IO.env = getLast $ execConfigEnv execConfig - , IO.cwd = getLast $ execConfigCwd execConfig - } - H.annotate . ("Command: " <>) $ bin <> " " <> L.unwords arguments - (exitResult, stdout, stderr) <- H.evalIO $ IO.readCreateProcessWithExitCode cp "" + (exitResult, stdout, stderr) <- execAny execConfig bin arguments case exitResult of IO.ExitFailure exitCode -> H.failMessage GHC.callStack . L.unlines $ - [ "Process exited with non-zero exit-code" + [ "Process exited with non-zero exit-code: " ++ show @Int exitCode , "━━━━ command ━━━━" , bin <> " " <> L.unwords (fmap argQuote arguments) - , "━━━━ stdout ━━━━" - , stdout - , "━━━━ stderr ━━━━" - , stderr - , "━━━━ exit code ━━━━" - , show @Int exitCode ] + ++ if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout] + ++ if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr] IO.ExitSuccess -> return stdout + +-- | Execute a process, returning the error code, the stdout, and the stderr. +execAny + :: (MonadTest m, MonadIO m, HasCallStack) + => ExecConfig + -> String -- ^ The binary to launch + -> [String] -- ^ The binary's arguments + -> m (ExitCode, String, String) -- ^ exit code, stdout, stderr +execAny execConfig bin arguments = GHC.withFrozenCallStack $ do + let cp = (IO.proc bin arguments) + { IO.env = getLast $ execConfigEnv execConfig + , IO.cwd = getLast $ execConfigCwd execConfig + } + H.annotate . ("Command: " <>) $ bin <> " " <> L.unwords arguments + H.evalIO $ IO.readCreateProcessWithExitCode cp "" -- | Wait for process to exit. waitForProcess