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.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" diff --git a/src/Hedgehog/Extras/Internal/Orphans.hs b/src/Hedgehog/Extras/Internal/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Orphans.hs @@ -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 + diff --git a/src/Hedgehog/Extras/Test.hs b/src/Hedgehog/Extras/Test.hs --- a/src/Hedgehog/Extras/Test.hs +++ b/src/Hedgehog/Extras/Test.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -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 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,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 diff --git a/src/Hedgehog/Extras/Test/Golden.hs b/src/Hedgehog/Extras/Test/Golden.hs --- a/src/Hedgehog/Extras/Test/Golden.hs +++ b/src/Hedgehog/Extras/Test/Golden.hs @@ -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 + ] diff --git a/src/Hedgehog/Extras/Test/MonadAssertion.hs b/src/Hedgehog/Extras/Test/MonadAssertion.hs --- a/src/Hedgehog/Extras/Test/MonadAssertion.hs +++ b/src/Hedgehog/Extras/Test/MonadAssertion.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Prim.hs b/src/Hedgehog/Extras/Test/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Prim.hs @@ -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 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 @@ -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 diff --git a/src/Hedgehog/Extras/Test/Unit.hs b/src/Hedgehog/Extras/Test/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Unit.hs @@ -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 diff --git a/test/Hedgehog/Extras/Test/TestExpectFailure.hs b/test/Hedgehog/Extras/Test/TestExpectFailure.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Extras/Test/TestExpectFailure.hs @@ -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) diff --git a/test/Hedgehog/Extras/Test/UnitSpec.hs b/test/Hedgehog/Extras/Test/UnitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Extras/Test/UnitSpec.hs @@ -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)