From 7e5deed1cb3fafdd6eb035b3713ae2f46b67014a Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 8 Jun 2023 13:26:11 +0300
Bug: https://github.com/haskell/math-functions/pull/75
Signed-off-by: hololeap <hololeap@protonmail.com>
Subject: [PATCH] Fix test suite

QC as of 2.14.3. became much better at generating test cases and started
reliably failing Kahan summation

This was fixed by tweaking badvec to be just very bad. Not outrageously
bad.
---
 tests/Tests/Sum.hs | 72 +++++++++++++++++++++++++++-------------------
 1 file changed, 43 insertions(+), 29 deletions(-)

diff --git a/tests/Tests/Sum.hs b/tests/Tests/Sum.hs
index 08eaf1e..1fcb2e9 100644
--- a/tests/Tests/Sum.hs
+++ b/tests/Tests/Sum.hs
@@ -4,54 +4,68 @@ module Tests.Sum (tests) where
 
 import Control.Applicative ((<$>))
 import Numeric.Sum as Sum
+import Numeric.MathFunctions.Comparison
 import Prelude hiding (sum)
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.QuickCheck (testProperty)
+import Test.Tasty.QuickCheck
 import Test.QuickCheck (Arbitrary(..))
 import qualified Prelude
 
-t_sum :: ([Double] -> Double) -> [Double] -> Bool
-t_sum f xs = f xs == trueSum xs
-
-t_sum_error :: ([Double] -> Double) -> [Double] -> Bool
-t_sum_error f xs = abs (ts - f xs) <= abs (ts - Prelude.sum xs)
-  where ts = trueSum xs
-
-t_sum_shifted :: ([Double] -> Double) -> [Double] -> Bool
+-- Test that summation result is same as exact sum. That should pass
+-- if we're effectively working with quad precision
+t_sum :: ([Double] -> Double) -> [Double] -> Property
+t_sum f xs
+  = counterexample ("APPROX = " ++ show approx)
+  $ counterexample ("EXACT  = " ++ show exact)
+  $ counterexample ("DELTA  = " ++ show (approx - exact))
+  $ counterexample ("ULPS   = " ++ show (ulpDistance approx exact))
+  $ approx == exact
+  where
+    approx = f xs
+    exact  = trueSum xs
+
+-- Test that summation has smaller error than naive summation or no
+-- worse than given number of ulps. If we're close enough to exact
+-- answer naive may get ahead
+t_sum_error :: ([Double] -> Double) -> [Double] -> Property
+t_sum_error f xs
+  = counterexample ("APPROX  = " ++ show approx)
+  $ counterexample ("NAIVE   = " ++ show naive)
+  $ counterexample ("EXACT   = " ++ show exact)
+  $ counterexample ("A-EXACT = " ++ show (approx - exact))
+  $ counterexample ("N-EXACT = " ++ show (naive  - exact))
+  $ counterexample ("ULPS[A] = " ++ show (ulpDistance approx exact))
+  $ counterexample ("ULPS[N] = " ++ show (ulpDistance naive  exact))
+  $ abs (exact - approx) <= abs (exact - naive)
+  where
+    naive  = Prelude.sum xs
+    approx = f xs
+    exact  = trueSum xs
+
+t_sum_shifted :: ([Double] -> Double) -> [Double] -> Property
 t_sum_shifted f = t_sum_error f . zipWith (+) badvec
 
 trueSum :: (Fractional b, Real a) => [a] -> b
 trueSum xs = fromRational . Prelude.sum . map toRational $ xs
 
 badvec :: [Double]
-badvec = cycle [1,1e16,-1e16]
+badvec = cycle [1, 1e14, -1e14]
 
 tests :: TestTree
-tests = testGroup "Summation" [
-    testGroup "ID" [
-      -- plain summation loses precision quickly
-      -- testProperty "t_sum" $ t_sum (sum id)
-
-      -- tautological tests:
-      -- testProperty "t_sum_error" $ t_sum_error (sum id)
-      -- testProperty "t_sum_shifted" $ t_sum_shifted (sum id)
-    ]
-  , testGroup "Kahan" [
-      -- tests that cannot pass:
-      -- testProprty "t_sum" $ t_sum (sum kahan)
-      -- testProperty "t_sum_error" $ t_sum_error (sum kahan)
-
-      -- kahan summation only beats normal summation with large values
+tests = testGroup "Summation"
+  [ testGroup "Kahan" [
+      -- Kahan summation only beats naive summation when truly
+      -- catastrophic cancellation occurs
       testProperty "t_sum_shifted" $ t_sum_shifted (sum kahan)
     ]
   , testGroup "KBN" [
-      testProperty "t_sum" $ t_sum (sum kbn)
-    , testProperty "t_sum_error" $ t_sum_error (sum kbn)
+      testProperty "t_sum"         $ t_sum         (sum kbn)
+    , testProperty "t_sum_error"   $ t_sum_error   (sum kbn)
     , testProperty "t_sum_shifted" $ t_sum_shifted (sum kbn)
     ]
   , testGroup "KB2" [
-      testProperty "t_sum" $ t_sum (sum kb2)
-    , testProperty "t_sum_error" $ t_sum_error (sum kb2)
+      testProperty "t_sum"         $ t_sum         (sum kb2)
+    , testProperty "t_sum_error"   $ t_sum_error   (sum kb2)
     , testProperty "t_sum_shifted" $ t_sum_shifted (sum kb2)
     ]
   ]