{-# LANGUAGE TemplateHaskell #-}

module HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog
  ( Hedgehog,

    assert,
    assertEquals,
    catchAssertion,
    eval,
    evalM,
    evalIO,
    writeLog,
    failWith,
    failWithCustom,
    throwAssertion,
    trapAssertion,

    forAll,
    classify,
    success,

    hedgehogToMonadTestFinal,
    hedgehogToPropertyFinal,
    hedgehogToTestFinal,

    catchExToPropertyFinal,

  ) where

import           HaskellWorks.Polysemy.Prelude

import qualified Hedgehog                                                as H
import qualified Hedgehog.Internal.Property                              as H

import qualified Control.Monad.Catch                                     as IO
import qualified Control.Monad.IO.Class                                  as IO
import           HaskellWorks.Polysemy.Except
import qualified HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog.Internal as I
import           Polysemy
import           Polysemy.Final

data Hedgehog m rv where
  Assert :: HasCallStack
    => Bool
    -> Hedgehog m ()

  AssertEquals :: (HasCallStack, Eq a, Show a)
    => a
    -> a
    -> Hedgehog m ()

  CatchAssertion :: HasCallStack
    => m a
    -> (H.Failure -> m a)
    -> Hedgehog m a

  Classify ::  HasCallStack
    => H.LabelName
    -> Bool
    -> Hedgehog m ()

  Eval :: HasCallStack
    => a
    -> Hedgehog m a

  EvalM :: HasCallStack
    => m a
    -> Hedgehog m a

  EvalIO :: HasCallStack
    => IO a
    -> Hedgehog m a

  FailWith :: HasCallStack
    => Maybe H.Diff
    -> String
    -> Hedgehog m a

  FailWithCustom :: ()
    => CallStack
    -> Maybe H.Diff
    -> String
    -> Hedgehog m a

  ThrowAssertion :: HasCallStack
    => H.Failure
    -> Hedgehog m a

  WriteLog :: HasCallStack
    => H.Log
    -> Hedgehog m ()

makeSem ''Hedgehog

trapAssertion :: forall a r. ()
  => Member Hedgehog r
  => (H.Failure -> Sem r a)
  -> Sem r a
  -> Sem r a
trapAssertion :: forall a (r :: EffectRow).
Member Hedgehog r =>
(Failure -> Sem r a) -> Sem r a -> Sem r a
trapAssertion = (Sem r a -> (Failure -> Sem r a) -> Sem r a)
-> (Failure -> Sem r a) -> Sem r a -> Sem r a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Sem r a -> (Failure -> Sem r a) -> Sem r a
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
Sem r a -> (Failure -> Sem r a) -> Sem r a
catchAssertion

hedgehogToMonadTestFinal :: forall a r m. ()
  => IO.MonadIO m
  => IO.MonadCatch m
  => H.MonadTest m
  => I.MonadAssertion m
  => Member (Final m) r
  => Sem (Hedgehog ': r) a
  -> Sem r a
hedgehogToMonadTestFinal :: forall a (r :: EffectRow) (m :: * -> *).
(MonadIO m, MonadCatch m, MonadTest m, MonadAssertion m,
 Member (Final m) r) =>
Sem (Hedgehog : r) a -> Sem r a
hedgehogToMonadTestFinal = (forall x (rInitial :: EffectRow).
 Hedgehog (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Hedgehog : r) a -> Sem r a
forall (m :: * -> *) (e :: Effect) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal \case
  Assert Bool
t ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ Bool -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert Bool
t
  AssertEquals a
a a
b ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
H.=== a
b
  CatchAssertion Sem rInitial x
f Failure -> Sem rInitial x
h -> do
    f ()
s  <- Sem (WithStrategy m f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    m (f x)
f' <- Sem rInitial x -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial x
f
    f Failure -> m (f x)
h' <- (Failure -> Sem rInitial x)
-> Sem (WithStrategy m f (Sem rInitial)) (f Failure -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS Failure -> Sem rInitial x
h
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a. a -> Sem (WithStrategy m f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ m (f x) -> (Failure -> m (f x)) -> m (f x)
forall a. m a -> (Failure -> m a) -> m a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
I.catchAssertion m (f x)
f' ((Failure -> m (f x)) -> m (f x))
-> (Failure -> m (f x)) -> m (f x)
forall a b. (a -> b) -> a -> b
$ \Failure
e -> do
      f Failure -> m (f x)
h' (Failure
e Failure -> f () -> f Failure
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
  Classify LabelName
labelName Bool
b ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ LabelName -> Bool -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
H.classify LabelName
labelName Bool
b
  Eval x
a ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ x -> m x
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval x
a
  EvalIO IO x
f ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ IO x -> m x
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO x
f
  EvalM Sem rInitial x
f -> do
    m (f x)
g <- Sem rInitial x -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial x
f
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a. a -> Sem (WithStrategy m f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ m (f x) -> m (f x)
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m (f x)
g
  FailWith Maybe Diff
mdiff String
msg ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ Maybe Diff -> String -> m x
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
H.failWith Maybe Diff
mdiff String
msg
  FailWithCustom CallStack
cs Maybe Diff
mdiff String
msg ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> m x
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
I.failWithCustom CallStack
cs
     Maybe Diff
mdiff String
msg
  ThrowAssertion Failure
e ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ Failure -> m x
forall a. Failure -> m a
forall (m :: * -> *) a. MonadAssertion m => Failure -> m a
I.throwAssertion Failure
e
  WriteLog Log
logValue ->
    m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (m x -> Strategic m (Sem rInitial) x)
-> m x -> Strategic m (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ Log -> m ()
forall (m :: * -> *). MonadTest m => Log -> m ()
H.writeLog Log
logValue

hedgehogToPropertyFinal :: forall a r. ()
  => Member (Final (H.PropertyT IO)) r
  => Sem (Hedgehog ': r) a
  -> Sem r a
hedgehogToPropertyFinal :: forall a (r :: EffectRow).
Member (Final (PropertyT IO)) r =>
Sem (Hedgehog : r) a -> Sem r a
hedgehogToPropertyFinal = Sem (Hedgehog : r) a -> Sem r a
forall a (r :: EffectRow) (m :: * -> *).
(MonadIO m, MonadCatch m, MonadTest m, MonadAssertion m,
 Member (Final m) r) =>
Sem (Hedgehog : r) a -> Sem r a
hedgehogToMonadTestFinal

hedgehogToTestFinal :: forall a r. ()
  => Member (Final (H.TestT IO)) r
  => Sem (Hedgehog ': r) a
  -> Sem r a
hedgehogToTestFinal :: forall a (r :: EffectRow).
Member (Final (TestT IO)) r =>
Sem (Hedgehog : r) a -> Sem r a
hedgehogToTestFinal = Sem (Hedgehog : r) a -> Sem r a
forall a (r :: EffectRow) (m :: * -> *).
(MonadIO m, MonadCatch m, MonadTest m, MonadAssertion m,
 Member (Final m) r) =>
Sem (Hedgehog : r) a -> Sem r a
hedgehogToMonadTestFinal

catchExToPropertyFinal :: forall a r. ()
  => Member (Final (H.PropertyT IO)) r
  => Sem (Except ': r) a
  -> Sem r a
catchExToPropertyFinal :: forall a (r :: EffectRow).
Member (Final (PropertyT IO)) r =>
Sem (Except : r) a -> Sem r a
catchExToPropertyFinal = Sem (Except : r) a -> Sem r a
forall a (r :: EffectRow) (m :: * -> *).
(MonadCatch m, MonadThrow m, Member (Final m) r) =>
Sem (Except : r) a -> Sem r a
catchExToFinal
{-# INLINE catchExToPropertyFinal #-}

forAll :: forall a r. ()
  => Member (Embed (H.PropertyT IO)) r
  => Member Hedgehog r
  => Show a
  => H.Gen a
  -> Sem r a
forAll :: forall a (r :: EffectRow).
(Member (Embed (PropertyT IO)) r, Member Hedgehog r, Show a) =>
Gen a -> Sem r a
forAll =
  PropertyT IO a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (PropertyT IO a -> Sem r a)
-> (Gen a -> PropertyT IO a) -> Gen a -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
H.forAll

success :: forall r. ()
  => Member Hedgehog r
  => Sem r ()
success :: forall (r :: EffectRow). Member Hedgehog r => Sem r ()
success =
  () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()