-- |
-- Module      : Test.LeanCheck.Error
-- Copyright   : (c) 2015-2020 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of LeanCheck,
-- a simple enumerative property-based testing library.
--
-- This module re-exports "Test.LeanCheck" but some test functions have been
-- specialized to catch errors (see the explicit export list below).
--
-- This module is unsafe as it uses `unsafePerformIO` to catch errors.
{-# LANGUAGE CPP #-}
module Test.LeanCheck.Error
  ( holds
  , fails
  , exists
  , counterExample
  , counterExamples
  , witness
  , witnesses
  , results

  , fromError
  , errorToNothing
  , errorToFalse
  , errorToTrue
  , errorToLeft
  , anyErrorToNothing
  , anyErrorToLeft
  , (?==?)
  , (!==!)

  , module Test.LeanCheck
  )
where

#if __GLASGOW_HASKELL__ <= 704
import Prelude hiding (catch)
#endif

import Test.LeanCheck hiding
  ( holds
  , fails
  , exists
  , counterExample
  , counterExamples
  , witness
  , witnesses
  , results
  )

import qualified Test.LeanCheck as C
  ( holds
  , fails
  , results
  )

import Control.Monad (liftM)
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Function (on)
import Control.Exception ( evaluate
                         , catch
#if __GLASGOW_HASKELL__
                         , SomeException
                         , ArithException
                         , ArrayException
                         , ErrorCall
                         , PatternMatchFail
                         , catches
                         , Handler (Handler)
#endif
                         )

etom :: Either b a -> Maybe a
etom :: Either b a -> Maybe a
etom (Right a
x)  =  a -> Maybe a
forall a. a -> Maybe a
Just a
x
etom (Left b
_)   =  Maybe a
forall a. Maybe a
Nothing

-- | Transforms a value into 'Just' that value or 'Nothing' on some errors:
--
--   * ArithException
--   * ArrayException
--   * ErrorCall
--   * PatternMatchFail
--
-- > > errorToNothing False
-- > Just False
--
-- > > errorToNothing (0 :: Int)
-- > Just 0
--
-- > > errorToNothing (undefined :: ())
-- > Nothing
--
-- This function uses 'unsafePerformIO'.
errorToNothing :: a -> Maybe a
errorToNothing :: a -> Maybe a
errorToNothing  =  Either String a -> Maybe a
forall b a. Either b a -> Maybe a
etom (Either String a -> Maybe a)
-> (a -> Either String a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String a
forall a. a -> Either String a
errorToLeft

-- | Transforms a value into 'Just' that value or 'Nothing' on error.
anyErrorToNothing :: a -> Maybe a
anyErrorToNothing :: a -> Maybe a
anyErrorToNothing  =  Either String a -> Maybe a
forall b a. Either b a -> Maybe a
etom (Either String a -> Maybe a)
-> (a -> Either String a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String a
forall a. a -> Either String a
anyErrorToLeft

-- | Transforms a value into 'Right' that value or 'Left String' on some errors:
--
--   * ArithException
--   * ArrayException
--   * ErrorCall
--   * PatternMatchFail
--
-- > > errorToLeft False
-- > Just False
--
-- > > errorToLeft (0 :: Int)
-- > Just 0
--
-- > > errorToLeft (undefined :: ())
-- > Left "Prelude.undefined"
--
-- > > errorToLeft (error "error message")
-- > Left "error message"
--
-- > > errorToLeft (1 `div` 0 :: Int)
-- > Left "divide by zero"
--
-- Only the first line of the error's string representation is included.
--
-- This function uses 'unsafePerformIO'.
errorToLeft :: a -> Either String a
errorToLeft :: a -> Either String a
errorToLeft a
x  =  IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__
  (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` a -> IO a
forall a. a -> IO a
evaluate a
x) IO (Either String a)
-> [Handler (Either String a)] -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`catches`
    [ (ArithException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArithException -> IO (Either String a))
 -> Handler (Either String a))
-> (ArithException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \ArithException
e -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (String -> Either String a) -> String -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ ArithException -> String
forall a. Show a => a -> String
show1st (ArithException
e :: ArithException)
    , (ArrayException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArrayException -> IO (Either String a))
 -> Handler (Either String a))
-> (ArrayException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \ArrayException
e -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (String -> Either String a) -> String -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ ArrayException -> String
forall a. Show a => a -> String
show1st (ArrayException
e :: ArrayException)
    , (ErrorCall -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String a)) -> Handler (Either String a))
-> (ErrorCall -> IO (Either String a)) -> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (String -> Either String a) -> String -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> String
forall a. Show a => a -> String
show1st (ErrorCall
e :: ErrorCall)
    , (PatternMatchFail -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((PatternMatchFail -> IO (Either String a))
 -> Handler (Either String a))
-> (PatternMatchFail -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \PatternMatchFail
e -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (String -> Either String a) -> String -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ PatternMatchFail -> String
forall a. Show a => a -> String
show1st (PatternMatchFail
e :: PatternMatchFail)
    ]
#else
  (Right `liftM` evaluate x) `catch` (return . Left . show1st)
#endif
  where
  show1st :: Show a => a -> String
  show1st :: a -> String
show1st  =  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> (a -> [String]) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Transforms a value into 'Right' that value or 'Left String' on error.
--
-- Only the first line of the error's string representation is included.
--
-- This function uses 'unsafePerformIO'.  See: 'errorToLeft'.
anyErrorToLeft :: a -> Either String a
anyErrorToLeft :: a -> Either String a
anyErrorToLeft a
x  =  IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__
  (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` a -> IO a
forall a. a -> IO a
evaluate a
x) IO (Either String a)
-> (SomeException -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\SomeException
e -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (String -> Either String a) -> String -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show1st (SomeException
e :: SomeException))
#else
  (Right `liftM` evaluate x) `catch` (return . Left . show1st)
#endif
  where
  show1st :: Show a => a -> String
  show1st :: a -> String
show1st  =  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> (a -> [String]) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Transforms errors into 'False' values.
--
-- > > errorToFalse False
-- > False
--
-- > > errorToFalse True
-- > True
--
-- > > errorToFalse undefined
-- > False
--
-- This functions uses 'unsafePerformIO'.
errorToFalse :: Bool -> Bool
errorToFalse :: Bool -> Bool
errorToFalse  =  Bool -> Bool -> Bool
forall a. a -> a -> a
fromError Bool
False

-- | Transforms errors into 'True' values.
--
-- > > errorToTrue False
-- > False
--
-- > > errorToTrue True
-- > True
--
-- > > errorToTrue undefined
-- > True
--
-- This functions uses 'unsafePerformIO'.
errorToTrue :: Bool -> Bool
errorToTrue :: Bool -> Bool
errorToTrue  =  Bool -> Bool -> Bool
forall a. a -> a -> a
fromError Bool
True

-- | Transforms errors into a default value.
--
-- > > fromError 0 (15 :: Int)
-- > 15
--
-- > > fromError 0 (undefined :: Int)
-- > 0
fromError :: a -> a -> a
fromError :: a -> a -> a
fromError a
x  =  a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x (Maybe a -> a) -> (a -> Maybe a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
errorToNothing

-- | Equality '==' lifted over 'errorToNothing'
--
-- > > 1 `div` 1  ?==?  2 `div` 2
-- > True
--
-- > > 1 `div` 1  ?==?  1 `div` 2
-- > False
--
-- > > 1 `div` 1  ?==?  1 `div` 0
-- > False
--
-- > > 6 `mod` 0  ?==?  2 `div` 0
-- > True
--
-- > > head []  ?==?  tail []
-- > True
--
-- > > error "a"  ?==?  error "a"
-- > True
--
-- > > error "a"  ?==?  error "b"
-- > True
--
-- This function consider error values equal.
(?==?) :: Eq a => a -> a -> Bool
?==? :: a -> a -> Bool
(?==?)  =  Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe a -> Maybe a -> Bool) -> (a -> Maybe a) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> Maybe a
forall a. a -> Maybe a
errorToNothing
infix 4 ?==?

-- | Equality '==' lifted over 'errorToLeft'
--
-- > > 1 `div` 1  !==!  2 `div` 2
-- > True
--
-- > > 1 `div` 1  !==!  1 `div` 2
-- > False
--
-- > > 1 `div` 1  !==!  1 `div` 0
-- > False
--
-- > > 6 `mod` 0  !==!  2 `div` 0
-- > True
--
-- > > head []  !==!  tail []
-- > False
--
-- > > error "a"  !==!  error "a"
-- > True
--
-- > > error "a"  !==!  error "b"
-- > False
--
-- On error, this function returns the result
-- of comparing the first line of error values.
(!==!) :: Eq a => a -> a -> Bool
!==! :: a -> a -> Bool
(!==!)  =  Either String a -> Either String a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Either String a -> Either String a -> Bool)
-> (a -> Either String a) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> Either String a
forall a. a -> Either String a
errorToLeft
infix 4 !==!

-- | An error-catching version of 'Test.LeanCheck.holds'
--   that returns 'False' in case of errors.
--
-- > prop_cannot_be_seven :: Int -> Bool
-- > prop_cannot_be_seven 7  =  error "Argument cannot be seven"
-- > prop_cannot_be_seven _  =  True
--
-- > > import Test.LeanCheck
-- > > holds 100 prop_cannot_be_seven
-- > *** Exception: Argument cannot be seven
--
-- > > import Test.LeanCheck.Error
-- > > holds 100 prop_cannot_be_seven
-- > False
holds :: Testable a => Int -> a -> Bool
holds :: Int -> a -> Bool
holds Int
n  =  Bool -> Bool
errorToFalse (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Bool
forall a. Testable a => Int -> a -> Bool
C.holds Int
n

-- | An error-catching version of 'Test.LeanCheck.fails'
--   that returns 'True' in case of errors.
fails :: Testable a => Int -> a -> Bool
fails :: Int -> a -> Bool
fails Int
n  =  Bool -> Bool
errorToTrue (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Bool
forall a. Testable a => Int -> a -> Bool
C.fails Int
n

-- | An error-catching version of 'Test.LeanCheck.exists'.
exists :: Testable a => Int -> a -> Bool
exists :: Int -> a -> Bool
exists Int
n  =  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> (a -> [Bool]) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
n ([Bool] -> [Bool]) -> (a -> [Bool]) -> a -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], Bool) -> Bool) -> [([String], Bool)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ([String], Bool) -> Bool
forall a b. (a, b) -> b
snd ([([String], Bool)] -> [Bool])
-> (a -> [([String], Bool)]) -> a -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [([String], Bool)]
forall a. Testable a => a -> [([String], Bool)]
results

-- | An error-catching version of 'Test.LeanCheck.counterExample'.
counterExample :: Testable a => Int -> a -> Maybe [String]
counterExample :: Int -> a -> Maybe [String]
counterExample Int
n  =  [[String]] -> Maybe [String]
forall a. [a] -> Maybe a
listToMaybe ([[String]] -> Maybe [String])
-> (a -> [[String]]) -> a -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> [[String]]
forall a. Testable a => Int -> a -> [[String]]
counterExamples Int
n

-- | An error-catching version of 'Test.LeanCheck.witness'.
witness :: Testable a => Int -> a -> Maybe [String]
witness :: Int -> a -> Maybe [String]
witness Int
n  =  [[String]] -> Maybe [String]
forall a. [a] -> Maybe a
listToMaybe ([[String]] -> Maybe [String])
-> (a -> [[String]]) -> a -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> [[String]]
forall a. Testable a => Int -> a -> [[String]]
witnesses Int
n

-- | An error-catching version of 'Test.LeanCheck.counterExamples'.
counterExamples :: Testable a => Int -> a -> [[String]]
counterExamples :: Int -> a -> [[String]]
counterExamples Int
n  =  (([String], Bool) -> [String]) -> [([String], Bool)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String], Bool) -> [String]
forall a b. (a, b) -> a
fst ([([String], Bool)] -> [[String]])
-> (a -> [([String], Bool)]) -> a -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], Bool) -> Bool)
-> [([String], Bool)] -> [([String], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([String], Bool) -> Bool) -> ([String], Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], Bool) -> Bool
forall a b. (a, b) -> b
snd) ([([String], Bool)] -> [([String], Bool)])
-> (a -> [([String], Bool)]) -> a -> [([String], Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [([String], Bool)] -> [([String], Bool)]
forall a. Int -> [a] -> [a]
take Int
n ([([String], Bool)] -> [([String], Bool)])
-> (a -> [([String], Bool)]) -> a -> [([String], Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [([String], Bool)]
forall a. Testable a => a -> [([String], Bool)]
results

-- | An error-catching version of 'Test.LeanCheck.witnesses'.
witnesses :: Testable a => Int -> a -> [[String]]
witnesses :: Int -> a -> [[String]]
witnesses Int
n  =  (([String], Bool) -> [String]) -> [([String], Bool)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String], Bool) -> [String]
forall a b. (a, b) -> a
fst ([([String], Bool)] -> [[String]])
-> (a -> [([String], Bool)]) -> a -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], Bool) -> Bool)
-> [([String], Bool)] -> [([String], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([String], Bool) -> Bool
forall a b. (a, b) -> b
snd ([([String], Bool)] -> [([String], Bool)])
-> (a -> [([String], Bool)]) -> a -> [([String], Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [([String], Bool)] -> [([String], Bool)]
forall a. Int -> [a] -> [a]
take Int
n ([([String], Bool)] -> [([String], Bool)])
-> (a -> [([String], Bool)]) -> a -> [([String], Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [([String], Bool)]
forall a. Testable a => a -> [([String], Bool)]
results

-- | An error-catching version of 'Test.LeanCheck.results'.
results :: Testable a => a -> [([String],Bool)]
results :: a -> [([String], Bool)]
results  =  (([String], Bool) -> ([String], Bool))
-> [([String], Bool)] -> [([String], Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Bool) -> ([String], Bool) -> ([String], Bool)
forall t b a. (t -> b) -> (a, t) -> (a, b)
mapSnd Bool -> Bool
errorToFalse) ([([String], Bool)] -> [([String], Bool)])
-> (a -> [([String], Bool)]) -> a -> [([String], Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [([String], Bool)]
forall a. Testable a => a -> [([String], Bool)]
C.results
  where
  mapSnd :: (t -> b) -> (a, t) -> (a, b)
mapSnd t -> b
f (a
x,t
y)  =  (a
x,t -> b
f t
y)