{- | Drop-in shim for "Test.Tasty.QuickCheck" that captures the source
location of each 'testProperty' definition and propagates it to the
streaming reporter.

Migration is a single-line import change:

@
-- before
import Test.Tasty.QuickCheck (testProperty)

-- after
import Convex.Tasty.QuickCheck (testProperty)
@

Call sites remain byte-for-byte identical. Re-exports everything from
"Test.Tasty.QuickCheck" except 'QC.testProperty', which is replaced by
the location-tracking shim defined here.
-}
module Convex.Tasty.QuickCheck (
  testProperty,
  module Test.Tasty.QuickCheck,
) where

import Convex.Tasty.Streaming.QCStats (
  QCStatsRecorder (..),
  recordQCStatsFromState,
 )
import Convex.Tasty.Streaming.SrcLoc (SrcLocOpt (..), withSrcLoc)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Test.QuickCheck.Property qualified as QCP
import Test.Tasty (TestName, TestTree, askOption)
import Test.Tasty.QuickCheck hiding (testProperty)
import Test.Tasty.QuickCheck qualified as QC

{- | Like 'QC.testProperty' but captures the call site as a source-location
range that the streaming ingredient will emit alongside the test.
-}
testProperty :: (HasCallStack, Testable a) => TestName -> a -> TestTree
testProperty :: forall a. (HasCallStack, Testable a) => TestName -> a -> TestTree
testProperty TestName
name a
prop =
  (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
    ( HasCallStack => TestTree -> TestTree
TestTree -> TestTree
withSrcLoc (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        let baseProp :: Property
baseProp = a -> Property
forall prop. Testable prop => prop -> Property
property a
prop
         in (SrcLocOpt -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((SrcLocOpt -> TestTree) -> TestTree)
-> (SrcLocOpt -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(SrcLocOpt Maybe SrcLocRange
mLoc) ->
              case Maybe SrcLocRange
mLoc of
                Maybe SrcLocRange
Nothing -> TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
QC.testProperty TestName
name Property
baseProp
                Just SrcLocRange
_ ->
                  (QCStatsRecorder -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((QCStatsRecorder -> TestTree) -> TestTree)
-> (QCStatsRecorder -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(QCStatsRecorder
recorder :: QCStatsRecorder) ->
                    let postTest :: Property -> Property
postTest =
                          Callback -> Property -> Property
forall prop. Testable prop => Callback -> prop -> Property
QCP.callback (Callback -> Property -> Property)
-> Callback -> Property -> Property
forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
QCP.PostTest CallbackKind
QCP.NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
_ ->
                            QCStatsRecorder -> Maybe SrcLocRange -> TestName -> State -> IO ()
recordQCStatsFromState QCStatsRecorder
recorder Maybe SrcLocRange
mLoc TestName
name State
st
                        postFinalFailure :: Property -> Property
postFinalFailure =
                          Callback -> Property -> Property
forall prop. Testable prop => Callback -> prop -> Property
QCP.callback (Callback -> Property -> Property)
-> Callback -> Property -> Property
forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
QCP.PostFinalFailure CallbackKind
QCP.NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
_ ->
                            QCStatsRecorder -> Maybe SrcLocRange -> TestName -> State -> IO ()
recordQCStatsFromState QCStatsRecorder
recorder Maybe SrcLocRange
mLoc TestName
name State
st
                        instrumented :: Property
instrumented = Property -> Property
postFinalFailure (Property -> Property
postTest Property
baseProp)
                     in TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
QC.testProperty TestName
name Property
instrumented
    )