wip tests 1

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

@@ -25,7 +25,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,107 @@
+{-# LANGUAGE ViewPatterns #-}
+
 module Test.Data.List.ApplyMerge.New (tests) where
 
+import Control.Applicative (liftA2)
+import Data.Bifunctor (bimap)
+import Data.Function (on)
+import Data.List (sort)
+import Data.List qualified as List
+import Data.List.ApplyMerge (applyMerge, applyMergeBy, applyMergeOn)
+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 (getInfiniteList, (===), getNonNegative)
+import Test.Tasty.QuickCheck qualified as QC
 
 tests :: TestTree
 tests =
   testGroup
     "Data.List.ApplyMerge.New"
-    [ testCase "placeholder" ((1 :: Int) @?= 1)
+    [ testGroup
+        "List"
+        [ testApplyMerge applyMerge "applyMerge f xs ys" "f",
+          testGroup "applyMergeOn proj f xs ys" . List.singleton $
+            let applyMergeViaOn :: ApplyMerge
+                applyMergeViaOn f xs ys =
+                  map (uncurry f) (applyMergeOn (uncurry f) (,) xs ys)
+             in testApplyMerge applyMergeViaOn "f = (,)" "proj",
+          testGroup "applyMerge cmp f xs ys" . List.singleton $
+            testApplyMerge (applyMergeBy compare) "cmp = compare" "f"
+        ]
+    ]
+
+type ApplyMerge = forall a b c. (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+
+testApplyMerge :: ApplyMerge -> String -> String -> TestTree
+testApplyMerge am label funcLabel =
+  testGroup
+    label
+    [ testFunctions
+        ("increasing " <> funcLabel <> ", increasing xs and ys")
+        am
+        increasingNaturalFuncs
+        (+),
+      testFunctions
+        ("decreasing " <> funcLabel <> ", decreasing xs and ys")
+        am
+        decreasingIntegerFuncs
+        (-)
     ]
+
+testFunctions ::
+  forall a.
+  (Show a, Integral a, QC.Arbitrary a) =>
+  String ->
+  ApplyMerge ->
+  [(String, a -> a -> a)] ->
+  (a -> a -> a) ->
+  TestTree
+testFunctions label am funcs op =
+  QC.testProperty label $ do
+    (fName, f) <- QC.elements funcs
+    let limit = 100
+    let getOrderedList =
+          scanl1 op . map getNonNegative . either id getInfiniteList
+    pure . QC.counterexample fName $
+      \(getOrderedList -> xs) (getOrderedList -> ys) ->
+        let actual = am f xs ys
+            expected = sort $ on (liftA2 f) (take limit) xs ys
+         in on (===) (take limit) actual expected
+
+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