ReinforcementProps.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Property.ReinforcementProps
  ( prop_predicate_negative_not_counted
  , prop_lazy_partial_force_concurrency
  , prop_partial_order_interleaved_duplicates
  ) where

import Test.QuickCheck
import Test.QuickCheck.Monadic (monadicIO, run, assert)
import Control.Exception (try, SomeException, evaluate)
import Control.Concurrent.Async (forConcurrently_)
import UnliftIO (withRunInIO)
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Data.List (nub)
import Test.MockCat hiding (any)
import Test.MockCat (param)

--------------------------------------------------------------------------------
-- 1. Predicate negative: failing inputs raise & are not counted
--------------------------------------------------------------------------------

prop_predicate_negative_not_counted :: Property
prop_predicate_negative_not_counted = forAll genVals $ \xs -> monadicIO $ do
  m <- run $ createMock (expect even "even" |> True)
  let f = stubFn m
  outcomes <- run $ mapM (\x -> (try (evaluate (f x)) :: IO (Either SomeException Bool))) xs
  let evens = length (filter even xs)
      successes = length [ () | (x, Right _) <- zip xs outcomes, even x ]
      oddSuccesses = [ x | (x, Right _) <- zip xs outcomes, odd x ]
      failures = length [ () | (_, Left _) <- zip xs outcomes ]
      odds = length (filter odd xs)
  -- No odd value should succeed
  assert (null oddSuccesses)
  -- Failures count equals number of odd inputs
  assert (failures == odds)
  -- Successes count equals even inputs
  assert (successes == evens)
  -- Applied count equals successes (only even)
  run $ m `shouldApplyTimesToAnything` evens
  assert True
  where
    genVals = resize 60 $ listOf (arbitrary :: Gen Int)

--------------------------------------------------------------------------------
-- 2. Lazy partial force with concurrency
--------------------------------------------------------------------------------

-- We reuse a unary typeclass mock to get laziness semantics (same pattern as LazyEvalProp).
class Monad m => ParLazyAction m where
  parLazy :: Int -> m Int

makeMock [t|ParLazyAction|]

prop_lazy_partial_force_concurrency :: Property
prop_lazy_partial_force_concurrency = forAll genPlan $ \(arg, mask) -> monadicIO $ do
  let forcedCount = length (filter id mask)
  run $ runMockT $ do
    -- expectation: arg -> arg; count only forced executions
    _parLazy (param arg |> arg) `applyTimesIs` forcedCount
    -- prepare thunks (NOT executed yet)
    let thunks = replicate (length mask) (parLazy arg)
    withRunInIO $ \runIn -> do
      forConcurrently_ (zip mask thunks) $ \(forceIt, action) ->
        if forceIt then do
          v <- runIn action
          v `seq` pure ()
        else pure () -- skip executing -> not counted
  assert True
  where
    genPlan = do
      size <- chooseInt (1,40)
      arg <- arbitrary :: Gen Int
      mask <- vectorOf size arbitrary
      pure (arg, mask)

--------------------------------------------------------------------------------
-- 3. Interleaved duplicate partial-order spec (A B A pattern)
--------------------------------------------------------------------------------

prop_partial_order_interleaved_duplicates :: Property
prop_partial_order_interleaved_duplicates = forAll genPair $ \(a,b) -> a /= b ==> monadicIO $ do
  -- Pattern a a b : [a,b] subsequence succeeds, [b,a] fails.
  m <- run $ createMock $ cases [ param a |> True
                                , param a |> True
                                , param b |> True ]
  let f = stubFn m
  run $ f a `seq` f a `seq` f b `seq` pure ()
  run $ m `shouldApplyInPartialOrder` [param a, param b]
  e <- run $ (try (m `shouldApplyInPartialOrder` [param b, param a]) :: IO (Either SomeException ()))
  case e of
    Left _  -> assert True
    Right _ -> assert False
  assert True
  where
    genPair = do
      a <- arbitrary :: Gen Int
      b <- arbitrary :: Gen Int
      pure (a,b)