hedgehog-extras 0.7.0.0 → 0.8.0.0

raw patch · 12 files changed

+368/−57 lines, 12 filesdep +containersdep +generic-lensdep +hw-preludePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, generic-lens, hw-prelude, microlens, tasty-discover

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +22/−3
• src/Hedgehog/Extras/Internal/Orphans.hs +25/−0
• src/Hedgehog/Extras/Test.hs +2/−0
• src/Hedgehog/Extras/Test/Base.hs +32/−16
• src/Hedgehog/Extras/Test/Concurrent.hs +2/−15
• src/Hedgehog/Extras/Test/Golden.hs +93/−19
• src/Hedgehog/Extras/Test/MonadAssertion.hs +45/−1
• src/Hedgehog/Extras/Test/Prim.hs +30/−0
• src/Hedgehog/Extras/Test/Process.hs +11/−3
• src/Hedgehog/Extras/Test/Unit.hs +56/−0
• test/Hedgehog/Extras/Test/TestExpectFailure.hs +37/−0
• test/Hedgehog/Extras/Test/UnitSpec.hs +13/−0

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:                   hedgehog-extras-version:                0.7.0.0+version:                0.8.0.0 synopsis:               Supplemental library for hedgehog description:            Supplemental library for hedgehog. category:               Test@@ -19,18 +19,22 @@ common aeson                        { build-depends: aeson                            >= 2.0.0.0                  } common aeson-pretty                 { build-depends: aeson-pretty                     >= 0.8.5                    } common async                        { build-depends: async                                                        }-common base                         { build-depends: base                             >= 4.12       && < 4.21     }+common base                         { build-depends: base                             >= 4.12       && < 4.22     } common bytestring                   { build-depends: bytestring                                                   }+common containers                   { build-depends: containers                                                   } common deepseq                      { build-depends: deepseq                                                      } common Diff                         { build-depends: Diff                                                         } common directory                    { build-depends: directory                                                    } common exceptions                   { build-depends: exceptions                                                   } common filepath                     { build-depends: filepath                                                     }+common generic-lens                 { build-depends: generic-lens                                                 } common hedgehog                     { build-depends: hedgehog                                                     } common hedgehog-quickcheck          { build-depends: hedgehog-quickcheck                                          } common http-conduit                 { build-depends: http-conduit                                                 }+common hw-prelude                   { build-depends: hw-prelude                                                   } common lifted-async                 { build-depends: lifted-async                                                 } common lifted-base                  { build-depends: lifted-base                                                  }+common microlens                    { build-depends: microlens                                                    } common mmorph                       { build-depends: mmorph                                                       } common monad-control                { build-depends: monad-control                                                } common mtl                          { build-depends: mtl                                                          }@@ -41,6 +45,7 @@ common stm                          { build-depends: stm                                                          } common tar                          { build-depends: tar                              ^>= 0.6                     } common tasty                        { build-depends: tasty                                                        }+common tasty-discover               { build-depends: tasty-discover                   >= 5.0.2                    } common tasty-hedgehog               { build-depends: tasty-hedgehog                                               } common tasty-quickcheck             { build-depends: tasty-quickcheck                                             } common temporary                    { build-depends: temporary                                                    }@@ -75,17 +80,21 @@                         aeson,                         async,                         bytestring,+                        containers,                         deepseq,                         Diff,                         directory,                         exceptions,                         filepath,+                        generic-lens,                         hedgehog,                         http-conduit,+                        hw-prelude,                         lifted-async,                         lifted-base,-                        monad-control,+                        microlens,                         mmorph,+                        monad-control,                         mtl,                         network,                         process,@@ -93,6 +102,9 @@                         retry,                         stm,                         tar,+                        tasty,+                        tasty-discover,+                        tasty-hedgehog,                         temporary,                         text,                         time,@@ -110,6 +122,7 @@   exposed-modules:      Hedgehog.Extras                         Hedgehog.Extras.Aeson                         Hedgehog.Extras.Internal.Cli+                        Hedgehog.Extras.Internal.Orphans                         Hedgehog.Extras.Internal.Plan                         Hedgehog.Extras.Internal.Test.Integration                         Hedgehog.Extras.Stock@@ -132,18 +145,22 @@                         Hedgehog.Extras.Test.Golden                         Hedgehog.Extras.Test.MonadAssertion                         Hedgehog.Extras.Test.Network+                        Hedgehog.Extras.Test.Prim                         Hedgehog.Extras.Test.Process                         Hedgehog.Extras.Test.TestWatchdog                         Hedgehog.Extras.Test.Tripwire+                        Hedgehog.Extras.Test.Unit  test-suite hedgehog-extras-test   import:               base, project-config,                         hedgehog,                         hedgehog-extras,+                        lifted-base,                         network,                         process,                         resourcet,                         tasty,+                        tasty-discover,                         tasty-hedgehog,                         transformers,                         time,@@ -152,7 +169,9 @@   type:                 exitcode-stdio-1.0    other-modules:        Hedgehog.Extras.Stock.IO.Network.PortSpec+                        Hedgehog.Extras.Test.TestExpectFailure                         Hedgehog.Extras.Test.TestWatchdogSpec+                        Hedgehog.Extras.Test.UnitSpec    build-tool-depends:   tasty-discover:tasty-discover   ghc-options:          -threaded -rtsopts "-with-rtsopts=-N -T"

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Hedgehog.Extras.Internal.Orphans () where++import Control.Applicative+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import System.IO (IO)+import UnliftIO qualified++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+

@@ -5,8 +5,10 @@ import           Hedgehog.Extras.Test.Base as X import           Hedgehog.Extras.Test.Concurrent as X import           Hedgehog.Extras.Test.File as X+import           Hedgehog.Extras.Test.Golden as X import           Hedgehog.Extras.Test.MonadAssertion as X import           Hedgehog.Extras.Test.Network as X import           Hedgehog.Extras.Test.Process as X import           Hedgehog.Extras.Test.TestWatchdog as X import           Hedgehog.Extras.Test.Tripwire as X+import           Hedgehog.Extras.Test.Unit as X

@@ -60,6 +60,11 @@    , failWithCustom   , failMessage+  , expectFailure+  , expectFailureWith+  , tryAssertion+  , assertFailure+  , assertFailure_    , assertByDeadlineM   , assertByDeadlineIO@@ -85,11 +90,18 @@    , retry   , retry'++  , MonadBaseControl+  , bracket+  , bracket_   ) where  import           Control.Applicative (Applicative (..))+import           Control.Exception (IOException)+import           Control.Exception.Lifted (bracket, bracket_)+import           Control.Monad.Trans.Control (MonadBaseControl) import           Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when)-import           Control.Monad.Catch (MonadCatch)+import           Control.Monad.Catch (Handler (..), MonadCatch) import           Control.Monad.Morph (hoist) import           Control.Monad.Reader (MonadIO (..), MonadReader (ask)) import           Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register, runResourceT)@@ -102,7 +114,6 @@ import           Data.Functor ((<$>)) import           Data.Int (Int) import           Data.Maybe (Maybe (..), listToMaybe, maybe)-import           Data.Monoid (Monoid (..)) import           Data.Semigroup (Semigroup (..)) import           Data.String (String) import           Data.Time.Clock (NominalDiffTime, UTCTime)@@ -113,8 +124,8 @@ import           Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) import           Hedgehog.Extras.Stock.CallStack (callerModuleName) import           Hedgehog.Extras.Stock.Monad (forceM)-import           Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)-import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)+import           Hedgehog.Extras.Test.MonadAssertion+import           Hedgehog.Extras.Test.Prim import           Hedgehog.Internal.Source (getCaller) import           Prelude (Num (..), Ord (..), floor) import           System.FilePath ((</>))@@ -123,8 +134,6 @@  import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM-import           Control.Exception (IOException)-import           Control.Monad.Catch (Handler (..)) import qualified Control.Monad.Trans.Resource as IO import qualified Control.Retry as R import qualified Data.List as L@@ -148,13 +157,20 @@ propertyOnce :: HasCallStack => Integration () -> H.Property propertyOnce = H.withTests 1 . H.property . hoist runResourceT . hoist H.runIntegrationReaderT --- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.-failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a-failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)+-- | Invert the behavior of a property: success becomes failure and vice versa.+expectFailure :: (MonadTest m, MonadIO m, HasCallStack) => H.TestT IO a -> m ()+expectFailure = GHC.withFrozenCallStack $ expectFailureWith (pure . const ()) --- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.-failMessage :: MonadTest m => CallStack -> String -> m a-failMessage cs = failWithCustom cs Nothing+-- | Invert the behavior of a property: success becomes failure and vice versa.+-- This function behaves like 'expectFailure' but it allows to check the failure+-- is as expected. The function takes a 'Failure' and should itself be a test+-- that fails if the failure is not as expected.+expectFailureWith :: (MonadTest m, MonadIO m, HasCallStack) => (H.Failure -> m ()) -> H.TestT IO b -> m ()+expectFailureWith checkFailure prop = GHC.withFrozenCallStack $ do+  (res, _) <- H.evalIO $ H.runTestT prop+  case res of+    Left failure -> checkFailure failure+    _ -> H.failWith Nothing "Expected the test to fail but it passed" -- Property pased but we expected a failure  -- | Create a workspace directory which will exist for at least the duration of -- the supplied block.@@ -482,13 +498,13 @@ jsonErrorFailM :: (MonadTest m, HasCallStack) => m (Result a) -> m a jsonErrorFailM f = GHC.withFrozenCallStack $ f >>= jsonErrorFail --- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the deadline expires. -- -- Expiration of the deadline results in an assertion failure byDeadlineIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> IO a -> m a byDeadlineIO period deadline errorMessage f = GHC.withFrozenCallStack $ byDeadlineM period deadline errorMessage $ liftIO f --- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the deadline expires. -- -- Expiration of the deadline results in an assertion failure byDeadlineM :: forall m a. (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> m a -> m a@@ -510,13 +526,13 @@               void $ failMessage GHC.callStack $ "Condition not met by deadline: " <> errorMessage               H.throwAssertion e --- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the duration expires. -- -- Expiration of the duration results in an assertion failure byDurationIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> IO a -> m a byDurationIO period duration errorMessage f = GHC.withFrozenCallStack $ byDurationM period duration errorMessage $ liftIO f --- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the duration expires. -- -- Expiration of the duration results in an assertion failure byDurationM :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> m a -> m a

@@ -1,9 +1,7 @@ {-# 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. @@ -73,20 +71,17 @@   , module System.Timeout.Lifted   ) where -import           Control.Applicative import           Control.Concurrent.Async.Lifted import qualified Control.Concurrent.Lifted as IO import           Control.Concurrent.MVar.Lifted-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 qualified GHC.Stack as GHC import           System.IO (IO) import           System.Timeout.Lifted-import qualified UnliftIO+import           Hedgehog.Extras.Internal.Orphans ()  import           Control.Monad import           Control.Monad.Catch (MonadCatch)@@ -94,7 +89,7 @@ import           Hedgehog import qualified Hedgehog as H --- | Delay the thread by 'n' milliseconds.+-- | Delay the thread by 'n' microseconds. threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m () threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n @@ -109,11 +104,3 @@   where     cleanUp :: Async a -> IO ()     cleanUp a = cancel a >> void (link a)--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

@@ -1,44 +1,59 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}  module Hedgehog.Extras.Test.Golden   ( diffVsGoldenFile,     diffFileVsGoldenFile,+    diffVsGoldenFileExcludeTrace,   ) where  import           Control.Applicative-import           Control.Exception (bracket_)+import           Control.Exception.Lifted import           Control.Monad import           Control.Monad.IO.Class (MonadIO (liftIO))+import           Control.Monad.Trans.Control import           Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff) import           Data.Algorithm.DiffOutput (ppDiff) import           Data.Bool import           Data.Eq import           Data.Function+import           Data.Map (Map) import           Data.Maybe import           Data.Monoid import           Data.String import           GHC.Stack (HasCallStack, callStack) import           Hedgehog (MonadTest) import           Hedgehog.Extras.Test.Base (failMessage)+import           System.Directory (canonicalizePath, getCurrentDirectory) import           System.FilePath (takeDirectory)+import           System.FilePath.Posix (makeRelative) import           System.IO (FilePath, IO)  import qualified Control.Concurrent.QSem as IO+import qualified Control.Concurrent.STM as STM import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Text as Text import qualified GHC.Stack as GHC-import qualified Hedgehog.Extras.Test as H+import qualified Hedgehog.Extras.Test.Base as H+import qualified Hedgehog.Extras.Test.File as H import qualified Hedgehog.Internal.Property as H import qualified System.Directory as IO import qualified System.Environment as IO import qualified System.IO as IO import qualified System.IO.Unsafe as IO -sem :: IO.QSem-sem = IO.unsafePerformIO $ IO.newQSem 1-{-# NOINLINE sem #-}--semBracket :: IO a -> IO a-semBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)+semBracket :: ()+  => MonadIO m+  => MonadBaseControl IO m+  => IO.QSem+  -> m a+  -> m a+semBracket sem =+  bracket_+    (liftIO (IO.waitQSem sem))+    (liftIO (IO.signalQSem sem))  -- | The file to log whenever a golden file is referenced. mGoldenFileLogFile :: Maybe FilePath@@ -103,6 +118,23 @@         ]       failMessage callStack $ ppDiff difference +tvGoldenFileSems :: STM.TVar (Map FilePath IO.QSem)+tvGoldenFileSems = IO.unsafePerformIO $ STM.newTVarIO mempty+{-# NOINLINE tvGoldenFileSems #-}++getGoldenFileSem :: FilePath -> IO IO.QSem+getGoldenFileSem filePath = do+  newSem <- IO.newQSem 1++  STM.atomically $ do+    sems <- STM.readTVar tvGoldenFileSems+    case Map.lookup filePath sems of+      Just sem -> return sem+      Nothing  -> do+        let newGoldenFileSems = Map.insert filePath newSem sems+        STM.writeTVar tvGoldenFileSems newGoldenFileSems+        return newSem+ -- | Diff contents against the golden file.  If CREATE_GOLDEN_FILES environment is -- set to "1", then should the golden file not exist it would be created.  If -- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would@@ -120,22 +152,33 @@ -- each input. diffVsGoldenFile   :: HasCallStack-  => (MonadIO m, MonadTest m)+  => MonadIO m+  => MonadBaseControl IO m+  => MonadTest m   => String   -- ^ Actual content   -> FilePath -- ^ Reference file   -> m ()-diffVsGoldenFile actualContent goldenFile = GHC.withFrozenCallStack $ do-  forM_ mGoldenFileLogFile $ \logFile ->-    liftIO $ semBracket $ IO.appendFile logFile $ goldenFile <> "\n"+diffVsGoldenFile actualContent goldenFile =+  GHC.withFrozenCallStack $ do+    realPath <- liftIO $ canonicalizePath goldenFile+    cwd <- liftIO getCurrentDirectory -  fileExists <- liftIO $ IO.doesFileExist goldenFile+    let relativeGoldenPath = makeRelative cwd realPath -  if-    | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent-    | fileExists          -> checkAgainstGoldenFile goldenFile actualLines-    | createGoldenFiles   -> writeGoldenFile goldenFile actualContent-    | otherwise           -> reportGoldenFileMissing goldenFile+    sem <- liftIO $ getGoldenFileSem relativeGoldenPath +    GHC.withFrozenCallStack $ semBracket sem $ do+      forM_ mGoldenFileLogFile $ \logFile ->+        liftIO $ IO.appendFile logFile $ goldenFile <> "\n"++      fileExists <- liftIO $ IO.doesFileExist goldenFile++      if+        | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent+        | fileExists          -> checkAgainstGoldenFile goldenFile actualLines+        | createGoldenFiles   -> writeGoldenFile goldenFile actualContent+        | otherwise           -> reportGoldenFileMissing goldenFile+   where     actualLines = List.lines actualContent @@ -152,10 +195,41 @@ -- files are never overwritten. diffFileVsGoldenFile   :: HasCallStack-  => (MonadIO m, MonadTest m)+  => MonadBaseControl IO m+  => MonadIO m+  => MonadTest m   => FilePath -- ^ Actual file   -> FilePath -- ^ Reference file   -> m () diffFileVsGoldenFile actualFile referenceFile = GHC.withFrozenCallStack $ do   contents <- H.readFile actualFile   diffVsGoldenFile contents referenceFile++-- | Diff contents against the golden file, excluding the trace.  If CREATE_GOLDEN_FILES environment is+-- set to "1", then should the golden file not exist it would be created.  If+-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would+-- be recreated. If GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file+-- path will be logged to the specified file.+--+-- Set the environment variable when you intend to generate or re-generate the golden+-- file for example when running the test for the first time or if the golden file+-- genuinely needs to change.+--+-- To re-generate a golden file you must also delete the golden file because golden+-- files are never overwritten.+diffVsGoldenFileExcludeTrace+  :: MonadBaseControl IO m+  => MonadIO m+  => MonadTest m+  => HasCallStack+  => String -> FilePath -> m ()+diffVsGoldenFileExcludeTrace inputString refFile =+  GHC.withFrozenCallStack $ do+    case List.uncons $ Text.splitOn "CallStack" $ Text.pack inputString of+      Just (stackTraceRemoved, _) -> diffVsGoldenFile (Text.unpack stackTraceRemoved) refFile+      Nothing ->+        H.failWith Nothing $+          List.unlines+            [ "Input string was empty"+            , "Reference file: " <> refFile+            ]

@@ -3,17 +3,27 @@  module Hedgehog.Extras.Test.MonadAssertion   ( MonadAssertion(..)+  , assertFailure+  , assertFailure_+  , tryAssertion   ) where +import           Control.Applicative (Applicative(..)) import           Control.Monad import           Control.Monad.Trans.Class import           Data.Either import           Data.Function-import           Data.Monoid (mempty)+import           Data.Functor ((<$>))+import           Data.Monoid+import           GHC.Stack (HasCallStack)+import           Hedgehog (MonadTest(..))+import           Hedgehog.Extras.Test.Prim+import           Text.Show (Show(..))  import qualified Control.Monad.Trans.Except as E import qualified Control.Monad.Trans.Resource as IO import qualified Control.Monad.Trans.Resource.Internal as IO+import qualified GHC.Stack as GHC import qualified Hedgehog as H import qualified Hedgehog.Internal.Property as H @@ -30,3 +40,37 @@   catchAssertion r h = IO.ResourceT $ \i -> IO.unResourceT r i `catchAssertion` \e -> IO.unResourceT (h e) i  deriving instance Monad m => MonadAssertion (H.PropertyT m)++-- | Attempt to run a function that may assert, returning either a failure or the result of the assertion.+tryAssertion :: ()+  => MonadAssertion m+  => m a+  -> m (Either H.Failure a)+tryAssertion m =+  catchAssertion (Right <$> m) (pure . Left)++-- | Run the given action and succeed if the action fails, but fail if it succeeds.+assertFailure :: ()+  => HasCallStack+  => Show a+  => MonadAssertion m+  => MonadTest m+  => m a+  -> m H.Failure+assertFailure f = do+  result <- tryAssertion f+  case result of+    Left e -> pure e+    Right a -> failMessage GHC.callStack $ show a++-- | Run the given action and succeed if the action fails, but fail if it succeeds.+assertFailure_ :: ()+  => HasCallStack+  => Show a+  => MonadAssertion m+  => MonadTest m+  => m a+  -> m ()+assertFailure_ f =+  GHC.withFrozenCallStack $+    void $ assertFailure f

@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Extras.Test.Prim+  ( failWithCustom+  , failMessage++  ) where++import           Data.Either (Either (..))+import           Data.Function+import           Data.Maybe+import           Data.Monoid (Monoid (..))+import           Data.String (String)+import           GHC.Stack+import           Hedgehog (MonadTest)+import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)+import           Hedgehog.Internal.Source (getCaller)++import qualified Hedgehog.Internal.Property as H++{- HLINT ignore "Reduce duplication" -}++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a+failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failMessage :: MonadTest m => CallStack -> String -> m a+failMessage cs = failWithCustom cs Nothing

@@ -284,7 +284,7 @@   maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv   case maybeEnvBin of     Just envBin -> return envBin-    Nothing -> binDist pkg+    Nothing -> binDist pkg binaryEnv  -- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding. -- to a haskell package.  It is assumed that the project has already been configured and the@@ -294,12 +294,20 @@   :: (HasCallStack, MonadTest m, MonadIO m)   => String   -- ^ Package name+  -> String+  -- ^ Environment variable pointing to the binary to run (used for error messages only)   -> m FilePath   -- ^ Path to executable-binDist pkg = do+binDist pkg binaryEnv = do   doesPlanExist <- liftIO $ IO.doesFileExist planJsonFile   unless doesPlanExist $-    error $ "Could not find plan.json in the path: " <> planJsonFile+    error $ "Could not find plan.json in the path: "+              <> planJsonFile+              <> ". Please run \"cabal build "+              <> pkg+              <> "\" if you are working with sources. Otherwise define "+              <> binaryEnv+              <> " and have it point to the executable you want."   contents <- H.evalIO . LBS.readFile $ planJsonFile    case eitherDecode contents of

@@ -0,0 +1,56 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Hedgehog.Extras.Test.Unit+  ( UnitIO(..)+  , testUnitIO+  ) where++import Control.Monad.Base+import Control.Monad.Catch (MonadCatch)+import Control.Monad.Morph+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Resource+import Data.Generics.Product.Any+import Data.Maybe+import Data.Monoid+import HaskellWorks.Prelude+import Hedgehog+import Hedgehog.Extras.Internal.Orphans ()+import Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)+import Hedgehog.Internal.Property qualified as H+import Lens.Micro+import Test.Tasty.Discover+import Test.Tasty.Hedgehog (testProperty)++import qualified Test.Tasty as T++newtype UnitIO a = UnitIO { runTestIO :: TestT (ResourceT IO) a }+  deriving newtype (Applicative)+  deriving newtype (Functor)+  deriving newtype (Monad)+  deriving newtype (MonadAssertion)+  deriving newtype (MonadBase IO)+  deriving newtype (MonadBaseControl IO)+  deriving newtype (MonadCatch)+  deriving newtype (MonadFail)+  deriving newtype (MonadIO)+  deriving newtype (MonadResource)+  deriving newtype (MonadTest)+  deriving newtype (MonadThrow)++instance Tasty (UnitIO ()) where+  tasty info = pure . testUnitIO testName+    where testName = fromMaybe "" $ getLast (info ^. the @"name")++testUnitIO :: T.TestName -> UnitIO () -> T.TestTree+testUnitIO testName =+  testProperty testName . H.withTests 1 . H.property . hoist runResourceT . H.test . runTestIO

@@ -0,0 +1,37 @@+module Hedgehog.Extras.Test.TestExpectFailure where++import           Prelude+import           Hedgehog (property, Property, MonadTest, (===), success)+import           Hedgehog.Extras.Test.Base (expectFailureWith, expectFailure)+import           Hedgehog.Internal.Property (Failure (..), failWith)+import           GHC.Stack (HasCallStack)+import           Control.Monad.IO.Class (MonadIO)++hprop_expect_always_fails_prop :: Property+hprop_expect_always_fails_prop = property $ do+  expectFailureWith failureCheck alwaysFailsProp+  where+    failureCheck :: (MonadTest m, HasCallStack) => Failure -> m ()+    failureCheck (Failure _ reason _) =+      reason === "This property always fails"++    alwaysFailsProp :: (MonadTest m, HasCallStack) => m ()+    alwaysFailsProp = failWith Nothing "This property always fails"++hprop_bad_expect_always_fails_fails_prop :: Property+hprop_bad_expect_always_fails_fails_prop = property $ do+  expectFailure badExpectFailure+  where+    badExpectFailure :: (MonadIO m, MonadTest m, HasCallStack) => m ()+    badExpectFailure = expectFailureWith badFailureCheck alwaysFailsProp++    badFailureCheck :: (MonadTest m, HasCallStack) => Failure -> m ()+    badFailureCheck (Failure _ reason _) =+      reason === "This property sometimes fails"++    alwaysFailsProp :: (MonadTest m, HasCallStack) => m ()+    alwaysFailsProp = failWith Nothing "This property always fails"++hprop_bad_expect_failure_fails_prop :: Property+hprop_bad_expect_failure_fails_prop = property $ do+  expectFailure (expectFailure success)

@@ -0,0 +1,13 @@+module Hedgehog.Extras.Test.UnitSpec where++import Control.Exception.Lifted+import Data.Bool+import Hedgehog+import Hedgehog.Extras.Test.Unit++tasty_unit :: UnitIO ()+tasty_unit = do+  bracket_+    (True === True)+    (True === True)+    (True === True)