{-# LANGUAGE Unsafe #-}

module Yaya.Hedgehog
  ( evalNonterminating,
    nonterminatingProperty,
  )
where

import safe "base" Control.Category (Category ((.)))
import safe "base" Control.Monad ((<=<))
import safe "base" Control.Monad.IO.Class (MonadIO)
import safe "base" Data.Function (const)
import safe "base" Data.Maybe (maybe)
import "base" GHC.IO (evaluate)
import safe "base" GHC.Stack (HasCallStack)
import safe "base" System.Timeout (timeout)
import safe "base" Text.Show (Show)
import qualified "hedgehog" Hedgehog as HH

-- | Returns success if the expression doesn’t terminate, failure otherwise.
--   Termination is just checked with a 1 second timeout, so this isn’t
--   foolproof.
evalNonterminating ::
  (HasCallStack, MonadIO m, HH.MonadTest m, Show a) => a -> m ()
evalNonterminating :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadTest m, Show a) =>
a -> m ()
evalNonterminating =
  m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
forall (m :: * -> *). MonadTest m => m ()
HH.success (m () -> () -> m ()
forall a b. a -> b -> a
const m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
HH.failure (() -> m ()) -> (a -> m ()) -> a -> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
HH.annotateShow)
    (Maybe a -> m ()) -> (a -> m (Maybe a)) -> a -> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
HH.evalIO (IO (Maybe a) -> m (Maybe a))
-> (a -> IO (Maybe a)) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
1_000_000 (IO a -> IO (Maybe a)) -> (a -> IO a) -> a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> IO a
forall a. a -> IO a
evaluate

-- | Returns success if the expression doesn’t terminate, failure otherwise.
--   The value passed here should termina
nonterminatingProperty :: (HasCallStack, Show a) => a -> HH.Property
nonterminatingProperty :: forall a. (HasCallStack, Show a) => a -> Property
nonterminatingProperty = TestLimit -> Property -> Property
HH.withTests TestLimit
1 (Property -> Property) -> (a -> Property) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
HH.property (PropertyT IO () -> Property)
-> (a -> PropertyT IO ()) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> PropertyT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadTest m, Show a) =>
a -> m ()
evalNonterminating