wip: Add new tests

apply-merge.cabal

@@ -83,6 +83,7 @@ test-suite apply-merge-tests
     , containers >=0.6 && <0.7 || >=0.7 && <0.8
     , data-ordlist ==0.4.*
     , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
+    , quickcheck-instances ==0.3.*
     , reflection ==2.1.*
     , tasty >=1.4 && <1.5 || >=1.5 && <1.6
     , tasty-expected-failure ==0.12.*

dev/test-suite.md

@@ -1,3 +1,8 @@
+<!--
+SPDX-FileCopyrightText: Copyright Preetham Gujjula
+SPDX-License-Identifier: BSD-3-Clause
+-->
+
 # Test suite for applyMerge implementations
 
 ## Things to test
@@ -25,7 +30,7 @@
   * function is constant in one or both inputs, or only increasing
     sometimes
 * a variety of integer functions
-* finite and infinite lists
+* a variety of finite and infinite lists
 * texts, where the function is lexicographic merging
 * input is not ordered, but is ordered according to function
 

package.yaml

@@ -71,6 +71,7 @@ tests:
     - containers ^>= {0.6, 0.7}
     - data-ordlist ^>= {0.4}
     - pqueue ^>= {1.4, 1.5}
+    - quickcheck-instances ^>= {0.3}
     - reflection ^>= {2.1}
     - tasty ^>= {1.4, 1.5}
     - tasty-expected-failure ^>= {0.12}

test/Main.hs

@@ -11,21 +11,22 @@ import Test.Data.DoublyLinkedList.STRef qualified (tests)
 import Test.Data.List.ApplyMerge qualified (tests)
 import Test.Data.List.ApplyMerge.New qualified (tests)
 import Test.Data.PQueue.Prio.Min.Mutable qualified (tests)
-import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty (TestTree, Timeout (Timeout), adjustOption, defaultMain, testGroup)
 
 main :: IO ()
 main = defaultMain tests
 
 tests :: TestTree
 tests =
-  testGroup
-    ""
-    [ Test.ApplyMerge.DoublyLinkedList.tests,
-      Test.ApplyMerge.IntMap.tests,
-      Test.ApplyMerge.IntSet.tests,
-      Test.ApplyMerge.MergeAll.tests,
-      Test.Data.List.ApplyMerge.tests,
-      Test.Data.List.ApplyMerge.New.tests,
-      Test.Data.DoublyLinkedList.STRef.tests,
-      Test.Data.PQueue.Prio.Min.Mutable.tests
-    ]
+  adjustOption (const (Timeout (10 ^ (7 :: Int)) "10s")) $
+    testGroup
+      ""
+      [ Test.ApplyMerge.DoublyLinkedList.tests,
+        Test.ApplyMerge.IntMap.tests,
+        Test.ApplyMerge.IntSet.tests,
+        Test.ApplyMerge.MergeAll.tests,
+        Test.Data.List.ApplyMerge.tests,
+        Test.Data.List.ApplyMerge.New.tests,
+        Test.Data.DoublyLinkedList.STRef.tests,
+        Test.Data.PQueue.Prio.Min.Mutable.tests
+      ]

test/Test/Data/List/ApplyMerge/New.hs

@@ -1,11 +1,191 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+--
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
 module Test.Data.List.ApplyMerge.New (tests) where
 
+#if !MIN_VERSION_base(4,18,0)
+import Control.Applicative (liftA2)
+#endif
+import Data.Bifunctor (bimap)
+import Data.Function (on)
+import Data.Kind (Type)
+import Data.List (sort)
+import Data.List qualified as List
+import Data.List.ApplyMerge (applyMerge, applyMergeBy, applyMergeOn)
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List.NonEmpty qualified as NE
+import Data.List.NonEmpty.ApplyMerge qualified as NE
+import Numeric.Natural (Natural)
+import Test.QuickCheck.Instances.Natural ()
+import Test.QuickCheck.Instances.Text ()
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (testCase, (@?=))
+import Test.Tasty.QuickCheck
+  ( InfiniteList,
+    getInfiniteList,
+    getNonNegative,
+    (===),
+  )
+import Test.Tasty.QuickCheck qualified as QC
 
 tests :: TestTree
 tests =
   testGroup
     "Data.List.ApplyMerge.New"
-    [ testCase "placeholder" ((1 :: Int) @?= 1)
+    [ genericTestApplyMerge
+        "List"
+        testListApplyMerge
+        (applyMerge, applyMergeOn, applyMergeBy),
+      genericTestApplyMerge
+        "NonEmpty"
+        testNonEmptyApplyMerge
+        (NE.applyMerge, NE.applyMergeOn, NE.applyMergeBy)
+    ]
+
+genericTestApplyMerge ::
+  forall f.
+  (Functor f) =>
+  String ->
+  (ApplyMerge f -> String -> String -> TestTree) ->
+  (ApplyMerge f, ApplyMergeOn f, ApplyMergeBy f) ->
+  TestTree
+genericTestApplyMerge label testAm (am, amOn, amBy) =
+  testGroup
+    label
+    [ testAm am "applyMerge f xs ys" "f",
+      testGroup "applyMergeOn proj f xs ys" . List.singleton $
+        let applyMergeViaOn :: ApplyMerge f
+            applyMergeViaOn f xs ys =
+              fmap (uncurry f) (amOn (uncurry f) (,) xs ys)
+         in testAm applyMergeViaOn "f = (,)" "proj",
+      testGroup "applyMergeBy cmp f xs ys" . List.singleton $
+        testAm (amBy compare) "cmp = compare" "f"
     ]
+
+type ApplyMerge f =
+  forall a b c. (Ord c) => (a -> b -> c) -> f a -> f b -> f c
+
+type ApplyMergeOn f =
+  forall a b c d. (Ord d) => (c -> d) -> (a -> b -> c) -> f a -> f b -> f c
+
+type ApplyMergeBy f =
+  forall a b c. (c -> c -> Ordering) -> (a -> b -> c) -> f a -> f b -> f c
+
+testNonEmptyApplyMerge :: ApplyMerge NonEmpty -> String -> String -> TestTree
+testNonEmptyApplyMerge = testGenericApplyMerge testNonEmptyFunctions
+
+testListApplyMerge :: ApplyMerge [] -> String -> String -> TestTree
+testListApplyMerge = testGenericApplyMerge testListFunctions
+
+type TestFunctions f =
+  forall a.
+  (Show a, Integral a, QC.Arbitrary a) =>
+  String ->
+  ApplyMerge f ->
+  [(String, a -> a -> a)] ->
+  (a -> a -> a) ->
+  TestTree
+
+testGenericApplyMerge ::
+  TestFunctions f -> ApplyMerge f -> String -> String -> TestTree
+testGenericApplyMerge testGenericFunctions am label funcLabel =
+  testGroup
+    label
+    [ testGenericFunctions
+        ("increasing " <> funcLabel <> ", increasing xs and ys")
+        am
+        increasingNaturalFuncs
+        (+),
+      testGenericFunctions
+        ("decreasing " <> funcLabel <> ", decreasing xs and ys")
+        am
+        decreasingIntegerFuncs
+        (-)
+    ]
+
+increasingNaturalFuncs :: [(String, Natural -> Natural -> Natural)]
+increasingNaturalFuncs =
+  let xs =
+        [ ("const", const),
+          ("min", min),
+          ("max", max),
+          ("(+)", (+)),
+          ("(\\x y -> 4 * x + y)", \x y -> 4 * x + y),
+          ("(*)", (*)),
+          ("(\\x y -> x ^ (3 :: Int) * y)", \x y -> x ^ (3 :: Int) * y),
+          ("(\\x y -> x * x + y * y)", \x y -> x * x + y * y),
+          ("(\\x y -> 4 * x * x + y * y)", \x y -> 4 * x * x + y * y),
+          ("(\\x _ -> x `quot` 5)", \x _ -> x `quot` 5),
+          ("(\\x y -> (x `quot` 5) + y)", \x y -> (x `quot` 5) + y),
+          ( "(\\x y -> (x `quot` 5) + (y `quot` 5))",
+            \x y -> (x `quot` 5) + (y `quot` 5)
+          )
+        ]
+   in xs ++ map (bimap ("flip " <>) flip) xs
+
+decreasingIntegerFuncs :: [(String, Integer -> Integer -> Integer)]
+decreasingIntegerFuncs =
+  let xs =
+        [ ("(\\x _ -> -x)", \x _ -> -x),
+          ("(\\x y -> -min x y)", \x y -> -min x y),
+          ("(\\x y -> -max x y)", \x y -> -max x y),
+          ("(\\x y -> -x - y)", \x y -> -x - y),
+          ("(\\x y -> -(4 * x) - y)", \x y -> -(4 * x) - y),
+          ("(\\x _ -> -(x `quot` 5))", \x _ -> -(x `quot` 5)),
+          ("(\\x y -> -(x `quot` 5) - y)", \x y -> -(x `quot` 5) - y),
+          ( "(\\x y -> -(x `quot` 5) - (y `quot` 5))",
+            \x y -> -(x `quot` 5) - (y `quot` 5)
+          )
+        ]
+   in xs ++ map (bimap ("flip " <>) flip) xs
+
+getOrderedList :: (a -> a -> a) -> PossiblyInfinite [QC.NonNegative a] -> [a]
+getOrderedList op = scanl1 op . map getNonNegative . getPossiblyInfinite
+
+getOrderedNonEmpty ::
+  (a -> a -> a) -> PossiblyInfinite (NonEmpty (QC.NonNegative a)) -> NonEmpty a
+getOrderedNonEmpty op =
+  NE.scanl1 op . NE.map QC.getNonNegative . getPossiblyInfinite
+
+testListFunctions :: TestFunctions []
+testListFunctions label am funcs op =
+  QC.testProperty label $ do
+    (fName, f) <- QC.elements funcs
+    let limit = 100
+    pure . QC.counterexample fName $
+      \(getOrderedList op -> xs) (getOrderedList op -> ys) ->
+        let actual = am f xs ys
+            expected = sort $ on (liftA2 f) (take limit) xs ys
+         in on (===) (take limit) actual expected
+
+testNonEmptyFunctions :: TestFunctions NonEmpty
+testNonEmptyFunctions label am funcs op =
+  QC.testProperty label $ do
+    (fName, f) <- QC.elements funcs
+    let limit = 100
+    pure . QC.counterexample fName $
+      \(getOrderedNonEmpty op -> xs) (getOrderedNonEmpty op -> ys) ->
+        let actual = am f xs ys
+            expected = NE.sort $ on (liftA2 f) (take1 limit) xs ys
+         in on (===) (NE.take limit) actual expected
+
+class HasPossiblyInfinite (a :: Type) where
+  type PossiblyInfinite a :: Type
+  getPossiblyInfinite :: PossiblyInfinite a -> a
+
+instance HasPossiblyInfinite [a] where
+  type PossiblyInfinite [a] = Either [a] (InfiniteList a)
+  getPossiblyInfinite = either id getInfiniteList
+
+instance HasPossiblyInfinite (NonEmpty a) where
+  type PossiblyInfinite (NonEmpty a) = (a, PossiblyInfinite [a])
+  getPossiblyInfinite (x, xs) = x :| getPossiblyInfinite xs
+
+-- Utilities
+take1 :: Int -> NonEmpty a -> NonEmpty a
+take1 n (x :| xs) = x :| take n xs