{-# language NoImplicitPrelude #-}
{-# options_haddock prune #-}

-- | Test runners for polysemy-conc programs using hedgehog.
module Zeugma.Run where

import qualified Chronos
import Chronos (datetimeToTime)
import Conc (
  Critical,
  Gates,
  interpretCritical,
  interpretGates,
  interpretInterrupt,
  interpretMaskFinal,
  interpretRace,
  interpretUninterruptibleMaskFinal,
  )
import Hedgehog (TestT)
import Hedgehog.Internal.Property (Failure)
import Incipit
import Log (Severity (Crit, Debug, Trace), interpretLogStderrLevelConc)
import Polysemy.Chronos (ChronosTime, interpretTimeChronos, interpretTimeChronosConstant)
import Polysemy.Test (Hedgehog, Test, TestError (TestError), runTestAuto)
import Time (mkDatetime)

type ConcTestStack' =
  [
    Log,
    Interrupt,
    Critical,
    Gates,
    Mask,
    UninterruptibleMask,
    Race,
    Async,
    Stop Text,
    Error Text
  ]

type ConcTestStack =
  ChronosTime : ConcTestStack'

-- | The entirety of the effects handled by this module's interpreters.
type TestStack =
  ConcTestStack ++ [
    Test,
    Fail,
    Error TestError,
    Hedgehog IO,
    Error Failure,
    Embed IO,
    Resource,
    Final IO
  ]

interpretTest' ::
  Members [Error TestError, Resource, Embed IO, Final IO] r =>
  Severity ->
  InterpretersFor ConcTestStack' r
interpretTest' :: forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack' r
interpretTest' Severity
level =
  forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError Text -> TestError
TestError forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall err (r :: EffectRow) a.
Member (Error err) r =>
Sem (Stop err : r) a -> Sem r a
stopToError forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Async : r) a -> Sem r a
asyncToIOFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor Race r
interpretRace forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor UninterruptibleMask r
interpretUninterruptibleMaskFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor UninterruptibleMask r
interpretMaskFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Embed IO) r =>
InterpreterFor (Scoped_ Gate) r
interpretGates forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor Critical r
interpretCritical forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterrupt forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Members '[Resource, Async, Race, Embed IO] r =>
Maybe Severity -> InterpreterFor Log r
interpretLogStderrLevelConc (forall a. a -> Maybe a
Just Severity
level)

interpretTest ::
  Members [Error TestError, Resource, Embed IO, Final IO] r =>
  Severity ->
  InterpretersFor ConcTestStack r
interpretTest :: forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack r
interpretTest Severity
level =
  forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack' r
interpretTest' Severity
level forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Embed IO) r =>
InterpreterFor ChronosTime r
interpretTimeChronos

-- | The time at which the combinators ending in @Frozen@ run the 'ChronosTime' effect.
testTime :: Chronos.Time
testTime :: Time
testTime =
  Datetime -> Time
datetimeToTime (forall dt.
Calendar dt =>
Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> dt
mkDatetime Int64
2030 Int64
5 Int64
23 Int64
12 Int64
0 Int64
0)

interpretTestFrozen ::
  Members [Error TestError, Resource, Embed IO, Final IO] r =>
  Severity ->
  InterpretersFor ConcTestStack r
interpretTestFrozen :: forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack r
interpretTestFrozen Severity
level =
  forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack' r
interpretTest' Severity
level forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Member (Embed IO) r =>
Time -> InterpreterFor ChronosTime r
interpretTimeChronosConstant Time
testTime

-- | Run the test stack as a 'TestT' with the specified log level.
runTestLevel ::
  Severity ->
  Sem TestStack a ->
  TestT IO a
runTestLevel :: forall a. Severity -> Sem TestStack a -> TestT IO a
runTestLevel Severity
level =
  forall a.
HasCallStack =>
Sem
  '[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
    Embed IO, Resource, Final IO]
  a
-> TestT IO a
runTestAuto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack r
interpretTest Severity
level

-- | Run the test stack as a 'TestT' with the specified log level, with 'ChronosTime' frozen at 'testTime'.
runTestFrozenLevel ::
  Severity ->
  Sem TestStack a ->
  TestT IO a
runTestFrozenLevel :: forall a. Severity -> Sem TestStack a -> TestT IO a
runTestFrozenLevel Severity
level =
  forall a.
HasCallStack =>
Sem
  '[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
    Embed IO, Resource, Final IO]
  a
-> TestT IO a
runTestAuto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO, Final IO] r =>
Severity -> InterpretersFor ConcTestStack r
interpretTestFrozen Severity
level

-- | Run the test stack as a 'TestT' with a log level of 'Trace'.
runTestTrace :: Sem TestStack a -> TestT IO a
runTestTrace :: forall a. Sem TestStack a -> TestT IO a
runTestTrace =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestLevel Severity
Trace

-- | Run the test stack as a 'TestT' with a log level of 'Debug'.
runTestDebug :: Sem TestStack a -> TestT IO a
runTestDebug :: forall a. Sem TestStack a -> TestT IO a
runTestDebug =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestLevel Severity
Debug

-- | Run the test stack as a 'TestT' with a log level of 'Crit'.
runTest :: Sem TestStack a -> TestT IO a
runTest :: forall a. Sem TestStack a -> TestT IO a
runTest =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestLevel Severity
Crit

-- | Run the test stack as a 'TestT' with a log level of 'Trace' and 'ChronosTime' frozen at 'testTime'.
runTestFrozenTrace :: Sem TestStack a -> TestT IO a
runTestFrozenTrace :: forall a. Sem TestStack a -> TestT IO a
runTestFrozenTrace =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestFrozenLevel Severity
Trace

-- | Run the test stack as a 'TestT' with a log level of 'Debug' and 'ChronosTime' frozen at 'testTime'.
runTestFrozenDebug :: Sem TestStack a -> TestT IO a
runTestFrozenDebug :: forall a. Sem TestStack a -> TestT IO a
runTestFrozenDebug =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestFrozenLevel Severity
Debug

-- | Run the test stack as a 'TestT' with a log level of 'Crit' and 'ChronosTime' frozen at 'testTime'.
runTestFrozen :: Sem TestStack a -> TestT IO a
runTestFrozen :: forall a. Sem TestStack a -> TestT IO a
runTestFrozen =
  forall a. Severity -> Sem TestStack a -> TestT IO a
runTestFrozenLevel Severity
Crit