{-# options_haddock prune #-}

-- |Hedgehog interpreters, internal
module Polysemy.Test.Hedgehog where

import Control.Monad.Trans.Except (runExceptT)
import qualified Control.Monad.Trans.Writer.Lazy as MTL
import qualified Hedgehog as Native
import Hedgehog.Internal.Property (Failure, Journal, TestT (TestT), failWith)

import qualified Polysemy.Test.Data.Hedgehog as Hedgehog
import Polysemy.Test.Data.Hedgehog (Hedgehog, liftH)

-- |Interpret 'Hedgehog' into @'TestT' IO@ by simple embedding of the native combinators.
interpretHedgehog ::
  Member (Embed (TestT m)) r =>
  InterpreterFor (Hedgehog m) r
interpretHedgehog :: forall (m :: * -> *) (r :: EffectRow).
Member (Embed (TestT m)) r =>
InterpreterFor (Hedgehog m) r
interpretHedgehog =
  forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Hedgehog.LiftH TestT m x
t ->
      forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed TestT m x
t

-- |Interpret 'Hedgehog' in terms of @'Error' 'Failure'@ and @'Writer' 'Journal'@, which correspond to the monad stack
-- wrapped by 'TestT'.
rewriteHedgehog ::
  Members [Error Failure, Writer Journal, Embed m] r =>
  InterpreterFor (Hedgehog m) r
rewriteHedgehog :: forall (m :: * -> *) (r :: EffectRow).
Members '[Error Failure, Writer Journal, Embed m] r =>
InterpreterFor (Hedgehog m) r
rewriteHedgehog =
  forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Hedgehog.LiftH (TestT ExceptT Failure (WriterT Journal m) x
t) -> do
      (Either Failure x
result, Journal
journal) <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
MTL.runWriterT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Failure (WriterT Journal m) x
t))
      forall o (r :: EffectRow). Member (Writer o) r => o -> Sem r ()
tell Journal
journal
      forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither Either Failure x
result

-- |Embeds 'Hedgehog.assert'.
assert ::
  ∀ m r .
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  Bool ->
  Sem r ()
assert :: forall (m :: * -> *) (r :: EffectRow).
(Monad m, HasCallStack, Member (Hedgehog m) r) =>
Bool -> Sem r ()
assert Bool
a =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
Native.assert Bool
a)

infix 4 ===

-- |Embeds 'Hedgehog.==='.
--
-- >>> 5 === 6
-- 5 === 6
-- ^^^^^^^
-- │ ━━━ Failed (- lhs) (+ rhs) ━━━
-- │ - 5
-- │ + 6
(===) ::
  ∀ a m r .
  Monad m =>
  Eq a =>
  Show a =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  Sem r ()
a
a === :: forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
=== a
b =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (a
a forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native.=== a
b)

infix 4 /==

-- |Prefix variant of '(===)'.
assertEq ::
  ∀ a m r .
  Monad m =>
  Eq a =>
  Show a =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  Sem r ()
assertEq :: forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
assertEq a
a a
b =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (a
a forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native.=== a
b)

-- |Embeds 'Hedgehog./=='.
--
-- >>> 5 /== 5
-- 5 /== 5
-- ^^^^^^^
-- │ ━━━ Failed (no differences) ━━━
-- │ 5
(/==) ::
  ∀ a m r .
  Monad m =>
  Eq a =>
  Show a =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  Sem r ()
a
a /== :: forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
/== a
b =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (a
a forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native./== a
b)

-- |Prefix variant of '(/==)'.
assertNeq ::
  ∀ a m r .
  Monad m =>
  Eq a =>
  Show a =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  Sem r ()
assertNeq :: forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
assertNeq a
a a
b =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (a
a forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native./== a
b)

-- |Embeds 'Hedgehog.evalEither'.
evalEither ::
  ∀ a m e r .
  Show e =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  Either e a ->
  Sem r a
evalEither :: forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither Either e a
e =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (forall (m :: * -> *) x a.
(MonadTest m, Show x, HasCallStack) =>
Either x a -> m a
Native.evalEither Either e a
e)

-- |Given a reference value, unpacks an 'Either' with 'evalEither' and applies '===' to the result in the
-- 'Right' case, and produces a test failure in the 'Left' case.
assertRight ::
  ∀ a m e r .
  Eq a =>
  Show e =>
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  Either e a ->
  Sem r ()
assertRight :: forall a (m :: * -> *) e (r :: EffectRow).
(Eq a, Show e, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e a -> Sem r ()
assertRight a
a =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
assertEq @_ @m a
a forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither @_ @m

-- |Like 'assertRight', but for two nested Eithers.
assertRight2 ::
  ∀ a m e1 e2 r .
  Eq a =>
  Show e1 =>
  Show e2 =>
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  Either e1 (Either e2 a) ->
  Sem r ()
assertRight2 :: forall a (m :: * -> *) e1 e2 (r :: EffectRow).
(Eq a, Show e1, Show e2, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e1 (Either e2 a) -> Sem r ()
assertRight2 a
a =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) e (r :: EffectRow).
(Eq a, Show e, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e a -> Sem r ()
assertRight @_ @m a
a forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither @_ @m

-- |Like 'assertRight', but for three nested Eithers.
assertRight3 ::
  ∀ a m e1 e2 e3 r .
  Eq a =>
  Show e1 =>
  Show e2 =>
  Show e3 =>
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  Either e1 (Either e2 (Either e3 a)) ->
  Sem r ()
assertRight3 :: forall a (m :: * -> *) e1 e2 e3 (r :: EffectRow).
(Eq a, Show e1, Show e2, Show e3, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e1 (Either e2 (Either e3 a)) -> Sem r ()
assertRight3 a
a =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) e1 e2 (r :: EffectRow).
(Eq a, Show e1, Show e2, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e1 (Either e2 a) -> Sem r ()
assertRight2 @_ @m a
a forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither @_ @m

-- |Like 'evalEither', but for 'Left'.
evalLeft ::
  ∀ a m e r .
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  Either e a ->
  Sem r e
evalLeft :: forall a (m :: * -> *) e (r :: EffectRow).
(Show a, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r e
evalLeft = \case
  Right a
a ->
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
      forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith forall a. Maybe a
Nothing (forall b a. (Show a, IsString b) => a -> b
show a
a))
  Left e
e ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e

-- |Like 'assertRight', but for 'Left'.
assertLeft ::
  ∀ a m e r .
  Eq e =>
  Show e =>
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  e ->
  Either e a ->
  Sem r ()
assertLeft :: forall a (m :: * -> *) e (r :: EffectRow).
(Eq e, Show e, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
e -> Either e a -> Sem r ()
assertLeft e
e =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
assertEq @_ @m e
e forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a (m :: * -> *) e (r :: EffectRow).
(Show a, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r e
evalLeft @_ @m

data ValueIsNothing =
  ValueIsNothing
  deriving stock Int -> ValueIsNothing -> ShowS
[ValueIsNothing] -> ShowS
ValueIsNothing -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueIsNothing] -> ShowS
$cshowList :: [ValueIsNothing] -> ShowS
show :: ValueIsNothing -> String
$cshow :: ValueIsNothing -> String
showsPrec :: Int -> ValueIsNothing -> ShowS
$cshowsPrec :: Int -> ValueIsNothing -> ShowS
Show

-- |Like 'evalEither', but for 'Maybe'.
evalMaybe ::
  ∀ a m r .
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  Maybe a ->
  Sem r a
evalMaybe :: forall a (m :: * -> *) (r :: EffectRow).
(Monad m, HasCallStack, Member (Hedgehog m) r) =>
Maybe a -> Sem r a
evalMaybe Maybe a
ma =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither @_ @m (forall l r. l -> Maybe r -> Either l r
maybeToRight ValueIsNothing
ValueIsNothing Maybe a
ma)

-- |Given a reference value, asserts that the scrutinee is 'Just' and its contained value matches the target.
assertJust ::
  ∀ a m r .
  Eq a =>
  Show a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  Maybe a ->
  Sem r ()
assertJust :: forall a (m :: * -> *) (r :: EffectRow).
(Eq a, Show a, Monad m, HasCallStack, Member (Hedgehog m) r) =>
a -> Maybe a -> Sem r ()
assertJust a
target Maybe a
ma =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) e (r :: EffectRow).
(Eq a, Show e, Show a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> Either e a -> Sem r ()
assertRight @_ @m a
target (forall l r. l -> Maybe r -> Either l r
maybeToRight ValueIsNothing
ValueIsNothing Maybe a
ma)

-- |Run a Polysemy 'Error' effect and assert its result.
evalError ::
  ∀ e a m r .
  Show e =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  Sem (Error e : r) a ->
  Sem r a
evalError :: forall e a (m :: * -> *) (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Sem (Error e : r) a -> Sem r a
evalError Sem (Error e : r) a
sem =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither @_ @m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem (Error e : r) a
sem

-- |Assert that two numeric values are closer to each other than the specified @delta@.
assertCloseBy ::
  ∀ a m r .
  Num a =>
  Ord a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  a ->
  Sem r ()
assertCloseBy :: forall a (m :: * -> *) (r :: EffectRow).
(Num a, Ord a, Monad m, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> a -> Sem r ()
assertCloseBy a
delta a
target a
scrutinee =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall (m :: * -> *) (r :: EffectRow).
(Monad m, HasCallStack, Member (Hedgehog m) r) =>
Bool -> Sem r ()
assert @m (forall a. Num a => a -> a
abs (a
scrutinee forall a. Num a => a -> a -> a
- a
target) forall a. Ord a => a -> a -> Bool
< a
delta)

-- |Assert that two fractional values are closer to each other than @0.001@.
assertClose ::
  ∀ a m r .
  Ord a =>
  Fractional a =>
  Monad m =>
  HasCallStack =>
  Member (Hedgehog m) r =>
  a ->
  a ->
  Sem r ()
assertClose :: forall a (m :: * -> *) (r :: EffectRow).
(Ord a, Fractional a, Monad m, HasCallStack,
 Member (Hedgehog m) r) =>
a -> a -> Sem r ()
assertClose =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    forall a (m :: * -> *) (r :: EffectRow).
(Num a, Ord a, Monad m, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> a -> Sem r ()
assertCloseBy @_ @m a
0.001