1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances #-}
module TestCommonEqEpsilon (EqEpsilon, setEpsilonEq, assertCloseElem, (@?~)) where
import Prelude
import Data.Typeable
import Data.IORef
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Storable as VS
import System.IO.Unsafe
import qualified Test.HUnit.Approx
import Test.Tasty.HUnit
import Test.Tasty.Options
newtype EqEpsilon = EqEpsilon Rational
deriving (Typeable, Num, Fractional)
instance IsOption EqEpsilon where
defaultValue = EqEpsilon eqEpsilonDefault
parseValue s = fmap (EqEpsilon . toRational) ((safeRead :: String -> Maybe Double) s)
optionName = return "eq-epsilon"
optionHelp = return $ "Epsilon to use for floating point comparisons: abs(a-b) < epsilon . Default: "
++ show eqEpsilonDefault
-- Default value for eqEpsilonRef
eqEpsilonDefault :: Rational
eqEpsilonDefault = 1e-6
-- Ugly global epsilon used to compare floating point values.
eqEpsilonRef :: IORef Rational
{-# NOINLINE eqEpsilonRef #-}
eqEpsilonRef = unsafePerformIO $ newIORef eqEpsilonDefault
-- Ugly global epsilon setter (to be called once).
setEpsilonEq :: EqEpsilon -> IO ()
setEpsilonEq (EqEpsilon x) = atomicWriteIORef eqEpsilonRef x
-- | Asserts that the specified actual floating point value is close to the expected value.
-- The output message will contain the prefix, the expected value, and the
-- actual value.
--
-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
-- and only the expected and actual values are output.
assertClose :: forall a. (Fractional a, Ord a, Show a, HasCallStack)
=> String -- ^ The message prefix
-> a -- ^ The expected value
-> a -- ^ The actual value
-> Assertion
assertClose preface expected actual = do
eqEpsilon <- readIORef eqEpsilonRef
Test.HUnit.Approx.assertApproxEqual preface (fromRational eqEpsilon) expected actual
-- | Asserts that the specified actual floating point value is close to at least one of the
-- expected values.
assertCloseElem :: forall a. (Fractional a, Ord a, Show a, HasCallStack)
=> String -- ^ The message prefix
-> [a] -- ^ The expected values
-> a -- ^ The actual value
-> Assertion
assertCloseElem preface expected actual = do
eqEpsilon <- readIORef eqEpsilonRef
go_assert eqEpsilon expected
where
msg = (if null preface then "" else preface ++ "\n") ++
"wrong result: " ++ show actual ++ " is expected to be a member of " ++ show expected
go_assert :: Rational -> [a] -> Assertion
go_assert _ [] = assertFailure msg
go_assert eqEps (h:t) =
if abs (h-actual) < fromRational eqEps then assertClose msg h actual else go_assert eqEps t
-- | Asserts that the specified actual floating point value list is close to the expected value.
assertCloseList :: forall a. (AssertClose a, HasCallStack)
=> [a] -- ^ The expected value
-> [a] -- ^ The actual value
-> Assertion
assertCloseList expected actual =
go_assert expected actual
where
len1 :: Int = length expected
len2 :: Int = length actual
msgneq :: String = "expected " ++ show len1 ++ " elements, but got " ++ show len2
go_assert :: [a] -> [a] -> Assertion
go_assert [] [] = assertBool "" True
go_assert [] (_:_) = assertFailure msgneq
go_assert (_:_) [] = assertFailure msgneq
go_assert (head_exp:tail_exp) (head_act:tail_act) =
(@?~) head_act head_exp >> go_assert tail_exp tail_act
-- | Foldable to list.
asList :: Foldable t => t a -> [a]
asList = foldr (:) []
-- | Things that can be asserted to be "approximately equal" to each other. The
-- contract for this relation is that it must be reflexive and symmetrical,
-- but not necessarily transitive.
class AssertClose a where
-- | Makes an assertion that the actual value is close to the expected value.
(@?~) :: a -- ^ The actual value
-> a -- ^ The expected value
-> Assertion
instance {-# OVERLAPPABLE #-} (Fractional a, Ord a, Show a) => AssertClose a where
(@?~) :: a -> a -> Assertion
(@?~) actual expected =
assertClose "" expected actual
instance (AssertClose a) => AssertClose (a,a) where
(@?~) :: (a,a) -> (a,a) -> Assertion
(@?~) actual expected =
(@?~) (fst actual) (fst expected) >> (@?~) (snd actual) (snd expected)
instance {-# OVERLAPPABLE #-} (Traversable t, AssertClose a) => AssertClose (t a) where
(@?~) :: t a -> t a -> Assertion
(@?~) actual expected =
assertCloseList (asList expected) (asList actual)
instance {-# OVERLAPPABLE #-} (Traversable t, AssertClose a) => AssertClose (t a, a) where
(@?~) :: (t a, a) -> (t a, a) -> Assertion
(@?~) (actual_xs, actual_x) (expected_xs, expected_x) =
(@?~) actual_x expected_x >> assertCloseList (asList expected_xs) (asList actual_xs)
instance (VS.Storable a, AssertClose a) => AssertClose (VS.Vector a, a) where
(@?~) :: (VS.Vector a, a) -> (VS.Vector a, a) -> Assertion
(@?~) (actual_xs, actual_x) (expected_xs, expected_x) =
(@?~) actual_x expected_x >> assertCloseList (VG.toList expected_xs) (VG.toList actual_xs)
|
