{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Skeletest.Prop.Internal (
  Property,
  PropertyM,
  runProperty,

  -- * Test
  prop,
  forAll,
  discard,

  -- * Configuring properties
  setDiscardLimit,
  setShrinkLimit,
  setShrinkRetries,
  setConfidence,
  setVerifiedTermination,
  setTestLimit,

  -- * Coverage
  classify,
  cover,
  label,
  collect,

  -- * Assertions
  isoWith,
  (===),
  Fun (..),
  IsoChecker (..),

  -- * Plugin
  propPlugin,
) where

import Control.Monad (ap)
import Control.Monad.Catch qualified as MonadCatch
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class qualified as Trans
import Control.Monad.Trans.Reader qualified as Trans
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe (catMaybes)
import Data.Text qualified as Text
import GHC.Stack qualified as GHC
import Hedgehog qualified
import Hedgehog.Internal.Property qualified as Hedgehog
import Hedgehog.Internal.Report qualified as Hedgehog hiding (defaultConfig)
import Hedgehog.Internal.Runner qualified as Hedgehog
import Hedgehog.Internal.Seed qualified as Hedgehog.Seed
import Hedgehog.Internal.Source qualified as Hedgehog
import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)
import Skeletest.Internal.CLI qualified as CLI
import Skeletest.Internal.Error (skeletestError)
import Skeletest.Internal.Predicate (Predicate (..), PredicateFuncResult (..), ShowFailCtx (..), render)
import Skeletest.Internal.Spec.Tree (Spec)
import Skeletest.Internal.Spec.Tree qualified as Spec
import Skeletest.Internal.TestInfo (TestInfo, getTestInfo)
import Skeletest.Internal.TestRunner (
  AssertionFail (..),
  FailContext,
  TestResult (..),
  TestResultMessage (..),
  Testable (..),
  testResultFromAssertionFail,
  testResultFromErrorWith,
  testResultPass,
 )
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Internal.Utils.Text (indent, parens)
import Skeletest.Plugin (Plugin (..), defaultPlugin)
import Skeletest.Prop.Gen (Gen)
import Text.Read (readEither, readMaybe)
import UnliftIO.Exception (SomeException, fromException, toException)
import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)

#if !MIN_VERSION_base(4, 20, 0)
import Data.Foldable (foldl')
#endif

-- | A property to run, with optional configuration settings specified up front.
--
-- Settings should be specified before any other 'Property' calls; any settings
-- specified afterwards are ignored.
type Property = PropertyM ()

data PropertyM a
  = PropertyPure [PropertyConfig] a
  | PropertyIO [PropertyConfig] (PropertyIO a)

type FailureRef = IORef (Maybe SomeException)
type PropertyIO a = Trans.ReaderT FailureRef (Hedgehog.PropertyT IO) a

instance Functor PropertyM where
  fmap :: forall a b. (a -> b) -> PropertyM a -> PropertyM b
fmap a -> b
f = \case
    PropertyPure [PropertyConfig]
cfg a
a -> [PropertyConfig] -> b -> PropertyM b
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure [PropertyConfig]
cfg (a -> b
f a
a)
    PropertyIO [PropertyConfig]
cfg PropertyIO a
m -> [PropertyConfig] -> PropertyIO b -> PropertyM b
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [PropertyConfig]
cfg (a -> b
f (a -> b) -> PropertyIO a -> PropertyIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PropertyIO a
m)
instance Applicative PropertyM where
  pure :: forall a. a -> PropertyM a
pure = [PropertyConfig] -> a -> PropertyM a
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure []
  <*> :: forall a b. PropertyM (a -> b) -> PropertyM a -> PropertyM b
(<*>) = PropertyM (a -> b) -> PropertyM a -> PropertyM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad PropertyM where
  PropertyPure [PropertyConfig]
cfg1 a
a >>= :: forall a b. PropertyM a -> (a -> PropertyM b) -> PropertyM b
>>= a -> PropertyM b
k =
    case a -> PropertyM b
k a
a of
      PropertyPure [PropertyConfig]
cfg2 b
b -> [PropertyConfig] -> b -> PropertyM b
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure ([PropertyConfig]
cfg1 [PropertyConfig] -> [PropertyConfig] -> [PropertyConfig]
forall a. Semigroup a => a -> a -> a
<> [PropertyConfig]
cfg2) b
b
      PropertyIO [PropertyConfig]
cfg2 PropertyIO b
m -> [PropertyConfig] -> PropertyIO b -> PropertyM b
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO ([PropertyConfig]
cfg1 [PropertyConfig] -> [PropertyConfig] -> [PropertyConfig]
forall a. Semigroup a => a -> a -> a
<> [PropertyConfig]
cfg2) PropertyIO b
m
  PropertyIO [PropertyConfig]
cfg1 PropertyIO a
fa >>= a -> PropertyM b
k =
    [PropertyConfig] -> PropertyIO b -> PropertyM b
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [PropertyConfig]
cfg1 (PropertyIO b -> PropertyM b) -> PropertyIO b -> PropertyM b
forall a b. (a -> b) -> a -> b
$ do
      a
a <- PropertyIO a
fa
      case a -> PropertyM b
k a
a of
        PropertyPure [] b
b -> b -> PropertyIO b
forall a. a -> ReaderT FailureRef (PropertyT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
        PropertyPure [PropertyConfig]
_ b
_ -> Text -> PropertyIO b
forall (m :: * -> *) a. MonadIO m => Text -> m a
skeletestError Text
"Property configuration function must be done before any forAll or IO actions"
        PropertyIO [PropertyConfig]
_ PropertyIO b
mb -> PropertyIO b
mb
instance MonadIO PropertyM where
  liftIO :: forall a. IO a -> PropertyM a
liftIO = [PropertyConfig] -> PropertyIO a -> PropertyM a
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [] (PropertyIO a -> PropertyM a)
-> (IO a -> PropertyIO a) -> IO a -> PropertyM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> PropertyIO a
forall a. IO a -> ReaderT FailureRef (PropertyT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadFail PropertyM where
  fail :: forall a. String -> PropertyM a
fail = IO a -> PropertyM a
forall a. IO a -> PropertyM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> PropertyM a) -> (String -> IO a) -> String -> PropertyM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance Testable PropertyM where
  runTestable :: PropertyM () -> IO TestResult
runTestable = PropertyM () -> IO TestResult
runProperty
  context :: forall a. String -> PropertyM a -> PropertyM a
context String
msg PropertyM a
m = [PropertyConfig] -> PropertyIO () -> PropertyM ()
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [] (String -> PropertyIO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
Hedgehog.annotate String
msg) PropertyM () -> PropertyM a -> PropertyM a
forall a b. PropertyM a -> PropertyM b -> PropertyM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PropertyM a
m
  throwFailure :: forall a. AssertionFail -> PropertyM a
throwFailure AssertionFail
e = [PropertyConfig] -> PropertyIO a -> PropertyM a
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [] (PropertyIO a -> PropertyM a) -> PropertyIO a -> PropertyM a
forall a b. (a -> b) -> a -> b
$ do
    FailureRef
failureRef <- ReaderT FailureRef (PropertyT IO) FailureRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
    FailureRef -> Maybe SomeException -> PropertyIO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef FailureRef
failureRef (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ AssertionFail -> SomeException
forall e. Exception e => e -> SomeException
toException AssertionFail
e)
    PropertyT IO a -> PropertyIO a
forall (m :: * -> *) a. Monad m => m a -> ReaderT FailureRef m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift PropertyT IO a
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
Hedgehog.failure

propConfig :: PropertyConfig -> Property
propConfig :: PropertyConfig -> PropertyM ()
propConfig PropertyConfig
cfg = [PropertyConfig] -> () -> PropertyM ()
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure [PropertyConfig
cfg] ()

propM :: Hedgehog.PropertyT IO a -> PropertyM a
propM :: forall a. PropertyT IO a -> PropertyM a
propM = [PropertyConfig] -> PropertyIO a -> PropertyM a
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [] (PropertyIO a -> PropertyM a)
-> (PropertyT IO a -> PropertyIO a)
-> PropertyT IO a
-> PropertyM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyT IO a -> PropertyIO a
forall (m :: * -> *) a. Monad m => m a -> ReaderT FailureRef m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift

data PropertyConfig
  = DiscardLimit Int
  | ShrinkLimit Int
  | ShrinkRetries Int
  | SetConfidence Int
  | SetVerifiedTermination
  | SetTestLimit Int

resolveConfig :: [PropertyConfig] -> Hedgehog.PropertyConfig
resolveConfig :: [PropertyConfig] -> PropertyConfig
resolveConfig = (PropertyConfig -> PropertyConfig -> PropertyConfig)
-> PropertyConfig -> [PropertyConfig] -> PropertyConfig
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PropertyConfig -> PropertyConfig -> PropertyConfig
go PropertyConfig
defaultConfig
 where
  defaultConfig :: PropertyConfig
defaultConfig =
    Hedgehog.PropertyConfig
      { propertyDiscardLimit :: DiscardLimit
propertyDiscardLimit = DiscardLimit
100
      , propertyShrinkLimit :: ShrinkLimit
propertyShrinkLimit = ShrinkLimit
1000
      , propertyShrinkRetries :: ShrinkRetries
propertyShrinkRetries = ShrinkRetries
0
      , propertyTerminationCriteria :: TerminationCriteria
propertyTerminationCriteria = TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination TestLimit
100
      , propertySkip :: Maybe Skip
propertySkip = Maybe Skip
forall a. Maybe a
Nothing
      }

  go :: PropertyConfig -> PropertyConfig -> PropertyConfig
go PropertyConfig
cfg = \case
    DiscardLimit Int
x -> PropertyConfig
cfg{Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit x}
    ShrinkLimit Int
x -> PropertyConfig
cfg{Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit x}
    ShrinkRetries Int
x -> PropertyConfig
cfg{Hedgehog.propertyShrinkRetries = Hedgehog.ShrinkRetries x}
    SetConfidence Int
x ->
      PropertyConfig
cfg
        { Hedgehog.propertyTerminationCriteria =
            case Hedgehog.propertyTerminationCriteria cfg of
              Hedgehog.NoEarlyTermination Confidence
_ TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
              Hedgehog.NoConfidenceTermination TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
              Hedgehog.EarlyTermination Confidence
_ TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
        }
    PropertyConfig
SetVerifiedTermination ->
      PropertyConfig
cfg
        { Hedgehog.propertyTerminationCriteria =
            case Hedgehog.propertyTerminationCriteria cfg of
              Hedgehog.NoEarlyTermination Confidence
c TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c TestLimit
tests
              Hedgehog.NoConfidenceTermination TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
Hedgehog.defaultConfidence TestLimit
tests
              Hedgehog.EarlyTermination Confidence
c TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c TestLimit
tests
        }
    SetTestLimit Int
x ->
      PropertyConfig
cfg
        { Hedgehog.propertyTerminationCriteria =
            case Hedgehog.propertyTerminationCriteria cfg of
              Hedgehog.NoEarlyTermination Confidence
c TestLimit
_ -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination Confidence
c (Int -> TestLimit
Hedgehog.TestLimit Int
x)
              Hedgehog.NoConfidenceTermination TestLimit
_ -> TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination (Int -> TestLimit
Hedgehog.TestLimit Int
x)
              Hedgehog.EarlyTermination Confidence
c TestLimit
_ -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c (Int -> TestLimit
Hedgehog.TestLimit Int
x)
        }

runProperty :: Property -> IO TestResult
runProperty :: PropertyM () -> IO TestResult
runProperty = \case
  PropertyPure [PropertyConfig]
cfg () -> PropertyM () -> IO TestResult
runProperty (PropertyM () -> IO TestResult) -> PropertyM () -> IO TestResult
forall a b. (a -> b) -> a -> b
$ [PropertyConfig] -> PropertyIO () -> PropertyM ()
forall a. [PropertyConfig] -> PropertyIO a -> PropertyM a
PropertyIO [PropertyConfig]
cfg (() -> PropertyIO ()
forall a. a -> ReaderT FailureRef (PropertyT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  PropertyIO [PropertyConfig]
cfg PropertyIO ()
m -> do
    (Seed
seed, [PropertyConfig]
extraConfig) <- IO (Seed, [PropertyConfig])
loadPropFlags
    let cfg' :: PropertyConfig
cfg' = [PropertyConfig] -> PropertyConfig
resolveConfig ([PropertyConfig] -> PropertyConfig)
-> [PropertyConfig] -> PropertyConfig
forall a b. (a -> b) -> a -> b
$ [PropertyConfig]
cfg [PropertyConfig] -> [PropertyConfig] -> [PropertyConfig]
forall a. Semigroup a => a -> a -> a
<> [PropertyConfig]
extraConfig
    (PropertyT IO ()
prop_, IO (Maybe SomeException)
getException) <- PropertyIO () -> IO (PropertyT IO (), IO (Maybe SomeException))
forall a.
PropertyIO a -> IO (PropertyT IO a, IO (Maybe SomeException))
fromPropertyIO PropertyIO ()
m
    Report Result
report <- PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
Hedgehog.checkReport PropertyConfig
cfg' Size
size Seed
seed PropertyT IO ()
prop_ Report Progress -> IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
reportProgress

    TestInfo
testInfo <- IO TestInfo
forall (m :: * -> *). (MonadIO m, HasCallStack) => m TestInfo
getTestInfo
    case Report Result -> Result
forall a. Report a -> a
Hedgehog.reportStatus Report Result
report of
      Result
Hedgehog.OK -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult -> IO TestResult) -> TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ Report Result -> TestResult
toTestResultPass Report Result
report
      Result
Hedgehog.GaveUp -> AssertionFail -> IO TestResult
testResultFromAssertionFail (AssertionFail -> IO TestResult) -> AssertionFail -> IO TestResult
forall a b. (a -> b) -> a -> b
$ TestInfo -> Report Result -> AssertionFail
fromGaveUpFailure TestInfo
testInfo Report Result
report
      Hedgehog.Failed FailureReport
failureReport -> do
        -- Get an 'Either AssertionFail SomeException'
        let resolveException :: Maybe SomeException -> Either AssertionFail SomeException
resolveException = \case
              Maybe SomeException
Nothing -> AssertionFail -> Either AssertionFail SomeException
forall a b. a -> Either a b
Left (AssertionFail -> Either AssertionFail SomeException)
-> AssertionFail -> Either AssertionFail SomeException
forall a b. (a -> b) -> a -> b
$ TestInfo -> FailureReport -> AssertionFail
fromHedgehogFailure TestInfo
testInfo FailureReport
failureReport
              Just SomeException
e -> Either AssertionFail SomeException
-> (AssertionFail -> Either AssertionFail SomeException)
-> Maybe AssertionFail
-> Either AssertionFail SomeException
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SomeException -> Either AssertionFail SomeException
forall a b. b -> Either a b
Right SomeException
e) AssertionFail -> Either AssertionFail SomeException
forall a b. a -> Either a b
Left (Maybe AssertionFail -> Either AssertionFail SomeException)
-> Maybe AssertionFail -> Either AssertionFail SomeException
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe AssertionFail
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
        Either AssertionFail SomeException
exc <- Maybe SomeException -> Either AssertionFail SomeException
resolveException (Maybe SomeException -> Either AssertionFail SomeException)
-> IO (Maybe SomeException)
-> IO (Either AssertionFail SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe SomeException)
getException

        -- Add hedgehog-specific context to the failure
        let info :: FailContext
info = Report Result -> FailureReport -> FailContext
getExtraTestContext Report Result
report FailureReport
failureReport
        case Either AssertionFail SomeException
exc of
          Left AssertionFail
failure ->
            AssertionFail -> IO TestResult
testResultFromAssertionFail
              -- N.B. testFailContext is reversed!
              AssertionFail
failure{testFailContext = failure.testFailContext <> reverse info}
          Right SomeException
err -> do
            let addInfo :: Text -> Text
addInfo Text
msg = Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> FailContext -> Text
Text.intercalate Text
"\n" FailContext
info
            (Text -> Text) -> SomeException -> IO TestResult
testResultFromErrorWith Text -> Text
addInfo SomeException
err
 where
  size :: Size
size = Size
0
  reportProgress :: p -> f ()
reportProgress p
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig])
loadPropFlags :: IO (Seed, [PropertyConfig])
loadPropFlags = do
  PropSeedFlag Maybe Seed
mSeed <- IO PropSeedFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
  Seed
seed <- IO Seed -> (Seed -> IO Seed) -> Maybe Seed -> IO Seed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Hedgehog.Seed.random Seed -> IO Seed
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Seed
mSeed

  PropLimitFlag Maybe Int
mLimit <- IO PropLimitFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag

  let extraConfig :: [Maybe PropertyConfig]
extraConfig =
        [ Int -> PropertyConfig
SetTestLimit (Int -> PropertyConfig) -> Maybe Int -> Maybe PropertyConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
mLimit
        ]
  (Seed, [PropertyConfig]) -> IO (Seed, [PropertyConfig])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seed
seed, [Maybe PropertyConfig] -> [PropertyConfig]
forall a. [Maybe a] -> [a]
catMaybes [Maybe PropertyConfig]
extraConfig)

fromPropertyIO :: PropertyIO a -> IO (Hedgehog.PropertyT IO a, IO (Maybe SomeException))
fromPropertyIO :: forall a.
PropertyIO a -> IO (PropertyT IO a, IO (Maybe SomeException))
fromPropertyIO PropertyIO a
m = do
  FailureRef
failureRef <- Maybe SomeException -> IO FailureRef
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe SomeException
forall a. Maybe a
Nothing
  let run :: PropertyT IO a
run =
        (PropertyIO a -> FailureRef -> PropertyT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`Trans.runReaderT` FailureRef
failureRef)
          (PropertyIO a -> PropertyT IO a)
-> (PropertyIO a -> PropertyIO a) -> PropertyIO a -> PropertyT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PropertyIO a -> (SomeException -> PropertyIO a) -> PropertyIO a
forall e a.
(HasCallStack, Exception e) =>
ReaderT FailureRef (PropertyT IO) a
-> (e -> ReaderT FailureRef (PropertyT IO) a)
-> ReaderT FailureRef (PropertyT IO) a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`MonadCatch.catch` \SomeException
e -> FailureRef -> Maybe SomeException -> PropertyIO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef FailureRef
failureRef (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e) PropertyIO () -> PropertyIO a -> PropertyIO a
forall a b.
ReaderT FailureRef (PropertyT IO) a
-> ReaderT FailureRef (PropertyT IO) b
-> ReaderT FailureRef (PropertyT IO) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PropertyIO a
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
Hedgehog.failure)
          (PropertyIO a -> PropertyT IO a) -> PropertyIO a -> PropertyT IO a
forall a b. (a -> b) -> a -> b
$ PropertyIO a
m
      getException :: IO (Maybe SomeException)
getException = FailureRef -> IO (Maybe SomeException)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef FailureRef
failureRef
  (PropertyT IO a, IO (Maybe SomeException))
-> IO (PropertyT IO a, IO (Maybe SomeException))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PropertyT IO a
run, IO (Maybe SomeException)
getException)

toTestResultPass :: Hedgehog.Report Hedgehog.Result -> TestResult
toTestResultPass :: Report Result -> TestResult
toTestResultPass Report Result
report =
  TestResult
testResultPass
    { message =
        TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $
          [ [show testCount <> " tests, " <> show discards <> " discards"]
          , renderCoverage report.reportCoverage testCount
          ]
    }
 where
  Hedgehog.TestCount Int
testCount = Report Result
report.reportTests
  Hedgehog.DiscardCount Int
discards = Report Result
report.reportDiscards

fromGaveUpFailure :: TestInfo -> Hedgehog.Report Hedgehog.Result -> AssertionFail
fromGaveUpFailure :: TestInfo -> Report Result -> AssertionFail
fromGaveUpFailure TestInfo
testInfo Report Result
report =
  AssertionFail
    { TestInfo
testInfo :: TestInfo
testInfo :: TestInfo
testInfo
    , testFailMessage :: Text
testFailMessage =
        String -> Text
Text.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$
          [ String
"Gave up after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
discards String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" discards."
          , String
"Passed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
testCount String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" tests."
          ]
    , testFailContext :: FailContext
testFailContext = []
    , callStack :: CallStack
callStack = [(String, SrcLoc)] -> CallStack
GHC.fromCallSiteList []
    }
 where
  Hedgehog.TestCount Int
testCount = Report Result
report.reportTests
  Hedgehog.DiscardCount Int
discards = Report Result
report.reportDiscards

-- | Convert a Hedgehog failure to AssertionFail.
--
-- Only happens if one of Hedgehog's functions failed using the failure mode in
-- PropertyT. All IO exceptions are handled in 'fromPropertyIO'.
fromHedgehogFailure :: TestInfo -> Hedgehog.FailureReport -> AssertionFail
fromHedgehogFailure :: TestInfo -> FailureReport -> AssertionFail
fromHedgehogFailure TestInfo
testInfo Hedgehog.FailureReport{String
[String]
[FailedAnnotation]
Maybe Span
Maybe (Coverage CoverCount)
Maybe Diff
ShrinkPath
ShrinkCount
failureShrinks :: ShrinkCount
failureShrinkPath :: ShrinkPath
failureCoverage :: Maybe (Coverage CoverCount)
failureAnnotations :: [FailedAnnotation]
failureLocation :: Maybe Span
failureMessage :: String
failureDiff :: Maybe Diff
failureFootnotes :: [String]
failureFootnotes :: FailureReport -> [String]
failureDiff :: FailureReport -> Maybe Diff
failureMessage :: FailureReport -> String
failureLocation :: FailureReport -> Maybe Span
failureAnnotations :: FailureReport -> [FailedAnnotation]
failureCoverage :: FailureReport -> Maybe (Coverage CoverCount)
failureShrinkPath :: FailureReport -> ShrinkPath
failureShrinks :: FailureReport -> ShrinkCount
..} =
  AssertionFail
    { TestInfo
testInfo :: TestInfo
testInfo :: TestInfo
testInfo
    , testFailMessage :: Text
testFailMessage = String -> Text
Text.pack String
failureMessage
    , testFailContext :: FailContext
testFailContext = []
    , callStack :: CallStack
callStack = Maybe Span -> CallStack
toCallStack Maybe Span
failureLocation
    }
 where
  toCallStack :: Maybe Span -> CallStack
toCallStack Maybe Span
mSpan =
    [(String, SrcLoc)] -> CallStack
GHC.fromCallSiteList ([(String, SrcLoc)] -> CallStack)
-> [(String, SrcLoc)] -> CallStack
forall a b. (a -> b) -> a -> b
$
      case Maybe Span
mSpan of
        Maybe Span
Nothing -> []
        Just Hedgehog.Span{String
ColumnNo
LineNo
spanFile :: String
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
spanEndColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanStartLine :: Span -> LineNo
spanFile :: Span -> String
..} ->
          let loc :: SrcLoc
loc =
                GHC.SrcLoc
                  { srcLocPackage :: String
srcLocPackage = String
""
                  , srcLocModule :: String
srcLocModule = String
""
                  , srcLocFile :: String
srcLocFile = String
spanFile
                  , srcLocStartLine :: Int
srcLocStartLine = LineNo -> Int
Hedgehog.unLineNo LineNo
spanStartLine
                  , srcLocStartCol :: Int
srcLocStartCol = ColumnNo -> Int
Hedgehog.unColumnNo ColumnNo
spanStartColumn
                  , srcLocEndLine :: Int
srcLocEndLine = LineNo -> Int
Hedgehog.unLineNo LineNo
spanEndLine
                  , srcLocEndCol :: Int
srcLocEndCol = ColumnNo -> Int
Hedgehog.unColumnNo ColumnNo
spanEndColumn
                  }
           in [(String
"<unknown>", SrcLoc
loc)]

getExtraTestContext :: Hedgehog.Report Hedgehog.Result -> Hedgehog.FailureReport -> FailContext
getExtraTestContext :: Report Result -> FailureReport -> FailContext
getExtraTestContext Report Result
report Hedgehog.FailureReport{String
[String]
[FailedAnnotation]
Maybe Span
Maybe (Coverage CoverCount)
Maybe Diff
ShrinkPath
ShrinkCount
failureFootnotes :: FailureReport -> [String]
failureDiff :: FailureReport -> Maybe Diff
failureMessage :: FailureReport -> String
failureLocation :: FailureReport -> Maybe Span
failureAnnotations :: FailureReport -> [FailedAnnotation]
failureCoverage :: FailureReport -> Maybe (Coverage CoverCount)
failureShrinkPath :: FailureReport -> ShrinkPath
failureShrinks :: FailureReport -> ShrinkCount
failureShrinks :: ShrinkCount
failureShrinkPath :: ShrinkPath
failureCoverage :: Maybe (Coverage CoverCount)
failureAnnotations :: [FailedAnnotation]
failureLocation :: Maybe Span
failureMessage :: String
failureDiff :: Maybe Diff
failureFootnotes :: [String]
..} =
  (String -> Text) -> [String] -> FailContext
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack ([String] -> FailContext)
-> ([[String]] -> [String]) -> [[String]] -> FailContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
concatSections ([[String]] -> FailContext) -> [[String]] -> FailContext
forall a b. (a -> b) -> a -> b
$
    [
      [ String
"Failed after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
testCount String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" tests."
      , String
"Rerun with --seed=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
seed String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to reproduce."
      ]
    , [ let loc :: String
loc =
              case Maybe Span
failedSpan of
                Just Hedgehog.Span{String
ColumnNo
LineNo
spanEndColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanStartLine :: Span -> LineNo
spanFile :: Span -> String
spanFile :: String
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
..} ->
                  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                    [ String
spanFile
                    , Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (LineNo -> Int) -> LineNo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineNo -> Int
Hedgehog.unLineNo (LineNo -> String) -> LineNo -> String
forall a b. (a -> b) -> a -> b
$ LineNo
spanStartLine
                    , Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (ColumnNo -> Int) -> ColumnNo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnNo -> Int
Hedgehog.unColumnNo (ColumnNo -> String) -> ColumnNo -> String
forall a b. (a -> b) -> a -> b
$ ColumnNo
spanStartColumn
                    ]
                Maybe Span
Nothing -> String
"<unknown loc>"
         in String
loc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ==> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
failedValue
      | Hedgehog.FailedAnnotation{String
Maybe Span
failedSpan :: Maybe Span
failedValue :: String
failedValue :: FailedAnnotation -> String
failedSpan :: FailedAnnotation -> Maybe Span
..} <- [FailedAnnotation]
failureAnnotations
      ]
    ]
 where
  Hedgehog.TestCount Int
testCount = Report Result
report.reportTests
  seed :: String
seed =
    let Hedgehog.Seed Word64
value Word64
gamma = Report Result
report.reportSeed
     in Word64 -> String
forall a. Show a => a -> String
show Word64
value String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
gamma
  concatSections :: [[String]] -> [String]
concatSections = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([[String]] -> [[String]]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
List.intersperse [String
""] ([[String]] -> [[String]])
-> ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> Bool) -> [[String]] -> [[String]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

renderCoverage :: Hedgehog.Coverage Hedgehog.CoverCount -> Int -> [String]
renderCoverage :: Coverage CoverCount -> Int -> [String]
renderCoverage (Hedgehog.Coverage Map LabelName (Label CoverCount)
coverage) Int
testCount =
  let columns :: [(String, String, String)]
columns =
        [ (String
name, String
percentStr, String
percentBar)
        | Hedgehog.MkLabel{Maybe Span
LabelName
CoverPercentage
CoverCount
labelName :: LabelName
labelLocation :: Maybe Span
labelMinimum :: CoverPercentage
labelAnnotation :: CoverCount
labelAnnotation :: forall a. Label a -> a
labelMinimum :: forall a. Label a -> CoverPercentage
labelLocation :: forall a. Label a -> Maybe Span
labelName :: forall a. Label a -> LabelName
..} <- (Label CoverCount -> Maybe Span)
-> [Label CoverCount] -> [Label CoverCount]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Label CoverCount -> Maybe Span
forall a. Label a -> Maybe Span
Hedgehog.labelLocation ([Label CoverCount] -> [Label CoverCount])
-> [Label CoverCount] -> [Label CoverCount]
forall a b. (a -> b) -> a -> b
$ Map LabelName (Label CoverCount) -> [Label CoverCount]
forall k a. Map k a -> [a]
Map.elems Map LabelName (Label CoverCount)
coverage
        , let
            Hedgehog.LabelName String
name = LabelName
labelName
            Hedgehog.CoverCount Int
count = CoverCount
labelAnnotation
            percent :: Int
percent = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
testCount Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
100 :: Double)
            percentStr :: String
percentStr = Int -> String
forall a. Show a => a -> String
show Int
percent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"%"
            percentBar :: String
percentBar = Int -> String
renderPercentBar Int
percent
        ]
      (Int
maxNameLen, Int
maxPercentLen) =
        ((String, String, String) -> (Int, Int) -> (Int, Int))
-> (Int, Int) -> [(String, String, String)] -> (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          ( \(String
name, String
percent, String
_) (Int
nameAcc, Int
percentAcc) ->
              (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Int
nameAcc, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
percent) Int
percentAcc)
          )
          (Int
0, Int
0)
          [(String, String, String)]
columns
   in [ Int -> String -> String
rjust Int
maxNameLen String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
rjust Int
maxPercentLen String
percentStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
percentBar
      | (String
name, String
percentStr, String
percentBar) <- [(String, String, String)]
columns
      ]
 where
  rjust :: Int -> String -> String
rjust Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
  renderPercentBar :: Int -> String
renderPercentBar Int
percent =
    -- render percentage bar 20 characters wide
    let (Int
n, Int
r) = Int
percent Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
     in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'█'
          , case Int
r of
              Int
0 -> String
""
              Int
1 -> String
"▏"
              Int
2 -> String
"▍"
              Int
3 -> String
"▌"
              Int
4 -> String
"▊"
              Int
_ -> String
"" -- unreachable
          , Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
1)) Char
'·'
          ]

{----- Test -----}

-- | Define a property test.
--
-- @
-- describe \"User\" $ do
--   prop "decode . encode === Just" $ do
--     let genUser = ...
--     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser
-- @
prop :: String -> Property -> Spec
prop :: String -> PropertyM () -> Spec
prop = String -> PropertyM () -> Spec
forall (m :: * -> *). Testable m => String -> m () -> Spec
Spec.test

forAll :: (GHC.HasCallStack, Show a) => Hedgehog.Gen a -> PropertyM a
forAll :: forall a. (HasCallStack, Show a) => Gen a -> PropertyM a
forAll Gen a
gen = (HasCallStack => PropertyM a) -> PropertyM a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM a) -> PropertyM a)
-> (HasCallStack => PropertyM a) -> PropertyM a
forall a b. (a -> b) -> a -> b
$ PropertyT IO a -> PropertyM a
forall a. PropertyT IO a -> PropertyM a
propM (Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
Hedgehog.forAll Gen a
gen)

discard :: PropertyM a
discard :: forall a. PropertyM a
discard = PropertyT IO a -> PropertyM a
forall a. PropertyT IO a -> PropertyM a
propM PropertyT IO a
forall (m :: * -> *) a. Monad m => PropertyT m a
Hedgehog.discard

{----- Configuring properties -----}

setDiscardLimit :: Int -> Property
setDiscardLimit :: Int -> PropertyM ()
setDiscardLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
DiscardLimit

setShrinkLimit :: Int -> Property
setShrinkLimit :: Int -> PropertyM ()
setShrinkLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
ShrinkLimit

setShrinkRetries :: Int -> Property
setShrinkRetries :: Int -> PropertyM ()
setShrinkRetries = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
ShrinkRetries

setConfidence :: Int -> Property
setConfidence :: Int -> PropertyM ()
setConfidence = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
SetConfidence

setVerifiedTermination :: Property
setVerifiedTermination :: PropertyM ()
setVerifiedTermination = PropertyConfig -> PropertyM ()
propConfig PropertyConfig
SetVerifiedTermination

setTestLimit :: Int -> Property
setTestLimit :: Int -> PropertyM ()
setTestLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
SetTestLimit

{----- Coverage -----}

-- | Record the propotion of tests which satisfy a given condition
--
-- @
-- xs <- forAll $ Gen.list (Range.linear 0 100) $ Gen.int (Range.linear 0 100)
-- for_ xs $ \x -> do
--   classify "newborns" $ x == 0
--   classify "children" $ x > 0 && x < 13
--   classify "teens" $ x > 12 && x < 20
-- @
classify :: (GHC.HasCallStack) => String -> Bool -> Property
classify :: HasCallStack => String -> Bool -> PropertyM ()
classify String
l Bool
cond = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ LabelName -> Bool -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
Hedgehog.classify (String -> LabelName
Hedgehog.LabelName String
l) Bool
cond

-- | Require a certain percentage of the tests to be covered by the classifier.
--
-- In the following example, if the condition does not have at least 30%
-- coverage, the test will fail.
--
-- @
-- match <- forAll Gen.bool
-- cover 30 "true" $ match
-- cover 30 "false" $ not match
-- @
cover :: (GHC.HasCallStack) => Double -> String -> Bool -> Property
cover :: HasCallStack => Double -> String -> Bool -> PropertyM ()
cover Double
p String
l Bool
cond = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ CoverPercentage -> LabelName -> Bool -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
Hedgehog.cover (Double -> CoverPercentage
Hedgehog.CoverPercentage Double
p) (String -> LabelName
Hedgehog.LabelName String
l) Bool
cond

-- | Add a label for each test run. It produces a table showing the percentage
-- of test runs that produced each label.
label :: (GHC.HasCallStack) => String -> Property
label :: HasCallStack => String -> PropertyM ()
label String
l = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ LabelName -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> m ()
Hedgehog.label (String -> LabelName
Hedgehog.LabelName String
l)

-- | Like 'label', but uses 'Show' to render its argument for display.
collect :: (Show a, GHC.HasCallStack) => a -> Property
collect :: forall a. (Show a, HasCallStack) => a -> PropertyM ()
collect a
a = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
Hedgehog.collect a
a

{----- Assertions -----}

data Fun a b = Fun String (a -> b)
data IsoChecker a b = IsoChecker (Fun a b) (Fun a b)

-- | Verify if two functions are isomorphic.
--
-- @
-- prop "reverse . reverse === id" $ do
--   let genList = Gen.list (Range.linear 0 10) $ Gen.int (Range.linear 0 1000)
--   (reverse . reverse) P.=== id \`shouldSatisfy\` P.isoWith genList
-- @
(===) :: (a -> b) -> (a -> b) -> IsoChecker a b
a -> b
f === :: forall a b. (a -> b) -> (a -> b) -> IsoChecker a b
=== a -> b
g = Fun a b -> Fun a b -> IsoChecker a b
forall a b. Fun a b -> Fun a b -> IsoChecker a b
IsoChecker (String -> (a -> b) -> Fun a b
forall a b. String -> (a -> b) -> Fun a b
Fun String
"lhs" a -> b
f) (String -> (a -> b) -> Fun a b
forall a b. String -> (a -> b) -> Fun a b
Fun String
"rhs" a -> b
g)

infix 2 ===

-- | See '(===)'.
isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)
isoWith :: forall a b.
(HasCallStack, Show a, Eq b) =>
Gen a -> Predicate PropertyM (IsoChecker a b)
isoWith Gen a
gen =
  Predicate
    { predicateFunc :: IsoChecker a b -> PropertyM PredicateFuncResult
predicateFunc = \(IsoChecker (Fun String
f1DispS a -> b
f1) (Fun String
f2DispS a -> b
f2)) -> do
        a
a <- (HasCallStack => PropertyM a) -> PropertyM a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM a) -> PropertyM a)
-> (HasCallStack => PropertyM a) -> PropertyM a
forall a b. (a -> b) -> a -> b
$ Gen a -> PropertyM a
forall a. (HasCallStack, Show a) => Gen a -> PropertyM a
forAll Gen a
gen
        let
          f1Disp :: Text
f1Disp = String -> Text
Text.pack String
f1DispS
          f2Disp :: Text
f2Disp = String -> Text
Text.pack String
f2DispS
          b1 :: b
b1 = a -> b
f1 a
a
          b2 :: b
b2 = a -> b
f2 a
a
          aDisp :: Text
aDisp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. a -> Text
render a
a
          b1Disp :: Text
b1Disp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ b -> Text
forall a. a -> Text
render b
b1
          b2Disp :: Text
b2Disp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ b -> Text
forall a. a -> Text
render b
b2
        PredicateFuncResult -> PropertyM PredicateFuncResult
forall a. a -> PropertyM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = b
b1 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
b2
            , predicateExplain :: Text
predicateExplain =
                Text -> FailContext -> Text
Text.intercalate Text
"\n" (FailContext -> Text) -> FailContext -> Text
forall a b. (a -> b) -> a -> b
$
                  [ Text
b1Disp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if b
b1 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
b2 then Text
"=" else Text
"≠") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b2Disp
                  , Text
"where"
                  , Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
b1Disp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f1Disp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aDisp
                  , Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
b2Disp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f2Disp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aDisp
                  ]
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
HideFailCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
 where
  disp :: Text
disp = Text
"isomorphic"
  dispNeg :: Text
dispNeg = Text
"not isomorphic"

{----- Plugin -----}

propPlugin :: Plugin
propPlugin :: Plugin
propPlugin =
  Plugin
defaultPlugin
    { cliFlags =
        [ CLI.flag @PropSeedFlag
        , CLI.flag @PropLimitFlag
        ]
    }

newtype PropSeedFlag = PropSeedFlag (Maybe Hedgehog.Seed)

instance IsFlag PropSeedFlag where
  flagName :: String
flagName = String
"seed"
  flagMetaVar :: String
flagMetaVar = String
"SEED"
  flagHelp :: String
flagHelp = String
"The seed to use for property tests"
  flagSpec :: FlagSpec PropSeedFlag
flagSpec =
    OptionalFlag
      { default_ :: PropSeedFlag
default_ = Maybe Seed -> PropSeedFlag
PropSeedFlag Maybe Seed
forall a. Maybe a
Nothing
      , parse :: String -> Either String PropSeedFlag
parse = String -> Either String PropSeedFlag
parse
      }
   where
    parse :: String -> Either String PropSeedFlag
parse String
s = Either String PropSeedFlag
-> (PropSeedFlag -> Either String PropSeedFlag)
-> Maybe PropSeedFlag
-> Either String PropSeedFlag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String PropSeedFlag
forall a b. a -> Either a b
Left (String -> Either String PropSeedFlag)
-> String -> Either String PropSeedFlag
forall a b. (a -> b) -> a -> b
$ String
"Invalid seed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s) PropSeedFlag -> Either String PropSeedFlag
forall a b. b -> Either a b
Right (Maybe PropSeedFlag -> Either String PropSeedFlag)
-> Maybe PropSeedFlag -> Either String PropSeedFlag
forall a b. (a -> b) -> a -> b
$ do
      (String
valS, Char
':' : String
gammaS) <- (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
s
      Word64
val <- String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
valS
      Word64
gamma <- String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
gammaS
      PropSeedFlag -> Maybe PropSeedFlag
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PropSeedFlag -> Maybe PropSeedFlag)
-> (Seed -> PropSeedFlag) -> Seed -> Maybe PropSeedFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Seed -> PropSeedFlag
PropSeedFlag (Maybe Seed -> PropSeedFlag)
-> (Seed -> Maybe Seed) -> Seed -> PropSeedFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> Maybe Seed
forall a. a -> Maybe a
Just (Seed -> Maybe PropSeedFlag) -> Seed -> Maybe PropSeedFlag
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Seed
Hedgehog.Seed Word64
val Word64
gamma

newtype PropLimitFlag = PropLimitFlag (Maybe Int)

instance IsFlag PropLimitFlag where
  flagName :: String
flagName = String
"prop-test-limit"
  flagMetaVar :: String
flagMetaVar = String
"N"
  flagHelp :: String
flagHelp = String
"The number of tests to run per property test"
  flagSpec :: FlagSpec PropLimitFlag
flagSpec =
    OptionalFlag
      { default_ :: PropLimitFlag
default_ = Maybe Int -> PropLimitFlag
PropLimitFlag Maybe Int
forall a. Maybe a
Nothing
      , parse :: String -> Either String PropLimitFlag
parse = (Int -> PropLimitFlag)
-> Either String Int -> Either String PropLimitFlag
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> PropLimitFlag
PropLimitFlag (Maybe Int -> PropLimitFlag)
-> (Int -> Maybe Int) -> Int -> PropLimitFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) (Either String Int -> Either String PropLimitFlag)
-> (String -> Either String Int)
-> String
-> Either String PropLimitFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Int
forall a. Read a => String -> Either String a
readEither
      }