{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Hedgehog.Extras.Test.Unit
  ( UnitIO(..)
  , testUnitIO
  ) where

import Control.Monad.Base
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Morph
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Resource
import Data.Generics.Product.Any
import Data.Maybe
import Data.Monoid
import HaskellWorks.Prelude
import Hedgehog
import Hedgehog.Extras.Internal.Orphans ()
import Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)
import Hedgehog.Internal.Property qualified as H
import Lens.Micro
import Test.Tasty.Discover
import Test.Tasty.Hedgehog (testProperty)

import qualified Test.Tasty as T

newtype UnitIO a = UnitIO { forall a. UnitIO a -> TestT (ResourceT IO) a
runTestIO :: TestT (ResourceT IO) a }
  deriving newtype (Functor UnitIO
Functor UnitIO =>
(forall a. a -> UnitIO a)
-> (forall a b. UnitIO (a -> b) -> UnitIO a -> UnitIO b)
-> (forall a b c.
    (a -> b -> c) -> UnitIO a -> UnitIO b -> UnitIO c)
-> (forall a b. UnitIO a -> UnitIO b -> UnitIO b)
-> (forall a b. UnitIO a -> UnitIO b -> UnitIO a)
-> Applicative UnitIO
forall a. a -> UnitIO a
forall a b. UnitIO a -> UnitIO b -> UnitIO a
forall a b. UnitIO a -> UnitIO b -> UnitIO b
forall a b. UnitIO (a -> b) -> UnitIO a -> UnitIO b
forall a b c. (a -> b -> c) -> UnitIO a -> UnitIO b -> UnitIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> UnitIO a
pure :: forall a. a -> UnitIO a
$c<*> :: forall a b. UnitIO (a -> b) -> UnitIO a -> UnitIO b
<*> :: forall a b. UnitIO (a -> b) -> UnitIO a -> UnitIO b
$cliftA2 :: forall a b c. (a -> b -> c) -> UnitIO a -> UnitIO b -> UnitIO c
liftA2 :: forall a b c. (a -> b -> c) -> UnitIO a -> UnitIO b -> UnitIO c
$c*> :: forall a b. UnitIO a -> UnitIO b -> UnitIO b
*> :: forall a b. UnitIO a -> UnitIO b -> UnitIO b
$c<* :: forall a b. UnitIO a -> UnitIO b -> UnitIO a
<* :: forall a b. UnitIO a -> UnitIO b -> UnitIO a
Applicative)
  deriving newtype ((forall a b. (a -> b) -> UnitIO a -> UnitIO b)
-> (forall a b. a -> UnitIO b -> UnitIO a) -> Functor UnitIO
forall a b. a -> UnitIO b -> UnitIO a
forall a b. (a -> b) -> UnitIO a -> UnitIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> UnitIO a -> UnitIO b
fmap :: forall a b. (a -> b) -> UnitIO a -> UnitIO b
$c<$ :: forall a b. a -> UnitIO b -> UnitIO a
<$ :: forall a b. a -> UnitIO b -> UnitIO a
Functor)
  deriving newtype (Applicative UnitIO
Applicative UnitIO =>
(forall a b. UnitIO a -> (a -> UnitIO b) -> UnitIO b)
-> (forall a b. UnitIO a -> UnitIO b -> UnitIO b)
-> (forall a. a -> UnitIO a)
-> Monad UnitIO
forall a. a -> UnitIO a
forall a b. UnitIO a -> UnitIO b -> UnitIO b
forall a b. UnitIO a -> (a -> UnitIO b) -> UnitIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. UnitIO a -> (a -> UnitIO b) -> UnitIO b
>>= :: forall a b. UnitIO a -> (a -> UnitIO b) -> UnitIO b
$c>> :: forall a b. UnitIO a -> UnitIO b -> UnitIO b
>> :: forall a b. UnitIO a -> UnitIO b -> UnitIO b
$creturn :: forall a. a -> UnitIO a
return :: forall a. a -> UnitIO a
Monad)
  deriving newtype (Monad UnitIO
Monad UnitIO =>
(forall a. Failure -> UnitIO a)
-> (forall a. UnitIO a -> (Failure -> UnitIO a) -> UnitIO a)
-> MonadAssertion UnitIO
forall a. Failure -> UnitIO a
forall a. UnitIO a -> (Failure -> UnitIO a) -> UnitIO a
forall (m :: * -> *).
Monad m =>
(forall a. Failure -> m a)
-> (forall a. m a -> (Failure -> m a) -> m a) -> MonadAssertion m
$cthrowAssertion :: forall a. Failure -> UnitIO a
throwAssertion :: forall a. Failure -> UnitIO a
$ccatchAssertion :: forall a. UnitIO a -> (Failure -> UnitIO a) -> UnitIO a
catchAssertion :: forall a. UnitIO a -> (Failure -> UnitIO a) -> UnitIO a
MonadAssertion)
  deriving newtype (MonadBase IO)
  deriving newtype (MonadBaseControl IO)
  deriving newtype (MonadThrow UnitIO
MonadThrow UnitIO =>
(forall e a.
 (HasCallStack, Exception e) =>
 UnitIO a -> (e -> UnitIO a) -> UnitIO a)
-> MonadCatch UnitIO
forall e a.
(HasCallStack, Exception e) =>
UnitIO a -> (e -> UnitIO a) -> UnitIO a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
UnitIO a -> (e -> UnitIO a) -> UnitIO a
catch :: forall e a.
(HasCallStack, Exception e) =>
UnitIO a -> (e -> UnitIO a) -> UnitIO a
MonadCatch)
  deriving newtype (Monad UnitIO
Monad UnitIO => (forall a. String -> UnitIO a) -> MonadFail UnitIO
forall a. String -> UnitIO a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> UnitIO a
fail :: forall a. String -> UnitIO a
MonadFail)
  deriving newtype (Monad UnitIO
Monad UnitIO => (forall α. IO α -> UnitIO α) -> MonadIO UnitIO
forall α. IO α -> UnitIO α
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall α. IO α -> UnitIO α
liftIO :: forall α. IO α -> UnitIO α
MonadIO)
  deriving newtype (MonadIO UnitIO
MonadIO UnitIO =>
(forall a. ResourceT IO a -> UnitIO a) -> MonadResource UnitIO
forall a. ResourceT IO a -> UnitIO a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
$cliftResourceT :: forall a. ResourceT IO a -> UnitIO a
liftResourceT :: forall a. ResourceT IO a -> UnitIO a
MonadResource)
  deriving newtype (Monad UnitIO
Monad UnitIO => (forall a. Test a -> UnitIO a) -> MonadTest UnitIO
forall a. Test a -> UnitIO a
forall (m :: * -> *).
Monad m =>
(forall a. Test a -> m a) -> MonadTest m
$cliftTest :: forall a. Test a -> UnitIO a
liftTest :: forall a. Test a -> UnitIO a
MonadTest)
  deriving newtype (Monad UnitIO
Monad UnitIO =>
(forall e a. (HasCallStack, Exception e) => e -> UnitIO a)
-> MonadThrow UnitIO
forall e a. (HasCallStack, Exception e) => e -> UnitIO a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> UnitIO a
throwM :: forall e a. (HasCallStack, Exception e) => e -> UnitIO a
MonadThrow)

instance Tasty (UnitIO ()) where
  tasty :: TastyInfo -> UnitIO () -> IO TestTree
tasty TastyInfo
info = TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> IO TestTree)
-> (UnitIO () -> TestTree) -> UnitIO () -> IO TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnitIO () -> TestTree
testUnitIO String
testName
    where testName :: String
testName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Last String -> Maybe String
forall a. Last a -> Maybe a
getLast (TastyInfo
info TastyInfo
-> Getting (Last String) TastyInfo (Last String) -> Last String
forall s a. s -> Getting a s a -> a
^. forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"name")

testUnitIO :: T.TestName -> UnitIO () -> T.TestTree
testUnitIO :: String -> UnitIO () -> TestTree
testUnitIO String
testName =
  String -> Property -> TestTree
testProperty String
testName (Property -> TestTree)
-> (UnitIO () -> Property) -> UnitIO () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Property -> Property
H.withTests TestLimit
1 (Property -> Property)
-> (UnitIO () -> Property) -> UnitIO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
H.property (PropertyT IO () -> Property)
-> (UnitIO () -> PropertyT IO ()) -> UnitIO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ResourceT IO a -> IO a)
-> PropertyT (ResourceT IO) () -> PropertyT IO ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> PropertyT m b -> PropertyT n b
hoist ResourceT IO a -> IO a
forall a. ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (PropertyT (ResourceT IO) () -> PropertyT IO ())
-> (UnitIO () -> PropertyT (ResourceT IO) ())
-> UnitIO ()
-> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestT (ResourceT IO) () -> PropertyT (ResourceT IO) ()
forall (m :: * -> *) a. Monad m => TestT m a -> PropertyT m a
H.test (TestT (ResourceT IO) () -> PropertyT (ResourceT IO) ())
-> (UnitIO () -> TestT (ResourceT IO) ())
-> UnitIO ()
-> PropertyT (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitIO () -> TestT (ResourceT IO) ()
forall a. UnitIO a -> TestT (ResourceT IO) a
runTestIO