<commit_before>{-# LANGUAGE FlexibleInstances #-}
module Test.QuickCheck.Property where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Text( showErr, putLine )
import Test.QuickCheck.Exception
import Test.QuickCheck.State

import Control.Concurrent
  ( forkIO
  , threadDelay
  , killThread
  , newEmptyMVar
  , takeMVar
  , putMVar
  )

import System.IO
  ( hFlush
  , stdout
  )

--------------------------------------------------------------------------
-- fixeties

infixr 0 ==>
infixr 1 .&.
-- infixr 1 .&&.

--------------------------------------------------------------------------
-- * Property and Testable types

type Property = Gen Prop

-- | The class of things which can be tested, i.e. turned into a property.
class Testable prop where
  property :: prop -> Property

instance Testable () where
  property _ = property rejected

instance Testable Bool where
  property = property . liftBool

instance Testable Result where
  property = return . MkProp . return . return

instance Testable Prop where
  property = return . protectProp

instance Testable prop => Testable (Gen prop) where
  property mp = do p <- mp; property p

morallyDubiousIOProperty :: Testable prop => IO prop -> Property
morallyDubiousIOProperty = fmap (MkProp . IORose . fmap unProp) . promote . fmap property

instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
  property f = forAllShrink arbitrary shrink f

--------------------------------------------------------------------------
-- ** Type Prop

-- is this the right level to be abstract at?

newtype Prop = MkProp{ unProp :: Rose (IO Result) }

protectProp :: Prop -> Prop
protectProp (MkProp r) =
  MkProp . IORose $ do
    (x, rs) <- unpackRose r
    return (MkRose x rs)

-- ** type Rose

-- We never allow a rose tree to be _|_. This makes avoiding
-- exceptions easier.
-- This relies on the fact that the 'property' function never returns _|_.
data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))

joinRose :: Rose (Rose a) -> Rose a
joinRose (IORose rs) = IORose (fmap joinRose rs)
joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs))
joinRose (MkRose (MkRose x ts) tts) =
  -- first shrinks outer quantification; makes most sense
  MkRose x (map joinRose tts ++ ts)
  -- first shrinks inner quantification
  --MkRose x (ts ++ map joinRose tts)

instance Functor Rose where
  fmap f (IORose rs)   = IORose (fmap (fmap f) rs)
  fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]

instance Monad Rose where
  return x = MkRose x []
  m >>= k  = joinRose (fmap k m)

unpackRose :: Rose (IO Result) -> IO (IO Result, [Rose (IO Result)])
unpackRose rose = either (\e -> (return (exception "Exception" e), [])) id
                  `fmap` tryEvaluateIO (unpack rose)
  where unpack (MkRose x xs) = return (x, xs)
        unpack (IORose m) = m >>= unpack

-- ** Result type

-- | Different kinds of callbacks
data Callback
  = PostTest (State -> Result -> IO ())         -- ^ Called just after a test
  | PostFinalFailure (State -> Result -> IO ()) -- ^ Called with the final failing test-case

-- | The result of a single test.
data Result
  = MkResult
  { ok          :: Maybe Bool     -- ^ result of the test case; Nothing = discard
  , expect      :: Bool           -- ^ indicates what the expected result of the property is
  , reason      :: String         -- ^ a message indicating what went wrong
  , interrupted :: Bool           -- ^ indicates if the test case was cancelled by pressing ^C
  , stamp       :: [(String,Int)] -- ^ the collected values for this test case
  , callbacks   :: [Callback]     -- ^ the callbacks for this test case
  }

result :: Result
result =
  MkResult
  { ok          = undefined
  , expect      = True
  , reason      = ""
  , interrupted = False
  , stamp       = []
  , callbacks   = []
  }

exception :: String -> AnException -> Result
exception msg err = failed{ reason = msg ++ ": '" ++ showErr err ++ "'",
                            interrupted = isInterrupt err }

protectResult :: IO Result -> IO Result
protectResult m = either (exception "Exception") id `fmap` tryEvaluateIO (fmap force m)
  where force res = ok res == Just False `seq` res

succeeded :: Result 
succeeded = result{ ok = Just True }

failed :: Result
failed = result{ ok = Just False }

rejected :: Result
rejected = result{ ok = Nothing }

--------------------------------------------------------------------------
-- ** Lifting and mapping functions

liftBool :: Bool -> Property
liftBool b = liftResult $
  result
  { ok     = Just b
  , reason = if b then "" else "Falsifiable"
  }

liftResult :: Result -> Property
liftResult r = liftIOResult (return r)

liftIOResult :: IO Result -> Property
liftIOResult m = property (MkProp (return m))

mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapIOResult (fmap f)

mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property
mapIOResult f = mapRoseIOResult (fmap (f . protectResult))

-- f here has to be total.
mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property
mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t))

mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property
mapProp f = fmap f . property

--------------------------------------------------------------------------
-- ** Property combinators

-- | Changes the maximum test case size for a property.
mapSize :: Testable prop => (Int -> Int) -> prop -> Property
mapSize f p = sized ((`resize` property p) . f)

-- | Shrinks the argument to property if it fails. Shrinking is done
-- automatically for most types. This is only needed when you want to
-- override the default behavior.
shrinking :: Testable prop =>
             (a -> [a])  -- ^ 'shrink'-like function.
          -> a           -- ^ The original argument
          -> (a -> prop) -> Property
shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0))<commit_msg>Work in progress: bugfixing in Property.hs<commit_after>{-# LANGUAGE FlexibleInstances #-}
module Test.QuickCheck.Property where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Text( showErr, putLine )
import Test.QuickCheck.Exception
import Test.QuickCheck.State

import Control.Concurrent
  ( forkIO
  , threadDelay
  , killThread
  , newEmptyMVar
  , takeMVar
  , putMVar
  )

import System.IO
  ( hFlush
  , stdout
  )

--------------------------------------------------------------------------
-- fixities

infixr 0 ==>
infixr 1 .&.
infixr 1 .&&.
infixr 1 .||.

--------------------------------------------------------------------------
-- * Property and Testable types

type Property = Gen Prop

-- | The class of things which can be tested, i.e. turned into a property.
class Testable prop where
  property :: prop -> Property
  -- Exception handling: the Prop generated by 'property' must never
  -- be _|_ (see the note below about rose trees).
  -- This is guaranteed because every Testable instance calls
  -- property :: Result -> Property or property :: Prop -> Property.
  -- The first never returns _|_ and the second installs an exception handler.

instance Testable () where
  property _ = property rejected

instance Testable Bool where
  property = property . liftBool

instance Testable Result where
  property = return . MkProp . return . return

instance Testable Prop where
  property = liftProp

instance Testable prop => Testable (Gen prop) where
  property mp = do p <- mp; property p

morallyDubiousIOProperty :: Testable prop => IO prop -> Property
morallyDubiousIOProperty = fmap (MkProp . IORose . fmap unProp) . promote . fmap property

instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
  property f = forAllShrink arbitrary shrink f

--------------------------------------------------------------------------
-- ** Type Prop

newtype Prop = MkProp{ unProp :: Rose (IO Result) }

-- Exception handling.
protect :: (AnException -> a) -> IO a -> IO a
protect f x = either f id `fmap` tryEvaluateIO x

-- The argument to liftProp is user-supplied so may be _|_;
-- to respect our rose tree invariants we have to add exception
-- handling ourselves.
liftProp :: Prop -> Property
liftProp (MkProp r) =
  return . MkProp . IORose $ protect (return . return . exception "Exception") (return r)

-- ** type Rose

-- Invariant: a rose tree must never be _|_.
-- This makes dealing with exceptions much easier for us.
-- This relies on the fact that the 'property' function never returns _|_.
data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))

joinRose :: Rose (Rose a) -> Rose a
joinRose (IORose rs) = IORose (fmap joinRose rs)
joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs))
joinRose (MkRose (MkRose x ts) tts) =
  -- first shrinks outer quantification; makes most sense
  MkRose x (map joinRose tts ++ ts)
  -- first shrinks inner quantification
  --MkRose x (ts ++ map joinRose tts)

instance Functor Rose where
  fmap f (IORose rs)   = IORose (fmap (fmap f) rs)
  fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]

instance Monad Rose where
  return x = MkRose x []
  m >>= k  = joinRose (fmap k m)

unpackRose :: Rose (IO Result) -> IO (IO Result, [Rose (IO Result)])
unpackRose rose = either (\e -> (return (exception "Exception" e), [])) id
                  `fmap` tryEvaluateIO (unpack rose)
  where unpack (MkRose x xs) = return (x, xs)
        unpack (IORose m) = m >>= unpack

-- ** Result type

-- We don't allow a Result to be _|_: it should be a 'failed' instead
-- in that case. The protectResult function transforms a possibly-_|_
-- Result into a non-_|_ one by catching any exceptions it throws.
--
-- We also don't allow MkResult { ok = _|_ }; in other words, forcing
-- the result should be enough to force its 'ok' component (and other
-- interesting components). We enforce this by only using 'succeeded',
-- 'failed' and 'rejected' to construct Results.
--
-- An IO Result stored inside a rose tree may be _|_, but unpackRose
-- and mapIOResult take care of protecting them so in most contexts
-- they won't be _|_.

-- | Different kinds of callbacks
data Callback
  = PostTest (State -> Result -> IO ())         -- ^ Called just after a test
  | PostFinalFailure (State -> Result -> IO ()) -- ^ Called with the final failing test-case

-- | The result of a single test.
data Result
  = MkResult
  { ok          :: Maybe Bool     -- ^ result of the test case; Nothing = discard
  , expect      :: Bool           -- ^ indicates what the expected result of the property is
  , reason      :: String         -- ^ a message indicating what went wrong
  , interrupted :: Bool           -- ^ indicates if the test case was cancelled by pressing ^C
  , stamp       :: [(String,Int)] -- ^ the collected values for this test case
  , callbacks   :: [Callback]     -- ^ the callbacks for this test case
  }

result :: Result
result =
  MkResult
  { ok          = undefined
  , expect      = True
  , reason      = ""
  , interrupted = False
  , stamp       = []
  , callbacks   = []
  }

exception :: String -> AnException -> Result
exception msg err = failed{ reason = msg ++ ": '" ++ showErr err ++ "'",
                            interrupted = isInterrupt err }

protectResult :: IO Result -> IO Result
protectResult m = protect (exception "Exception") m

succeeded :: Result 
succeeded = result{ ok = Just True }

failed :: Result
failed = result{ ok = Just False }

rejected :: Result
rejected = result{ ok = Nothing }

--------------------------------------------------------------------------
-- ** Lifting and mapping functions

liftBool :: Bool -> Result
liftBool True = succeeded
liftBool False = failed { reason = "Falsifiable" }

mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapIOResult (fmap f)

mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property
mapIOResult f = mapRoseIOResult (fmap (f . protectResult))

-- f here has to be total (rose tree invariant).
mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property
mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t))

mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property
mapProp f = fmap f . property

--------------------------------------------------------------------------
-- ** Property combinators

-- | Changes the maximum test case size for a property.
mapSize :: Testable prop => (Int -> Int) -> prop -> Property
mapSize f p = sized ((`resize` property p) . f)

-- | Shrinks the argument to property if it fails. Shrinking is done
-- automatically for most types. This is only needed when you want to
-- override the default behavior.
shrinking :: Testable prop =>
             (a -> [a])  -- ^ 'shrink'-like function.
          -> a           -- ^ The original argument
          -> (a -> prop) -> Property
shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0))
{'fraction_non_alphanumeric': 0.16945827674664252, 'fraction_numerical': 0.0008299381318847141, 'mean_word_length': 2.249570973277764, 'pattern_counts': {'":': 2, '<': 10, '<?xml version=': 0, '>': 110, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4793696', 'n_tokens_mistral': 3913, 'n_tokens_neox': 3714, 'n_words': 1529}