{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Massiv.Utils (
  showsType,
  showsArrayType,
  assertDeepException,
  assertDeepExceptionIO,
  assertSomeException,
  assertSomeExceptionIO,
  toStringException,
  selectErrorCall,
  ExpectedException (..),
  applyFun2Compat,
  expectProp,
  propIO,
  specLaws,

  -- * Epsilon comparison
  epsilonExpect,
  epsilonFoldableExpect,
  epsilonMaybeEq,
  epsilonEq,
  epsilonEqDouble,
  epsilonEqFloat,
  module X,
) where

import Control.DeepSeq as X (NFData, deepseq)
import Control.Exception (ErrorCall (..))
import Control.Monad as X
import Control.Monad.ST as X
import qualified Data.Foldable as F
import Data.Maybe as X (fromMaybe, isJust, isNothing)
import Data.Typeable as X
import Test.Hspec as X
import Test.Hspec.QuickCheck as X
import Test.QuickCheck as X hiding ((.&.))
import Test.QuickCheck.Classes.Base as X
import Test.QuickCheck.Function as X
import Test.QuickCheck.Monadic as X
import UnliftIO.Exception (Exception (..), SomeException, catch, catchAny)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup as X ((<>))
#endif

specLaws :: HasCallStack => Laws -> Spec
specLaws :: HasCallStack => Laws -> Spec
specLaws Laws
laws =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Laws -> String
lawsTypeclass Laws
laws) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    ((String, Property) -> Spec) -> [(String, Property)] -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> Property -> Spec) -> (String, Property) -> Spec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop) (Laws -> [(String, Property)]
lawsProperties Laws
laws)

-- | Use Typeable to show the type.
showsType :: forall t. Typeable t => ShowS
showsType :: forall t. Typeable t => ShowS
showsType = TypeRep -> ShowS
showsTypeRep (Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))

-- | Use Typeable to show the array type
showsArrayType :: forall r ix e. (Typeable r, Typeable ix, Typeable e) => ShowS
showsArrayType :: forall r ix e. (Typeable r, Typeable ix, Typeable e) => ShowS
showsArrayType =
  (String
"Array " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Typeable t => ShowS
showsType @r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Typeable t => ShowS
showsType @ix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Typeable t => ShowS
showsType @e

assertSomeException :: NFData a => a -> Property
assertSomeException :: forall a. NFData a => a -> Property
assertSomeException = IO a -> Property
forall a. NFData a => IO a -> Property
assertSomeExceptionIO (IO a -> Property) -> (a -> IO a) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

assertSomeExceptionIO :: NFData a => IO a -> Property
assertSomeExceptionIO :: forall a. NFData a => IO a -> Property
assertSomeExceptionIO IO a
action =
  PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$
    IO Property -> PropertyM IO Property
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Property -> PropertyM IO Property)
-> IO Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$
      IO Property -> (SomeException -> IO Property) -> IO Property
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
        ( do
            a
res <- IO a
action
            a
res a -> IO Property -> IO Property
forall a b. NFData a => a -> b -> b
`deepseq` Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Did not receive an exception" Bool
False)
        )
        (\SomeException
exc -> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
exc String -> IO Property -> IO Property
forall a b. NFData a => a -> b -> b
`deepseq` Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True))

#if !MIN_VERSION_QuickCheck(2,15,0)
assertDeepException
  :: (Testable b, NFData a, Exception exc)
  => (exc -> b)
  -- ^ Return True if that is the exception that was expected
  -> a
  -- ^ Value that should throw an exception, when fully evaluated
  -> Property
assertDeepException isExc = assertDeepExceptionIO isExc . pure

assertDeepExceptionIO
  :: (Testable b, NFData a, Exception exc)
  => (exc -> b)
  -- ^ Return True if that is the exception that was expected
  -> IO a
  -- ^ IO Action that should throw an exception
  -> Property
assertDeepExceptionIO isExc action =
  monadicIO $
    run $
      catch
        ( do
            res <- action
            res `deepseq` return (counterexample "Did not receive an exception" False)
        )
        (\exc -> displayException exc `deepseq` return (property (isExc exc)))

#endif

toStringException :: Either SomeException a -> Either String a
toStringException :: forall a. Either SomeException a -> Either String a
toStringException = (SomeException -> Either String a)
-> (a -> Either String a)
-> Either SomeException a
-> Either String a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (SomeException -> String) -> SomeException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException) a -> Either String a
forall a b. b -> Either a b
Right

selectErrorCall :: ErrorCall -> Bool
selectErrorCall :: ErrorCall -> Bool
selectErrorCall = \case
  ErrorCallWithLocation String
err String
loc -> String
err String -> Bool -> Bool
forall a b. NFData a => a -> b -> b
`deepseq` String
loc String -> Bool -> Bool
forall a b. NFData a => a -> b -> b
`deepseq` Bool
True

data ExpectedException = ExpectedException deriving (Int -> ExpectedException -> ShowS
[ExpectedException] -> ShowS
ExpectedException -> String
(Int -> ExpectedException -> ShowS)
-> (ExpectedException -> String)
-> ([ExpectedException] -> ShowS)
-> Show ExpectedException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExpectedException -> ShowS
showsPrec :: Int -> ExpectedException -> ShowS
$cshow :: ExpectedException -> String
show :: ExpectedException -> String
$cshowList :: [ExpectedException] -> ShowS
showList :: [ExpectedException] -> ShowS
Show, ExpectedException -> ExpectedException -> Bool
(ExpectedException -> ExpectedException -> Bool)
-> (ExpectedException -> ExpectedException -> Bool)
-> Eq ExpectedException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExpectedException -> ExpectedException -> Bool
== :: ExpectedException -> ExpectedException -> Bool
$c/= :: ExpectedException -> ExpectedException -> Bool
/= :: ExpectedException -> ExpectedException -> Bool
Eq)

instance Exception ExpectedException

applyFun2Compat :: Fun (a, b) c -> (a -> b -> c)
#if MIN_VERSION_QuickCheck(2,10,0)
applyFun2Compat :: forall a b c. Fun (a, b) c -> a -> b -> c
applyFun2Compat = Fun (a, b) c -> a -> b -> c
forall a b c. Fun (a, b) c -> a -> b -> c
applyFun2
#else
applyFun2Compat (Fun _ f) a b = f (a, b)
instance Function Word where
  function = functionMap fromIntegral fromInteger
#endif

-- | Convert an hspec Expectation to a quickcheck Property.
--
-- @since 1.5.0
expectProp :: Expectation -> Property
expectProp :: Expectation -> Property
expectProp = PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property)
-> (Expectation -> PropertyM IO ()) -> Expectation -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run

-- | Convert a Testable to a quickcheck Property. Works well with hspec expectations as well
--
-- @since 1.7.0
propIO :: Testable a => IO a -> Property
propIO :: forall a. Testable a => IO a -> Property
propIO IO a
action = PropertyM IO a -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO a -> Property) -> PropertyM IO a -> Property
forall a b. (a -> b) -> a -> b
$ IO a -> PropertyM IO a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO a
action

epsilonExpect
  :: (HasCallStack, Show a, RealFloat a)
  => a
  -- ^ Epsilon, a maximum tolerated error. Sign is ignored.
  -> a
  -- ^ Expected result.
  -> a
  -- ^ Tested value.
  -> Expectation
epsilonExpect :: forall a.
(HasCallStack, Show a, RealFloat a) =>
a -> a -> a -> Expectation
epsilonExpect a
epsilon a
x a
y =
  Maybe String -> (String -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
X.forM_ (a -> a -> a -> Maybe String
forall a. (Show a, RealFloat a) => a -> a -> a -> Maybe String
epsilonMaybeEq a
epsilon a
x a
y) ((String -> Expectation) -> Expectation)
-> (String -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \String
errMsg ->
    HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
errMsg

epsilonFoldableExpect
  :: (HasCallStack, Foldable f, Show (f e), Show e, RealFloat e) => e -> f e -> f e -> Expectation
epsilonFoldableExpect :: forall (f :: * -> *) e.
(HasCallStack, Foldable f, Show (f e), Show e, RealFloat e) =>
e -> f e -> f e -> Expectation
epsilonFoldableExpect e
epsilon f e
x f e
y = do
  f e -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length f e
x Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` f e -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length f e
y
  Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (f e -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null f e
x) (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
    Maybe [String] -> ([String] -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
X.forM_ ((e -> e -> Maybe String) -> [e] -> [e] -> Maybe [String]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (e -> e -> e -> Maybe String
forall a. (Show a, RealFloat a) => a -> a -> a -> Maybe String
epsilonMaybeEq e
epsilon) (f e -> [e]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f e
x) (f e -> [e]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f e
y)) (([String] -> Expectation) -> Expectation)
-> ([String] -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \[String]
errMsgs ->
      HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
        String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f e -> String
forall a. Show a => a -> String
show f e
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f e -> String
forall a. Show a => a -> String
show f e
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"    " String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
errMsgs)

epsilonMaybeEq
  :: (Show a, RealFloat a)
  => a
  -- ^ Epsilon, a maximum tolerated error. Sign is ignored.
  -> a
  -- ^ Expected result.
  -> a
  -- ^ Tested value.
  -> Maybe String
epsilonMaybeEq :: forall a. (Show a, RealFloat a) => a -> a -> a -> Maybe String
epsilonMaybeEq a
epsilon a
x a
y
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
y) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Expected NaN, but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = Maybe String
forall a. Maybe a
Nothing
  | a
diff a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
n = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [a -> String
forall a. Show a => a -> String
show a
x, String
" /= ", a -> String
forall a. Show a => a -> String
show a
y, String
" (Tolerance: ", a -> String
forall a. Show a => a -> String
show a
diff, String
" > ", a -> String
forall a. Show a => a -> String
show a
n, String
")"]
  | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
  where
    (a
absx, a
absy) = (a -> a
forall a. Num a => a -> a
abs a
x, a -> a
forall a. Num a => a -> a
abs a
y)
    n :: a
n = a
epsilon a -> a -> a
forall a. Num a => a -> a -> a
* (a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a -> a
forall a. Ord a => a -> a -> a
max a
absx a
absy)
    diff :: a
diff = a -> a
forall a. Num a => a -> a
abs (a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
x)

epsilonEq
  :: (Show a, RealFloat a)
  => a
  -- ^ Epsilon, a maximum tolerated error. Sign is ignored.
  -> a
  -- ^ Expected result.
  -> a
  -- ^ Tested value.
  -> Property
epsilonEq :: forall a. (Show a, RealFloat a) => a -> a -> a -> Property
epsilonEq a
epsilon a
x a
y = Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Expectation -> Property) -> Expectation -> Property
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> Expectation
forall a.
(HasCallStack, Show a, RealFloat a) =>
a -> a -> a -> Expectation
epsilonExpect a
epsilon a
x a
y

epsilonEqDouble
  :: Double
  -- ^ Expected result.
  -> Double
  -- ^ Tested value.
  -> Property
epsilonEqDouble :: Double -> Double -> Property
epsilonEqDouble = Double -> Double -> Double -> Property
forall a. (Show a, RealFloat a) => a -> a -> a -> Property
epsilonEq Double
epsilon
  where
    epsilon :: Double
epsilon = Double
1e-12

epsilonEqFloat
  :: Float
  -- ^ Expected result.
  -> Float
  -- ^ Tested value.
  -> Property
epsilonEqFloat :: Float -> Float -> Property
epsilonEqFloat = Float -> Float -> Float -> Property
forall a. (Show a, RealFloat a) => a -> a -> a -> Property
epsilonEq Float
epsilon
  where
    epsilon :: Float
epsilon = Float
1e-6