{-# LANGUAGE GADTs           #-}
{-# LANGUAGE TemplateHaskell #-}

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

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

  , 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
  AssertEquals :: (HasCallStack, Eq a, Show a)
    => a
    -> a
    -> Hedgehog m ()

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

  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
  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)
  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 #-}