hedgehog-extras 0.5.1.0 → 0.6.0.0

raw patch · 3 files changed

+146/−34 lines, 3 filesdep +lifted-asyncdep +lifted-basedep +monad-controlnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-async, lifted-base, monad-control, transformers-base

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +9/−1
• src/Hedgehog/Extras/Test/Concurrent.hs +91/−6
• src/Hedgehog/Extras/Test/Process.hs +46/−27

@@ -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,

@@ -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

@@ -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