diff --git a/test/Test/Data/List/ApplyMerge/New.hs b/test/Test/Data/List/ApplyMerge/New.hs index b89d2ea..abc1f0c 100644 --- a/test/Test/Data/List/ApplyMerge/New.hs +++ b/test/Test/Data/List/ApplyMerge/New.hs @@ -3,16 +3,20 @@ module Test.Data.List.ApplyMerge.New (tests) where import Control.Applicative (liftA2) -import Data.Bifunctor (bimap) +import Control.Arrow ((>>>)) +import Data.Bifunctor (bimap, second) import Data.Function (on) 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.QuickCheck (getInfiniteList, (===), getNonNegative) +import Test.Tasty.QuickCheck (getInfiniteList, getNonNegative, (===)) import Test.Tasty.QuickCheck qualified as QC tests :: TestTree @@ -29,11 +33,46 @@ tests = in testApplyMerge applyMergeViaOn "f = (,)" "proj", testGroup "applyMerge cmp f xs ys" . List.singleton $ testApplyMerge (applyMergeBy compare) "cmp = compare" "f" + ], + testGroup + "NonEmpty" + [ testNEApplyMerge NE.applyMerge "applyMerge f xs ys" "f", + testGroup "applyMergeOn proj f xs ys" . List.singleton $ + let applyMergeViaOn :: NEApplyMerge + applyMergeViaOn f xs ys = + NE.map (uncurry f) (NE.applyMergeOn (uncurry f) (,) xs ys) + in testNEApplyMerge applyMergeViaOn "f = (,)" "proj", + testGroup "applyMerge cmp f xs ys" . List.singleton $ + testNEApplyMerge (NE.applyMergeBy compare) "cmp = compare" "f" ] ] type ApplyMerge = forall a b c. (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c] +type NEApplyMerge = + forall a b c. + (Ord c) => + (a -> b -> c) -> + NonEmpty a -> + NonEmpty b -> + NonEmpty c + +testNEApplyMerge :: NEApplyMerge -> String -> String -> TestTree +testNEApplyMerge am label funcLabel = + testGroup + label + [ testNEFunctions + ("increasing " <> funcLabel <> ", increasing xs and ys") + am + increasingNaturalFuncs + (+), + testNEFunctions + ("decreasing " <> funcLabel <> ", decreasing xs and ys") + am + decreasingIntegerFuncs + (-) + ] + testApplyMerge :: ApplyMerge -> String -> String -> TestTree testApplyMerge am label funcLabel = testGroup @@ -50,6 +89,37 @@ testApplyMerge am label funcLabel = (-) ] +testNEFunctions :: + forall a. + (Show a, Integral a, QC.Arbitrary a) => + String -> + NEApplyMerge -> + [(String, a -> a -> a)] -> + (a -> a -> a) -> + TestTree +testNEFunctions label am funcs op = + QC.testProperty label $ do + (fName, f) <- QC.elements funcs + let limit = 100 + let getOrderedList :: + ( QC.NonNegative a, + Either [QC.NonNegative a] (QC.InfiniteList (QC.NonNegative a)) + ) -> + NonEmpty a + getOrderedList = + second (either id getInfiniteList) + >>> uncurry (:|) + >>> NE.map QC.getNonNegative + >>> NE.scanl1 op + pure . QC.counterexample fName $ + \(getOrderedList -> xs) (getOrderedList -> ys) -> + let actual = am f xs ys + expected = NE.sort $ on (liftA2 f) (take1 limit) xs ys + in on (===) (NE.take limit) actual expected + +take1 :: Int -> NonEmpty a -> NonEmpty a +take1 n (x :| xs) = x :| take n xs + testFunctions :: forall a. (Show a, Integral a, QC.Arbitrary a) =>