module Effectful.Zoo.Hedgehog.MonadTestProxy
  ( MonadTestProxy(..),
  ) where

import Control.Monad.Trans.Writer.Lazy qualified as MTL
import Data.Functor.Identity
import Effectful
import Effectful.Error.Static
import Effectful.Writer.Static.Local
import Effectful.Zoo.Core
import HaskellWorks.Prelude
import Hedgehog (MonadTest(..))
import Hedgehog.Internal.Property (Failure, Journal)
import Hedgehog.Internal.Property qualified as H

class Monad m => MonadTestProxy m where
  liftTestProxy :: H.Test a -> m a

instance MonadTestProxy (H.TestT IO) where
  liftTestProxy :: forall a. Test a -> TestT IO a
liftTestProxy = Test a -> TestT IO a
forall a. Test a -> TestT IO a
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest

instance (r <: Error Failure, r <: Writer Journal) => MonadTestProxy (Eff r) where
  liftTestProxy :: forall a. Test a -> Eff r a
liftTestProxy = \case
    H.TestT ExceptT Failure (WriterT Journal Identity) a
m -> do
      let (Either Failure a
result, Journal
journal) = Identity (Either Failure a, Journal) -> (Either Failure a, Journal)
forall a. Identity a -> a
runIdentity (Identity (Either Failure a, Journal)
 -> (Either Failure a, Journal))
-> Identity (Either Failure a, Journal)
-> (Either Failure a, Journal)
forall a b. (a -> b) -> a -> b
$ WriterT Journal Identity (Either Failure a)
-> Identity (Either Failure a, Journal)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
MTL.runWriterT (WriterT Journal Identity (Either Failure a)
 -> Identity (Either Failure a, Journal))
-> WriterT Journal Identity (Either Failure a)
-> Identity (Either Failure a, Journal)
forall a b. (a -> b) -> a -> b
$ ExceptT Failure (WriterT Journal Identity) a
-> WriterT Journal Identity (Either Failure a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Failure (WriterT Journal Identity) a
m
      Journal -> Eff r ()
forall w (es :: [Effect]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell Journal
journal
      case Either Failure a
result of
        Left (H.Failure Maybe Span
loc String
err Maybe Diff
diff) ->
          Failure -> Eff r a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (Maybe Span -> String -> Maybe Diff -> Failure
H.Failure Maybe Span
loc String
err Maybe Diff
diff)
        Right a
a ->
          a -> Eff r a
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a