{-# 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 ()