module Ribosome.Test.Wait where

import Hedgehog.Internal.Property (Failure, failWith, liftTest, mkTest)
import qualified Conc
import Conc (interpretAtomic)
import Polysemy.Test (Hedgehog, liftH)
import qualified Polysemy.Time as Time
import Polysemy.Time (MilliSeconds (MilliSeconds), Seconds (Seconds))

assertWaitFor ::
  Monad m =>
  HasCallStack =>
  Members [Hedgehog m, Time t d, Race, Error Failure, Embed IO] r =>
  TimeUnit t1 =>
  TimeUnit t2 =>
  t1 ->
  t2 ->
  Sem r a ->
  (a -> Sem r b) ->
  Sem r b
assertWaitFor :: forall (m :: * -> *) t d (r :: EffectRow) t1 t2 a b.
(Monad m, HasCallStack,
 Members '[Hedgehog m, Time t d, Race, Error Failure, Embed IO] r,
 TimeUnit t1, TimeUnit t2) =>
t1 -> t2 -> Sem r a -> (a -> Sem r b) -> Sem r b
assertWaitFor t1
timeout t2
interval Sem r a
acquire a -> Sem r b
test =
  (HasCallStack => Sem r b) -> Sem r b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Maybe Failure -> InterpreterFor (AtomicState (Maybe Failure)) r
forall a (r :: EffectRow).
Member (Embed IO) r =>
a -> InterpreterFor (AtomicState a) r
interpretAtomic Maybe Failure
forall a. Maybe a
Nothing do
      Sem (AtomicState (Maybe Failure) : r) b
-> t1
-> Sem (AtomicState (Maybe Failure) : r) b
-> Sem (AtomicState (Maybe Failure) : r) b
forall u (r :: EffectRow) a.
(TimeUnit u, Member Race r) =>
Sem r a -> u -> Sem r a -> Sem r a
Conc.timeout_ Sem (AtomicState (Maybe Failure) : r) b
forall {b}. Sem (AtomicState (Maybe Failure) : r) b
timeoutError t1
timeout Sem (AtomicState (Maybe Failure) : r) b
spin
  where
    spin :: Sem (AtomicState (Maybe Failure) : r) b
spin = do
      a
a <- Sem r a -> Sem (AtomicState (Maybe Failure) : r) a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise Sem r a
acquire
      Sem (AtomicState (Maybe Failure) : r) b
-> (Failure -> Sem (AtomicState (Maybe Failure) : r) b)
-> Sem (AtomicState (Maybe Failure) : r) b
forall e (r :: EffectRow) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
catch (Sem r b -> Sem (AtomicState (Maybe Failure) : r) b
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r b
test a
a)) \ Failure
e -> do
        Maybe Failure -> Sem (AtomicState (Maybe Failure) : r) ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut (Failure -> Maybe Failure
forall a. a -> Maybe a
Just Failure
e)
        t2 -> Sem (AtomicState (Maybe Failure) : r) ()
forall t d u (r :: EffectRow).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep t2
interval
        Sem (AtomicState (Maybe Failure) : r) b
spin
    timeoutError :: Sem (AtomicState (Maybe Failure) : r) b
timeoutError =
      Sem (AtomicState (Maybe Failure) : r) (Maybe Failure)
forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet Sem (AtomicState (Maybe Failure) : r) (Maybe Failure)
-> (Maybe Failure -> Sem (AtomicState (Maybe Failure) : r) b)
-> Sem (AtomicState (Maybe Failure) : r) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestT m b -> Sem (AtomicState (Maybe Failure) : r) b
forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH (TestT m b -> Sem (AtomicState (Maybe Failure) : r) b)
-> (Maybe Failure -> TestT m b)
-> Maybe Failure
-> Sem (AtomicState (Maybe Failure) : r) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Just Failure
e -> Test b -> TestT m b
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest ((Either Failure b, Journal) -> Test b
forall a. (Either Failure a, Journal) -> Test a
mkTest (Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
e, Journal
forall a. Monoid a => a
mempty))
        Maybe Failure
Nothing -> Maybe Diff -> String -> TestT m b
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing String
"timed out before an assertion was made"

assertWait ::
  Monad m =>
  HasCallStack =>
  Members [Hedgehog m, Time t d, Race, Error Failure, Embed IO] r =>
  Sem r a ->
  (a -> Sem r b) ->
  Sem r b
assertWait :: forall (m :: * -> *) t d (r :: EffectRow) a b.
(Monad m, HasCallStack,
 Members
   '[Hedgehog m, Time t d, Race, Error Failure, Embed IO] r) =>
Sem r a -> (a -> Sem r b) -> Sem r b
assertWait Sem r a
acquire a -> Sem r b
test =
  (HasCallStack => Sem r b) -> Sem r b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Seconds -> MilliSeconds -> Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) t d (r :: EffectRow) t1 t2 a b.
(Monad m, HasCallStack,
 Members '[Hedgehog m, Time t d, Race, Error Failure, Embed IO] r,
 TimeUnit t1, TimeUnit t2) =>
t1 -> t2 -> Sem r a -> (a -> Sem r b) -> Sem r b
assertWaitFor (Int64 -> Seconds
Seconds Int64
3) (Int64 -> MilliSeconds
MilliSeconds Int64
100) Sem r a
acquire a -> Sem r b
test