{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test.Consensus.Util.MonadSTM.NormalForm (tests) where

import           Control.Monad.IOSim
import           GHC.Generics
import           NoThunks.Class
import           Ouroboros.Consensus.Util.MonadSTM.NormalForm (MonadSTM,
                     newSVar, updateSVar)
import           Test.Tasty
import           Test.Tasty.QuickCheck

-- Note that all of the tests here are only significant with compiler
-- optimizations turned off! These tests ensure that the invariants are
-- maintained when calling `updateMVar` on consensus' `StrictMVar` values
-- (which are created with a `NoThunks` "this should not contain any unforced
-- thunks" invariant). Because the existence of thunks (and therefore the
-- behaviour of `unsafeNoThunks`) is heavily dependent on compiler
-- optimizations, these tests will *always* pass at -O1 or higher (at least on
-- GHC 8.10 and GHC 9.2).
tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Ouroboros.Consensus.Util.MonadSTM.NormalForm"
  [ String -> [TestTree] -> TestTree
testGroup String
"updateSVar"
    [ String -> [TestTree] -> TestTree
testGroup String
"updateSVar strictness"
      [ String
-> (Fun Integer (Integer, String) -> Integer -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"IO @Integer @String"
          (forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_io @Integer @String)
      , String
-> (Fun Integer (Integer, String) -> Integer -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"IOSim @Integer @String"
          (forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_iosim @Integer @String)
      , String
-> (Fun StrictnessTestType (StrictnessTestType, String)
    -> StrictnessTestType -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"IO @StrictnessTestType @String"
          (forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_io @StrictnessTestType @String)
      , String
-> (Fun StrictnessTestType (StrictnessTestType, String)
    -> StrictnessTestType -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"IOSim @StrictnessTestType @String"
          (forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_iosim @StrictnessTestType @String)
      ]
    ]
  ]

data StrictnessTestType = StrictnessTestType !Int !Bool
  deriving stock (Int -> StrictnessTestType -> ShowS
[StrictnessTestType] -> ShowS
StrictnessTestType -> String
(Int -> StrictnessTestType -> ShowS)
-> (StrictnessTestType -> String)
-> ([StrictnessTestType] -> ShowS)
-> Show StrictnessTestType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrictnessTestType -> ShowS
showsPrec :: Int -> StrictnessTestType -> ShowS
$cshow :: StrictnessTestType -> String
show :: StrictnessTestType -> String
$cshowList :: [StrictnessTestType] -> ShowS
showList :: [StrictnessTestType] -> ShowS
Show, (forall x. StrictnessTestType -> Rep StrictnessTestType x)
-> (forall x. Rep StrictnessTestType x -> StrictnessTestType)
-> Generic StrictnessTestType
forall x. Rep StrictnessTestType x -> StrictnessTestType
forall x. StrictnessTestType -> Rep StrictnessTestType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StrictnessTestType -> Rep StrictnessTestType x
from :: forall x. StrictnessTestType -> Rep StrictnessTestType x
$cto :: forall x. Rep StrictnessTestType x -> StrictnessTestType
to :: forall x. Rep StrictnessTestType x -> StrictnessTestType
Generic)
  deriving anyclass ((forall b. (StrictnessTestType -> b) -> StrictnessTestType :-> b)
-> Function StrictnessTestType
forall b. (StrictnessTestType -> b) -> StrictnessTestType :-> b
forall a. (forall b. (a -> b) -> a :-> b) -> Function a
$cfunction :: forall b. (StrictnessTestType -> b) -> StrictnessTestType :-> b
function :: forall b. (StrictnessTestType -> b) -> StrictnessTestType :-> b
Function, Context -> StrictnessTestType -> IO (Maybe ThunkInfo)
Proxy StrictnessTestType -> String
(Context -> StrictnessTestType -> IO (Maybe ThunkInfo))
-> (Context -> StrictnessTestType -> IO (Maybe ThunkInfo))
-> (Proxy StrictnessTestType -> String)
-> NoThunks StrictnessTestType
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> StrictnessTestType -> IO (Maybe ThunkInfo)
noThunks :: Context -> StrictnessTestType -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StrictnessTestType -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StrictnessTestType -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy StrictnessTestType -> String
showTypeOf :: Proxy StrictnessTestType -> String
NoThunks, (forall b. StrictnessTestType -> Gen b -> Gen b)
-> CoArbitrary StrictnessTestType
forall b. StrictnessTestType -> Gen b -> Gen b
forall a. (forall b. a -> Gen b -> Gen b) -> CoArbitrary a
$ccoarbitrary :: forall b. StrictnessTestType -> Gen b -> Gen b
coarbitrary :: forall b. StrictnessTestType -> Gen b -> Gen b
CoArbitrary)

instance Arbitrary StrictnessTestType where
  arbitrary :: Gen StrictnessTestType
arbitrary = Int -> Bool -> StrictnessTestType
StrictnessTestType (Int -> Bool -> StrictnessTestType)
-> Gen Int -> Gen (Bool -> StrictnessTestType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen (Bool -> StrictnessTestType)
-> Gen Bool -> Gen StrictnessTestType
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: StrictnessTestType -> [StrictnessTestType]
shrink (StrictnessTestType Int
a Bool
b) = do
    Int -> Bool -> StrictnessTestType
StrictnessTestType (Int -> Bool -> StrictnessTestType)
-> [Int] -> [Bool -> StrictnessTestType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
a [Bool -> StrictnessTestType] -> [Bool] -> [StrictnessTestType]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> [Bool]
forall a. Arbitrary a => a -> [a]
shrink Bool
b

prop_update_svar_strictness_io
  :: forall a b. NoThunks a
  => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_io :: forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_io Fun a (a, b)
f a
a =
  IO () -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO () -> Property) -> IO () -> Property
forall a b. (a -> b) -> a -> b
$ Fun a (a, b) -> a -> IO ()
forall (m :: * -> *) a b.
(MonadSTM m, NoThunks a) =>
Fun a (a, b) -> a -> m ()
updateSVarTest Fun a (a, b)
f a
a

prop_update_svar_strictness_iosim
  :: forall a b. NoThunks a
  => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_iosim :: forall a b. NoThunks a => Fun a (a, b) -> a -> Property
prop_update_svar_strictness_iosim Fun a (a, b)
f a
a =
  () -> Property
forall prop. Testable prop => prop -> Property
property (() -> Property) -> () -> Property
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> ()
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s ()) -> ()) -> (forall s. IOSim s ()) -> ()
forall a b. (a -> b) -> a -> b
$ Fun a (a, b) -> a -> IOSim s ()
forall (m :: * -> *) a b.
(MonadSTM m, NoThunks a) =>
Fun a (a, b) -> a -> m ()
updateSVarTest Fun a (a, b)
f a
a

updateSVarTest :: (MonadSTM m, NoThunks a) => Fun a (a, b) -> a -> m ()
updateSVarTest :: forall (m :: * -> *) a b.
(MonadSTM m, NoThunks a) =>
Fun a (a, b) -> a -> m ()
updateSVarTest (Fun (a :-> (a, b), (a, b), Shrunk)
_ a -> (a, b)
f) a
a = do
  StrictSVar m a
mvar <- a -> m (StrictSVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictSVar m a)
newSVar a
a
  b
_ <- StrictSVar m a -> (a -> (a, b)) -> m b
forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> (a -> (a, b)) -> m b
updateSVar StrictSVar m a
mvar a -> (a, b)
f
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()