{-# LANGUAGE MultiParamTypeClasses, CPP #-}
#if __GLASGOW_HASKELL__ == 708
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
#endif
module Test.Framework.Providers.LeanCheck
( testProperty
)
where
import Test.Framework.Providers.API
import Test.LeanCheck
import Control.Exception (SomeException, catch, evaluate)
#if __GLASGOW_HASKELL__ == 708
import Data.Typeable (Typeable)
#endif
newtype Results = Results [([String],Bool)]
#if __GLASGOW_HASKELL__ == 708
deriving instance Typeable Results
#endif
data Result = OK Int
| Falsified Int [String]
| Exception Int [String] String
deriving Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq
instance Show Result where
show :: Result -> String
show (OK Int
n) = String
"OK, passed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests."
show (Falsified Int
i [String]
ce) = String
"*** Failed! Falsifiable (after "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests):\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
joinArgs [String]
ce
show (Exception Int
i [String]
ce String
e) = String
"*** Failed! Exception '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' (after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests):\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
joinArgs [String]
ce
testProperty :: Testable a => TestName -> a -> Test
testProperty :: String -> a -> Test
testProperty String
name = String -> Results -> Test
forall i r t. (Testlike i r t, Typeable t) => String -> t -> Test
Test String
name (Results -> Test) -> (a -> Results) -> a -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([String], Bool)] -> Results
Results ([([String], Bool)] -> Results)
-> (a -> [([String], Bool)]) -> a -> Results
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [([String], Bool)]
forall a. Testable a => a -> [([String], Bool)]
results
instance Testlike Int Result Results where
runTest :: CompleteTestOptions -> Results -> IO (Int :~> Result, IO ())
runTest CompleteTestOptions
topts Results
results = do
let m :: Int
m = K Int -> Int
forall a. K a -> a
unK (K Int -> Int) -> K Int -> Int
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K Int
forall (f :: * -> *). TestOptions' f -> f Int
topt_maximum_generated_tests CompleteTestOptions
topts
Result
result <- Int -> Results -> IO Result
resultIO Int
m Results
results
(Int :~> Result, IO ()) -> IO (Int :~> Result, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Int :~> Result
forall i f. f -> i :~> f
Finished Result
result, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
testTypeName :: Results -> String
testTypeName Results
_ = String
"Properties"
instance TestResultlike Int Result where
testSucceeded :: Result -> Bool
testSucceeded (OK Int
_) = Bool
True
testSucceeded Result
_ = Bool
False
resultsIO :: Int -> Results -> [IO Result]
resultsIO :: Int -> Results -> [IO Result]
resultsIO Int
n (Results [([String], Bool)]
results) = (Int -> ([String], Bool) -> IO Result)
-> [Int] -> [([String], Bool)] -> [IO Result]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ([String], Bool) -> IO Result
torio [Int
1..] ([([String], Bool)] -> [IO Result])
-> [([String], Bool)] -> [IO Result]
forall a b. (a -> b) -> a -> b
$ Int -> [([String], Bool)] -> [([String], Bool)]
forall a. Int -> [a] -> [a]
take Int
n [([String], Bool)]
results
where
tor :: Int -> ([String], Bool) -> Result
tor Int
i ([String]
_,Bool
True) = Int -> Result
OK Int
i
tor Int
i ([String]
as,Bool
False) = Int -> [String] -> Result
Falsified Int
i [String]
as
torio :: Int -> ([String], Bool) -> IO Result
torio Int
i r :: ([String], Bool)
r@([String]
as,Bool
_) = Result -> IO Result
forall a. a -> IO a
evaluate (Int -> ([String], Bool) -> Result
tor Int
i ([String], Bool)
r)
IO Result -> (SomeException -> IO Result) -> IO Result
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> let SomeException
_ = SomeException
e :: SomeException
in Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [String] -> String -> Result
Exception Int
i [String]
as (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
resultIO :: Int -> Results -> IO Result
resultIO :: Int -> Results -> IO Result
resultIO Int
n = [IO Result] -> IO Result
forall (m :: * -> *). Monad m => [m Result] -> m Result
computeResult ([IO Result] -> IO Result)
-> (Results -> [IO Result]) -> Results -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Results -> [IO Result]
resultsIO Int
n
where
computeResult :: [m Result] -> m Result
computeResult [] = String -> m Result
forall a. HasCallStack => String -> a
error String
"resultIO: no results, empty Listable enumeration?"
computeResult [m Result
r] = m Result
r
computeResult (m Result
r:[m Result]
rs) = m Result
r m Result -> (Result -> m Result) -> m Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Result
r -> case Result
r of
(OK Int
_) -> [m Result] -> m Result
computeResult [m Result]
rs
Result
_ -> Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
joinArgs :: [String] -> String
joinArgs :: [String] -> String
joinArgs [String]
ce | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [String]
ce = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
chopBreak [String]
ce
| Bool
otherwise = [String] -> String
unwords [String]
ce
chopBreak :: String -> String
chopBreak :: ShowS
chopBreak [] = []
chopBreak [Char
'\n'] = []
chopBreak (Char
x:String
xs) = Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
chopBreak String
xs