{-# OPTIONS_GHC -fno-warn-orphans #-}

module Effectful.Zoo.Hedgehog.Dynamic
  ( Hedgehog(..),
    MonadTest(..),

    runHedgehogIO,
    runHedgehog,
  ) where

import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.Writer.Static.Local
import Effectful.Zoo.Core
import Effectful.Zoo.Hedgehog.MonadTestProxy
import HaskellWorks.Prelude
import Hedgehog (MonadTest(..))
import Hedgehog qualified as H
import Hedgehog.Internal.Property (Failure, Journal)
import Hedgehog.Internal.Property qualified as H

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

  LiftTest :: HasCallStack
    => H.Test a
    -> Hedgehog m a

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

type instance DispatchOf Hedgehog = Dynamic

instance (r <: Hedgehog) => MonadTest (Eff r) where
  liftTest :: forall a. Test a -> Eff r a
liftTest Test a
t = Hedgehog (Eff r) a -> Eff r a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hedgehog (Eff r) a -> Eff r a) -> Hedgehog (Eff r) a -> Eff r a
forall a b. (a -> b) -> a -> b
$ Test a -> Hedgehog (Eff r) a
forall a (m :: * -> *). HasCallStack => Test a -> Hedgehog m a
LiftTest Test a
t

runHedgehogIO :: forall a. ()
  => Eff
      [ Hedgehog
      , Error Failure
      , Writer Journal
      , IOE
      ] a
  -> IO (Either Failure a, Journal)
runHedgehogIO :: forall a.
Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
-> IO (Either Failure a, Journal)
runHedgehogIO Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
f =
  Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
f
    Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
-> (Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
    -> Eff '[Error Failure, Writer Journal, IOE] a)
-> Eff '[Error Failure, Writer Journal, IOE] a
forall a b. a -> (a -> b) -> b
& Eff '[Hedgehog, Error Failure, Writer Journal, IOE] a
-> Eff '[Error Failure, Writer Journal, IOE] a
forall a (r :: [Effect]).
(r <: Error Failure, r <: Writer Journal) =>
Eff (Hedgehog : r) a -> Eff r a
runHedgehog
    Eff '[Error Failure, Writer Journal, IOE] a
-> (Eff '[Error Failure, Writer Journal, IOE] a
    -> Eff '[Writer Journal, IOE] (Either (CallStack, Failure) a))
-> Eff '[Writer Journal, IOE] (Either (CallStack, Failure) a)
forall a b. a -> (a -> b) -> b
& forall e (es :: [Effect]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError @H.Failure
    Eff '[Writer Journal, IOE] (Either (CallStack, Failure) a)
-> (Eff '[Writer Journal, IOE] (Either (CallStack, Failure) a)
    -> Eff '[IOE] (Either (CallStack, Failure) a, Journal))
-> Eff '[IOE] (Either (CallStack, Failure) a, Journal)
forall a b. a -> (a -> b) -> b
& forall w (es :: [Effect]) a.
(HasCallStack, Monoid w) =>
Eff (Writer w : es) a -> Eff es (a, w)
runWriter @H.Journal
    Eff '[IOE] (Either (CallStack, Failure) a, Journal)
-> (Eff '[IOE] (Either (CallStack, Failure) a, Journal)
    -> Eff '[IOE] (Either Failure a, Journal))
-> Eff '[IOE] (Either Failure a, Journal)
forall a b. a -> (a -> b) -> b
& ((Either (CallStack, Failure) a, Journal)
 -> (Either Failure a, Journal))
-> Eff '[IOE] (Either (CallStack, Failure) a, Journal)
-> Eff '[IOE] (Either Failure a, Journal)
forall a b. (a -> b) -> Eff '[IOE] a -> Eff '[IOE] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either (CallStack, Failure) a -> Either Failure a)
-> (Either (CallStack, Failure) a, Journal)
-> (Either Failure a, Journal)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((CallStack, Failure) -> Failure)
-> Either (CallStack, Failure) a -> Either Failure a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (CallStack, Failure) -> Failure
forall a b. (a, b) -> b
snd))
    Eff '[IOE] (Either Failure a, Journal)
-> (Eff '[IOE] (Either Failure a, Journal)
    -> IO (Either Failure a, Journal))
-> IO (Either Failure a, Journal)
forall a b. a -> (a -> b) -> b
& Eff '[IOE] (Either Failure a, Journal)
-> IO (Either Failure a, Journal)
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff

runHedgehog :: forall a r. ()
  => r <: Error Failure
  => r <: Writer Journal
  => Eff (Hedgehog : r) a
  -> Eff r a
runHedgehog :: forall a (r :: [Effect]).
(r <: Error Failure, r <: Writer Journal) =>
Eff (Hedgehog : r) a -> Eff r a
runHedgehog =
  EffectHandler Hedgehog r -> Eff (Hedgehog : r) a -> Eff r a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret (EffectHandler Hedgehog r -> Eff (Hedgehog : r) a -> Eff r a)
-> EffectHandler Hedgehog r -> Eff (Hedgehog : r) a -> Eff r a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs r
env -> \case
    CatchAssertion Eff localEs a
f Failure -> Eff localEs a
h -> LocalEnv localEs r
-> UnliftStrategy
-> ((forall {r}. Eff localEs r -> Eff r r) -> Eff r a)
-> Eff r a
forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SharedSuffix es handlerEs) =>
LocalEnv localEs handlerEs
-> UnliftStrategy
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> Eff es a
localUnlift LocalEnv localEs r
env UnliftStrategy
SeqUnlift (((forall {r}. Eff localEs r -> Eff r r) -> Eff r a) -> Eff r a)
-> ((forall {r}. Eff localEs r -> Eff r r) -> Eff r a) -> Eff r a
forall a b. (a -> b) -> a -> b
$ \forall {r}. Eff localEs r -> Eff r r
unlift -> Eff r a -> (CallStack -> Failure -> Eff r a) -> Eff r a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
catchError (Eff localEs a -> Eff r a
forall {r}. Eff localEs r -> Eff r r
unlift Eff localEs a
f) ((Failure -> Eff r a) -> CallStack -> Failure -> Eff r a
forall a b. a -> b -> a
const (Eff localEs a -> Eff r a
forall {r}. Eff localEs r -> Eff r r
unlift (Eff localEs a -> Eff r a)
-> (Failure -> Eff localEs a) -> Failure -> Eff r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Eff localEs a
h))
    LiftTest Test a
f -> Test a -> Eff r a
forall a. Test a -> Eff r a
forall (m :: * -> *) a. MonadTestProxy m => Test a -> m a
liftTestProxy Test a
f
    ThrowAssertion Failure
failure -> Failure -> Eff r a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError Failure
failure