ReinforcementProps.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# OPTIONS_GHC -fno-hpc #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Property.ReinforcementProps (spec, 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 Test.MockCat hiding (any)
import Property.Generators (resetMockHistory)
import Control.Monad.IO.Class (liftIO)
import Test.Hspec (Spec, describe, it)



--------------------------------------------------------------------------------
-- 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
  let evens = length (filter even xs)
  run $ withMock $ do
    f <- mock (expect even "even" ~> True)
          `expects` called (times evens)
          
    outcomes <- liftIO $ mapM (\x -> (try (evaluate (f x)) :: IO (Either SomeException Bool))) xs
    
    {- Analysis (optional checks) -}
    liftIO $ do
      let 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
      if not (null oddSuccesses) then error "oddSuccesses not null" else pure ()
      -- Failures count equals number of odd inputs
      if failures /= odds then error "failures /= odds" else pure ()
      -- Successes count equals even inputs
      if successes /= evens then error "successes /= evens" else pure ()
  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

makeAutoLiftMock [t|ParLazyAction|]

prop_lazy_partial_force_concurrency :: Property
prop_lazy_partial_force_concurrency = forAll genPlan $ \(arg, mask) -> monadicIO $ do
  run resetMockHistory
  let forcedCount = length (filter id mask)
  run $ runMockT $ do
    -- expectation: arg -> arg; count only forced executions
    _parLazy ((param arg ~> arg))
      `expects` do
        called (times 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.
  run $ withMock $ do
      f <- mock (cases [ param a ~> True
                                    , param a ~> True
                                    , param b ~> True ])
             `expects` calledInSequence [a, b]
      liftIO $ f a `seq` f a `seq` f b `seq` pure ()

  e <- run ((try $ withMock $ do
      f <- mock (cases [ param a ~> True
                                    , param a ~> True
                                    , param b ~> True ])
             `expects` calledInSequence [b, a]
      liftIO $ f a `seq` f a `seq` f b `seq` pure ()
      ) :: 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)

spec :: Spec
spec = do
    describe "Property Reinforcement (Negative predicate / Partial force / Interleave)" $ do
      it "predicate negative not counted" $ property prop_predicate_negative_not_counted
      it "lazy partial force in concurrency counts only forced" $ property prop_lazy_partial_force_concurrency
      it "interleaved duplicate partial order semantics" $ property prop_partial_order_interleaved_duplicates