QuickCheck.hs

module Test.Chell.QuickCheck
	( property
	) where

import           System.Random (mkStdGen)

import qualified Test.Chell as Chell
import qualified Test.QuickCheck as QuickCheck
import qualified Test.QuickCheck.Gen as Gen
import qualified Test.QuickCheck.State as State
import qualified Test.QuickCheck.Test as Test
import qualified Test.QuickCheck.Text as Text

-- | Convert a QuickCheck property to a Chell 'Chell.Test'.
--
-- @
--import Test.Chell
--import Test.Chell.QuickCheck
--import Test.QuickCheck hiding (property)
--
--test_NullLength :: Test
--test_NullLength = property \"null-length\"
--    (\xs -> not (null xs) ==> length xs > 0)
-- @
property :: QuickCheck.Testable prop => String -> prop -> Chell.Test
property name prop = Chell.test name $ \opts -> do
	let seed = Chell.testOptionSeed opts
	
	term <- Text.newNullTerminal
	
	let args = QuickCheck.stdArgs
	let state = State.MkState
		{ State.terminal = term
		, State.maxSuccessTests = QuickCheck.maxSuccess args
		, State.maxDiscardedTests = QuickCheck.maxDiscard args
		, State.computeSize = computeSize (QuickCheck.maxSize args) (QuickCheck.maxSuccess args)
		, State.numSuccessTests = 0
		, State.numDiscardedTests = 0
		, State.collected = []
		, State.expectedFailure = False
		, State.randomSeed = mkStdGen seed
		, State.numSuccessShrinks = 0
		, State.numTryShrinks = 0
		}
	
	result <- Test.test state (Gen.unGen (QuickCheck.property prop))
	let output = Test.output result
	let notes = [("seed", show seed)]
	let failure = Chell.failure { Chell.failureMessage = output }
	return $ case result of
		Test.Success{} -> Chell.TestPassed notes
		Test.Failure{} -> Chell.TestFailed notes [failure]
		Test.GaveUp{} -> Chell.TestAborted notes output
		Test.NoExpectedFailure{} -> Chell.TestFailed notes [failure]

-- copied from quickcheck-2.4.1.1/src/Test/QuickCheck/Test.hs
computeSize :: Int -> Int -> Int -> Int -> Int
computeSize maxSize maxSuccess n d
	-- e.g. with maxSuccess = 250, maxSize = 100, goes like this:
	-- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.
	| n `roundTo` maxSize + maxSize <= maxSuccess ||
	  n >= maxSuccess ||
	  maxSuccess `mod` maxSize == 0 = n `mod` maxSize + d `div` 10
	| otherwise =
	 (n `mod` maxSize) * maxSize `div` (maxSuccess `mod` maxSize) + d `div` 10

roundTo :: Int -> Int -> Int
roundTo n m = (n `div` m) * m