{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-missing-role-annotations #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-term-variable-capture #-}
-- |
-- Module : Effectful.Hspec
-- Copyright : (c) 2026 Institute for Digital Autonomy
-- License : EUPL-1.2
-- Maintainer : IDA
--
-- Effectful bindings for the <http://hackage.haskell.org/package/hspec Hspec library>
-- built on top of @<http://hackage.haskell.org/package/hunit-effectful hunit-effectful>@.
--
-- = Overview
--
-- This library provides @Hspec@'s test combinators expressed in terms of the 'Hspec' effect.
-- This effect allows you to intersperse test assertions with arbitrary other effects.
--
-- = Example usage
--
-- Suppose we wish to test stateful operations on an account balance:
--
-- > deposit :: (State Int :> es) => Int -> Eff es ()
-- > deposit amount = modify (+ amount)
-- >
-- > balance :: (State Int :> es) => Eff es Int
-- > balance = get
--
-- > withdraw :: (State Int :> es) => Int -> Eff es Bool
-- > withdraw amount = do
-- > funds <- balance
-- > if funds < amount
-- > then pure False
-- > else do
-- > put $ funds - amount
-- > pure True
--
-- Use 'describe' to group related examples, 'it' to state individual expectations
-- and setup/teardown combinators such as 'before_', 'after_', or 'around_' to
-- run the examples from a known initial state:
--
-- > accountSpec :: (State Int :> es, Hspec :> es) => Eff es ()
-- > accountSpec = describe "account" . before_ (put @Int 0) $ do
-- > it "accumulates deposits" $ do
-- > deposit 100
-- > deposit 50
-- > balance `shouldReturn` 150
-- >
-- > it "checks for sufficient funds before withdrawing" $ do
-- > deposit 100
-- > withdraw 30 `shouldReturn` True
-- > withdraw 1000 `shouldReturn` False
-- > balance `shouldReturn` 70
--
-- Finally, run the spec with 'runHspec', which also resolves the underlying 'HUnit' effect:
--
-- > main :: IO ()
-- > main = runEff . runHspec . evalState @Int 0 $ accountSpec
module Effectful.Hspec
( -- * Effect
Hspec
, Expectation
, runHspecWith'
, runHspecWith
, runHspec'
, runHspec
, runHUnit
-- * Spec construction
, describe
, context
, it
, specify
, pending
, pendingWith
-- * Skipping
, xit
, xspecify
, xdescribe
, xcontext
-- * Focusing
, focus
, fit
, fspecify
, fdescribe
, fcontext
, parallel
, sequential
-- * Setup / Teardown
, before_
, beforeAll_
, after_
, afterAll_
, around_
, aroundAll_
-- * Expectations
, expectationFailure
, shouldBe
, shouldSatisfy
, shouldStartWith
, shouldEndWith
, shouldContain
, shouldMatchList
, shouldReturn
, shouldNotBe
, shouldNotSatisfy
, shouldNotContain
, shouldNotReturn
, shouldThrow
, anyException
-- * Properties
, prop
, xprop
, fprop
-- * Config
, Config (..)
, defaultConfig
)
where
import Control.Monad (unless)
import Data.List qualified as List
import Data.Typeable (typeOf)
import Effectful
import Effectful.Dispatch.Static
import Effectful.Environment (runEnvironment, withArgs)
import Effectful.Exception (Exception, throwIO, try)
import Effectful.HUnit as HUnit
import Test.Hspec qualified as Hspec
import Test.Hspec.Core.Spec (ResultStatus (..))
import Test.Hspec.Expectations (Selector, anyException)
import Test.Hspec.Expectations.Pretty.Matcher (matchList)
import Test.Hspec.QuickCheck qualified as Hspec
import Test.Hspec.Runner (Config (..), defaultConfig)
import Test.Hspec.Runner qualified as Hspec
import Test.QuickCheck qualified as QuickCheck
import Prelude
data Hspec :: Effect
type instance DispatchOf Hspec = 'Static 'WithSideEffects
data instance StaticRep Hspec = Hspec
{ spec :: Hspec.Spec
, unlift :: forall r. Eff '[HUnit] r -> IO r
}
type Expectation es = Assertion es
runHspecWith' :: (IOE :> es, HUnit :> es) => Config -> Eff (Hspec ': es) a -> Eff es a
runHspecWith' config action = do
(a, Hspec{spec}) <- withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift ->
unlift
. runStaticRep
Hspec
{ spec = pure ()
, unlift = unlift . inject
}
. inject
$ action
runEnvironment . withArgs [] . liftIO $ Hspec.hspecWith config spec
pure a
runHspecWith :: (IOE :> es) => Config -> Eff (Hspec ': es) a -> Eff es a
runHspecWith = (runHUnit .) . (. inject) . runHspecWith'
runHspec' :: (IOE :> es, HUnit :> es) => Eff (Hspec ': es) a -> Eff es a
runHspec' = runHspecWith' defaultConfig . inject
runHspec :: (IOE :> es) => Eff (Hspec ': es) a -> Eff es a
runHspec = runHUnit . runHspec' . inject
hunit :: (Hspec :> es) => Eff '[HUnit] r -> Eff es r
hunit action = do
Hspec{unlift} <- getStaticRep
unsafeEff_ . unlift . inject $ action
appendSpec :: (Hspec :> es) => Hspec.Spec -> Eff es ()
appendSpec spec = stateStaticRep \hspec -> ((), hspec{spec = hspec.spec >> spec})
mapSpec :: (HasCallStack, Hspec :> es) => (Hspec.Spec -> Hspec.Spec) -> Eff es a -> Eff es a
mapSpec f action =
stateStaticRepM \before -> do
putStaticRep before{spec = pure ()}
result <- action
after <- getStaticRep @Hspec
pure (result, before{spec = before.spec >> f after.spec})
-- | Lifted 'Hspec.describe'.
describe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
describe = mapSpec . Hspec.describe
-- | Lifted 'Hspec.it'.
it :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
it label action = do
ioAction <-
unsafeConcUnliftIO Ephemeral Unlimited \runInIO ->
pure (runInIO action)
appendSpec $ Hspec.it label ioAction
-- | Lifted 'Hspec.specify'.
specify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
specify = it
-- | Lifted 'Hspec.context'.
context :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
context = describe
-- | Lifted 'Hspec.pending'.
pending :: (HasCallStack, Hspec :> es) => Eff es ()
pending = getStaticRep @Hspec >> unsafeEff_ Hspec.pending
pending_ :: Eff es ()
pending_ = throwIO $ Pending Nothing Nothing
-- | Lifted 'Hspec.pendingWith'.
pendingWith :: (HasCallStack, Hspec :> es) => String -> Eff es ()
pendingWith = (getStaticRep @Hspec >>) . unsafeEff_ . Hspec.pendingWith
-- | Lifted 'Hspec.xit'.
xit :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
xit = (before_ pending_ .) . it
-- | Lifted 'Hspec.xspecify'.
xspecify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
xspecify = xit
-- | Lifted 'Hspec.xdescribe'.
xdescribe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
xdescribe = (before_ pending_ .) . describe
-- | Lifted 'Hspec.xcontext'.
xcontext :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
xcontext = xdescribe
-- | Lifted 'Hspec.focus'.
focus :: (HasCallStack, Hspec :> es) => Eff es a -> Eff es a
focus = mapSpec Hspec.focus
-- | Lifted 'Hspec.fit'.
fit :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
fit = fmap focus . it
-- | Lifted 'Hspec.fspecify'.
fspecify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
fspecify = fit
-- | Lifted 'Hspec.fdescribe'.
fdescribe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
fdescribe = fmap focus . describe
-- | Lifted 'Hspec.fcontext'.
fcontext :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
fcontext = fdescribe
-- | Lifted 'Hspec.parallel'.
parallel :: (HasCallStack, Hspec :> es) => Eff es a -> Eff es a
parallel = mapSpec Hspec.parallel
-- | Lifted 'Hspec.sequential'.
sequential :: (HasCallStack, Hspec :> es) => Eff es a -> Eff es a
sequential = mapSpec Hspec.sequential
-- | Lifted 'Hspec.before_'.
before_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a
before_ setup action = do
ioSetup <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift setup)
mapSpec (Hspec.before_ ioSetup) action
-- | Lifted 'Hspec.beforeAll_'.
beforeAll_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a
beforeAll_ setup action = do
ioSetup <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift setup)
mapSpec (Hspec.beforeAll_ ioSetup) action
-- | Lifted 'Hspec.after_'.
after_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a
after_ teardown action = do
ioTeardown <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift teardown)
mapSpec (Hspec.after_ ioTeardown) action
-- | Lifted 'Hspec.afterAll_'.
afterAll_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a
afterAll_ teardown action = do
ioTeardown <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift teardown)
mapSpec (Hspec.afterAll_ ioTeardown) action
-- | Lifted 'Hspec.around_'.
around_ :: (HasCallStack, Hspec :> es) => (Eff es () -> Eff es ()) -> Eff es a -> Eff es a
around_ wrapper action = do
ioWrapper <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift . wrapper . unsafeEff_)
mapSpec (Hspec.around_ ioWrapper) action
-- | Lifted 'Hspec.aroundAll_'.
aroundAll_ :: (HasCallStack, Hspec :> es) => (Eff es () -> Eff es ()) -> Eff es a -> Eff es a
aroundAll_ wrapper action = do
ioWrapper <-
unsafeConcUnliftIO Ephemeral Unlimited \unlift ->
pure (unlift . wrapper . unsafeEff_)
mapSpec (Hspec.aroundAll_ ioWrapper) action
expectationFailure :: (HasCallStack, Hspec :> es) => String -> Expectation es
expectationFailure msg = hunit $ HUnit.assertFailure msg
expectTrue
:: (HasCallStack, Hspec :> es)
=> String
-> Bool
-> Expectation es
expectTrue msg b = unless b (expectationFailure msg)
infix 1 `shouldBe`
, `shouldSatisfy`
, `shouldStartWith`
, `shouldEndWith`
, `shouldContain`
, `shouldMatchList`
, `shouldReturn`
, `shouldThrow`
infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`
-- | @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal
-- to @expected@.
shouldBe :: (HasCallStack, Show a, Eq a, Hspec :> es) => a -> a -> Expectation es
actual `shouldBe` expected = hunit $ actual @?= expected
-- | @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.
shouldSatisfy :: (HasCallStack, Show a, Hspec :> es) => a -> (a -> Bool) -> Expectation es
v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v)
compareWith
:: (HasCallStack, Show a, Hspec :> es)
=> (a -> a -> Bool)
-> String
-> a
-> a
-> Expectation es
compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result)
where
errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected
-- | @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@.
shouldStartWith :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es
shouldStartWith = compareWith List.isPrefixOf "does not start with"
-- | @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@.
shouldEndWith :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es
shouldEndWith = compareWith List.isSuffixOf "does not end with"
-- | @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained,
-- wholly and intact, anywhere in @list@.
shouldContain :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es
shouldContain = compareWith List.isInfixOf "does not contain"
-- | @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same
-- elements that @ys@ has, possibly in another order.
shouldMatchList :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es
xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys)
-- | @action \`shouldReturn\` expected@ sets the expectation that @action@
-- returns @expected@.
shouldReturn :: (HasCallStack, Show a, Eq a, Hspec :> es) => Eff es a -> a -> Expectation es
action `shouldReturn` expected = action >>= (`shouldBe` expected)
-- | @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not
-- equal to @notExpected@.
shouldNotBe :: (HasCallStack, Show a, Eq a, Hspec :> es) => a -> a -> Expectation es
actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected)
-- | @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@.
shouldNotSatisfy :: (HasCallStack, Show a, Hspec :> es) => a -> (a -> Bool) -> Expectation es
v `shouldNotSatisfy` p = expectTrue ("predicate succeeded on: " ++ show v) ((not . p) v)
-- | @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not
-- contained anywhere in @list@.
shouldNotContain :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es
list `shouldNotContain` sublist = expectTrue errorMsg (not $ sublist `List.isInfixOf` list)
where
errorMsg = show list ++ " does contain " ++ show sublist
-- | @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@
-- does not return @notExpected@.
shouldNotReturn
:: (HasCallStack, Show a, Eq a, Hspec :> es)
=> Eff es a
-> a
-> Expectation es
action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected)
-- | @action \`shouldThrow\` selector@ sets the expectation that @action@ throws
-- an exception. The precise nature of the expected exception is described
-- with a 'Selector'.
shouldThrow
:: (HasCallStack, Exception e, Hspec :> es)
=> Eff es a
-> Selector e
-> Expectation es
action `shouldThrow` p = do
r <- try action
case r of
Right _ ->
expectationFailure $
"did not get expected exception: " ++ exceptionType
Left e ->
(`expectTrue` p e) $
"predicate failed on expected exception: " ++ exceptionType ++ "\n" ++ show e
where
-- a string representation of the expected exception's type
exceptionType = (show . typeOf . instanceOf) p
where
instanceOf :: Selector a -> a
instanceOf _ = error "Effectful.Hspec.shouldThrow: broken Typeable instance"
-- | Lifted 'Hspec.prop'.
prop :: (HasCallStack, QuickCheck.Testable prop, Hspec :> es) => String -> prop -> Eff es ()
prop = (appendSpec .) . Hspec.prop
-- | Lifted 'Hspec.xprop'.
xprop :: (HasCallStack, QuickCheck.Testable prop, Hspec :> es) => String -> prop -> Eff es ()
xprop = (appendSpec .) . Hspec.xprop
-- | Lifted 'Hspec.fprop'.
fprop :: (HasCallStack, QuickCheck.Testable prop, Hspec :> es) => String -> prop -> Eff es ()
fprop = (appendSpec .) . Hspec.fprop