Hspec.hs

{-# LANGUAGE ImpredicativeTypes #-}
{-# OPTIONS_GHC -Wno-missing-role-annotations #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

      -- * Spec construction
    , describe
    , context
    , it
    , specify
    , pending
    , pendingWith

      -- * Skipping
    , xit
    , xspecify
    , xdescribe
    , xcontext

      -- * Focusing
    , focus
    , fit
    , fspecify
    , fdescribe
    , fcontext

      -- * Setup / Teardown
    , before_
    , beforeAll_
    , after_
    , afterAll_
    , around_
    , aroundAll_

      -- * Expectations
    , expectationFailure
    , shouldBe
    , shouldSatisfy
    , shouldStartWith
    , shouldEndWith
    , shouldContain
    , shouldMatchList
    , shouldReturn
    , shouldNotBe
    , shouldNotSatisfy
    , shouldNotContain
    , shouldNotReturn
    , shouldThrow
    , anyException
    , Config (..)
    , defaultConfig
    , Hspec.Spec
    , HasCallStack
    )
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.Runner (Config (..), defaultConfig)
import Test.Hspec.Runner qualified as Hspec
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

-- | Lifted 'Hspec.describe'
describe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a
describe label action =
    stateStaticRepM \before -> do
        putStaticRep before{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, before{spec = spec before >> Hspec.describe label (spec after)})

-- | Lifted 'Hspec.it'
it :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es ()
it label action = do
    ioAction <-
        unsafeConcUnliftIO Ephemeral Unlimited \runInIO ->
            pure (runInIO action)
    stateStaticRep \hspec -> ((), hspec{spec = spec hspec >> 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 action =
    stateStaticRepM \before -> do
        putStaticRep before{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, before{spec = spec before >> Hspec.focus (spec after)})

-- | 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.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)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.before_ ioSetup (spec after)})

-- | 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)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.beforeAll_ ioSetup (spec after)})

-- | 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)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.after_ ioTeardown (spec after)})

-- | 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)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.afterAll_ ioTeardown (spec after)})

-- | 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_)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.around_ ioWrapper (spec after)})

-- | 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_)
    stateStaticRepM \prev -> do
        putStaticRep prev{spec = pure ()}
        result <- action
        after <- getStaticRep
        pure (result, prev{spec = spec prev >> Hspec.aroundAll_ ioWrapper (spec after)})

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"