{-# OPTIONS_HADDOCK hide #-}

module Polysemy.Test.Hedgehog where

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

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 :: InterpreterFor (Hedgehog m) r
interpretHedgehog =
  (forall x (rInitial :: EffectRow).
 Hedgehog m (Sem rInitial) x -> Sem r x)
-> Sem (Hedgehog m : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Hedgehog.LiftH t ->
      TestT m x -> Sem r x
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 :: InterpreterFor (Hedgehog m) r
rewriteHedgehog =
  (forall x (rInitial :: EffectRow).
 Hedgehog m (Sem rInitial) x -> Sem r x)
-> Sem (Hedgehog m : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Hedgehog.LiftH (TestT t) -> do
      (result :: Either Failure x
result, journal :: Journal
journal) <- m (Either Failure x, Journal) -> Sem r (Either Failure x, Journal)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (WriterT Journal m (Either Failure x)
-> m (Either Failure x, Journal)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
MTL.runWriterT (ExceptT Failure (WriterT Journal m) x
-> WriterT Journal m (Either Failure x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Failure (WriterT Journal m) x
t))
      Journal -> Sem r ()
forall o (r :: EffectRow).
MemberWithError (Writer o) r =>
o -> Sem r ()
tell Journal
journal
      Either Failure x -> Sem r x
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 :: Bool -> Sem r ()
assert a :: Bool
a =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TestT m () -> Sem r ()
forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH (Bool -> TestT 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
a === :: a -> a -> Sem r ()
=== b :: a
b =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TestT m () -> Sem r ()
forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH (a
a a -> a -> TestT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native.=== a
b)

infix 4 /==

-- |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
a /== :: a -> a -> Sem r ()
/== b :: a
b =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TestT m () -> Sem r ()
forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH (a
a a -> a -> TestT m ()
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 :: Either e a -> Sem r a
evalEither e :: Either e a
e =
  (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ TestT m a -> Sem r a
forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH (Either e a -> TestT m a
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 :: a -> Either e a -> Sem r ()
assertRight a :: a
a e :: Either e a
e =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ (a
a a -> a -> Sem r ()
forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
===) (a -> Sem r ()) -> Sem r a -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either e a -> Sem r a
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

data ValueIsNothing =
  ValueIsNothing
  deriving Int -> ValueIsNothing -> ShowS
[ValueIsNothing] -> ShowS
ValueIsNothing -> String
(Int -> ValueIsNothing -> ShowS)
-> (ValueIsNothing -> String)
-> ([ValueIsNothing] -> ShowS)
-> Show ValueIsNothing
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 :: Maybe a -> Sem r a
evalMaybe ma :: Maybe a
ma =
  (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Either ValueIsNothing a -> Sem r a
forall a (m :: * -> *) e (r :: EffectRow).
(Show e, Monad m, HasCallStack, Member (Hedgehog m) r) =>
Either e a -> Sem r a
evalEither (ValueIsNothing -> Maybe a -> Either ValueIsNothing a
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 :: a -> Maybe a -> Sem r ()
assertJust target :: a
target ma :: Maybe a
ma =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ a -> Either ValueIsNothing a -> Sem r ()
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
target (ValueIsNothing -> Maybe a -> Either ValueIsNothing a
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 :: Sem (Error e : r) a -> Sem r a
evalError sem :: Sem (Error e : r) a
sem =
  (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Either e a -> Sem r a
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 -> Sem r a) -> Sem r (Either e a) -> Sem r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem (Error e : r) a
sem