{-# LANGUAGE MultiParamTypeClasses, CPP #-}
#if __GLASGOW_HASKELL__ == 708
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
#endif
-- |
-- Module      : Test.Framework.Providers.LeanCheck
-- Copyright   : (c) 2018 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- LeanCheck support for test-framework (Test.Framework).
--
-- Here's how your @test.hs@ might look like:
--
-- > import Test.Framework
-- > import Test.Framework.Providers.LeanCheck as LC
-- > import Data.List
-- >
-- > main :: IO ()
-- > main = defaultMain tests
-- >
-- > tests :: [Test]
-- > tests =
-- >   [ LC.testProperty "sort . sort == sort"
-- >       $ \xs -> sort (sort xs :: [Int]) == sort xs
-- >   , LC.testProperty "sort == id" -- not really, should fail
-- >       $ \xs -> sort (xs :: [Int]) == xs
-- >   ]
--
-- The output for the above program is:
--
-- > ./eg/test
-- > sort . sort == sort: [OK, passed 100 tests.]
-- > sort == id: [Failed]
-- > *** Failed! Falsifiable (after 7 tests):
-- > [1,0]
-- >
-- >          Properties  Total
-- >  Passed  1           1
-- >  Failed  1           1
-- >  Total   2           2
--
-- Use @-a@ or @--maximum-generated-tests@ to configure
-- the maximum number of tests for each property.
--
-- > $ ./eg/test -a5
-- > sort . sort == sort: [OK, passed 5 tests.]
-- > sort == id: [OK, passed 5 tests.]
-- >
-- >          Properties  Total      
-- >  Passed  2           2          
-- >  Failed  0           0          
-- >  Total   2           2          
--
-- Since LeanCheck is enumerative,
-- you may want to increase the default number of tests (100).
-- Arbitrary rule of thumb:
--
-- * between 200 to 500 on a developer machine;
-- * between 1000 and 5000 on the CI.
--
-- Your mileage may vary.
--
-- Please see the documentation of
-- "Test.LeanCheck" and "Test.Framework.Providers"
-- for more details.
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

-- | List of test results for a given property
newtype Results = Results [([String],Bool)]

#if __GLASGOW_HASKELL__ == 708
deriving instance Typeable Results
#endif

-- | The ultimate test result for a given property
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

-- | Given a 'Testable' property, returns a test-framework test.
--   For example, place the following in a 'TestGroup' list:
--
-- > testProperty "sort . sort == sort" $
-- >   \xs -> sort (sort xs :: [Int]) == sort xs
--
-- You may want to import this module qualified and use @LC.TestProperty@
-- if mixing "Test.LeanCheck" tests
-- with those of other property testing libraries.
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

-- | The current version does not 'runImprovingIO'.
--   So progress is only seen between properties, but not within properties.
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

-- joins the counter-example arguments
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

-- chops a line break at the end if there is any
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