{-# OPTIONS_HADDOCK hide #-}

module Polysemy.Test.Hedgehog where

import qualified Hedgehog as Native
import Hedgehog (TestT)

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 IO)) r =>
  InterpreterFor Hedgehog r
interpretHedgehog :: InterpreterFor Hedgehog r
interpretHedgehog =
  (forall x (rInitial :: EffectRow).
 Hedgehog (Sem rInitial) x -> Sem r x)
-> Sem (Hedgehog : 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 IO x -> Sem r x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed TestT IO x
t

-- |Embeds 'Hedgehog.assert'.
assert ::
  ∀ r .
  HasCallStack =>
  Member Hedgehog r =>
  Bool ->
  Sem r ()
assert :: Bool -> Sem r ()
assert 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 IO () -> Sem r ()
forall a (r :: EffectRow).
Member Hedgehog r =>
TestT IO a -> Sem r a
liftH (Bool -> TestT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
Native.assert Bool
a)

-- |Embeds 'Hedgehog.==='.
--
-- >>> 5 === 6
-- 5 === 6
-- ^^^^^^^
-- │ ━━━ Failed (- lhs) (+ rhs) ━━━
-- │ - 5
-- │ + 6
(===) ::
  Eq a =>
  Show a =>
  HasCallStack =>
  Member Hedgehog r =>
  a ->
  a ->
  Sem r ()
a
a === :: a -> a -> Sem r ()
=== 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 IO () -> Sem r ()
forall a (r :: EffectRow).
Member Hedgehog r =>
TestT IO a -> Sem r a
liftH (a
a a -> a -> TestT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
Native.=== a
b)

-- |Embeds 'Hedgehog.evalEither'.
evalEither ::
  ∀ a e r .
  Show e =>
  HasCallStack =>
  Member Hedgehog r =>
  Either e a ->
  Sem r a
evalEither :: Either e a -> Sem r a
evalEither 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 IO a -> Sem r a
forall a (r :: EffectRow).
Member Hedgehog r =>
TestT IO a -> Sem r a
liftH (Either e a -> TestT IO 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 e r .
  Show e =>
  Eq a =>
  Show a =>
  HasCallStack =>
  Member Hedgehog r =>
  a ->
  Either e a ->
  Sem r ()
assertRight :: a -> Either e a -> Sem r ()
assertRight a
a 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 (r :: EffectRow).
(Eq a, Show a, HasCallStack, Member Hedgehog 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 e (r :: EffectRow).
(Show e, HasCallStack, Member Hedgehog 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

assertJust ::
  Eq a =>
  Show a =>
  HasCallStack =>
  Member Hedgehog r =>
  a ->
  Maybe a ->
  Sem r ()
assertJust :: a -> Maybe a -> Sem r ()
assertJust a
target 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 e (r :: EffectRow).
(Show e, Eq a, Show a, HasCallStack, Member Hedgehog 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)

evalMaybe ::
  HasCallStack =>
  Member Hedgehog r =>
  Maybe a ->
  Sem r a
evalMaybe :: Maybe a -> Sem r a
evalMaybe 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 e (r :: EffectRow).
(Show e, HasCallStack, Member Hedgehog 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)