{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if MIN_VERSION_base(4,18,0)
# define HAS_FOLDABLE1_CONTAINERS MIN_VERSION_containers(0,6,7)
# define HAS_FOLDABLE1_TRANSFORMERS MIN_VERSION_transformers(0,6,1)
#else
# define HAS_FOLDABLE1_CONTAINERS 1
# define HAS_FOLDABLE1_TRANSFORMERS 1
#endif
module Main (main) where
import Prelude hiding (foldl1, foldr1, head, last, maximum, minimum)
import Data.Functor.Compose (Compose (..))
import Data.Functor.Identity (Identity (..))
import Data.Functor.Product (Product (..))
import Data.Functor.Sum (Sum (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup
(First (..), Last (..), Max (..), Min (..), Semigroup (..))
import Test.Framework.Providers.API (Test, TestName, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.Framework.Runners.Console (defaultMain)
import Test.QuickCheck
(Arbitrary, Fun, Property, Testable, applyFun, applyFun2, counterexample,
mapSize, (===))
import Test.QuickCheck.Poly (A, B, OrdA)
import Test.QuickCheck.Instances ()
import qualified Data.Foldable as F (Foldable (foldMap))
import Data.Foldable (toList)
import Data.Foldable1
#if HAS_FOLDABLE1_CONTAINERS
import Data.Tree (Tree (..))
#endif
#if HASH_FOLDABLE1_TRANSFORMERS
import Data.Functor.Reverse (Reverse (..))
#endif
main :: IO ()
main = defaultMain
[ foldable1tests "NonEmpty" (P1 :: P1 NonEmpty)
, foldable1tests "foldMap1" (P1 :: P1 NE1)
, foldable1tests "foldrMap1" (P1 :: P1 NE3)
#if HAS_FOLDABLE1_CONTAINERS
, foldable1tests "Tree" (P1 :: P1 Tree)
#endif
, foldable1tests "Identity" (P1 :: P1 Identity)
, foldable1tests "Compose" (P1 :: P1 (Compose NonEmpty NonEmpty))
, foldable1tests "Product" (P1 :: P1 (Product NonEmpty NonEmpty))
#if HASH_FOLDABLE1_TRANSFORMERS
, foldable1tests "Reverse" (P1 :: P1 (Reverse NonEmpty))
#endif
, foldable1tests "Sum" (P1 :: P1 (Sum NonEmpty NonEmpty))
]
-------------------------------------------------------------------------------
-- tests
-------------------------------------------------------------------------------
foldable1tests
:: forall f.
( Foldable1 f
, Arbitrary (f A), Show (f A)
, Arbitrary (f OrdA), Show (f OrdA)
, Arbitrary (f B), Show (f B)
, Arbitrary (f [B]), Show (f [B])
)
=> TestName
-> P1 f
-> Test
foldable1tests name _p = testGroup name
[ testProperty "foldMap1 ~= foldMap" coherentFoldMap
, testProperty "toList . toNonEmpty ~= toList" coherentToNonEmpty
, testProperty "foldl1 non/strict" $ smaller strictFoldl1
, testProperty "foldr1 non/strict" $ smaller strictFoldr1
, testProperty "foldlMap1 non/strict" $ smaller strictFoldl1Map
, testProperty "foldrMap1 non/strict" $ smaller strictFoldr1Map
-- test against default implementations
, testProperty "foldMap1 default" defaultFoldMap
, testProperty "foldrMap1 default" $ smaller defaultFoldr1Map
, testProperty "foldlMap1 default" $ smaller defaultFoldl1Map
, testProperty "toNonEmpty default" defaultToNonEmpty
, testProperty "head default" defaultHead
, testProperty "last default" defaultLast
, testProperty "minimum default" defaultMinimum
, testProperty "maximum default" defaultMaximum
-- if we first convert to nonEmpty it should be the same
, testProperty "foldMap via toNonEmpty" viaFoldMap
, testProperty "foldr1 via toNonEmpty" $ smaller viaFoldr1
, testProperty "foldl1 via toNonEmpty" $ smaller viaFoldl1
, testProperty "foldr1' via toNonEmpty" $ smaller viaFoldr1'
, testProperty "foldl1' via toNonEmpty" $ smaller viaFoldl1'
, testProperty "head via toNonEmpty" viaHead
, testProperty "last via toNonEmpty" viaLast
, testProperty "minimum via toNonEmpty" viaMinimum
, testProperty "maximum via toNonEmpty" viaMaximum
]
where
-- Things like Compose NonEmpty NonEmpty are big
smaller :: Testable prop => prop -> Property
smaller = mapSize (`div` 3)
coherentFoldMap :: f A -> Fun A [B] -> Property
coherentFoldMap xs f' = F.foldMap f xs === foldMap1 f xs where
f = applyFun f'
coherentToNonEmpty :: f A -> Property
coherentToNonEmpty xs = toList (toNonEmpty xs) === toList xs
strictFoldr1 :: f [B] -> Fun ([B], [B]) [B] -> Property
strictFoldr1 xs g' = foldr1 g xs === foldr1' g xs where
g = applyFun2 g'
strictFoldl1 :: f [B] -> Fun ([B], [B]) [B] -> Property
strictFoldl1 xs g' = foldl1 g xs === foldl1' g xs where
g = applyFun2 g'
strictFoldr1Map :: f A -> Fun A B -> Fun (A, B) B -> Property
strictFoldr1Map xs f' g' = foldrMap1 f g xs === foldrMap1' f g xs where
f = applyFun f'
g = applyFun2 g'
strictFoldl1Map :: f A -> Fun A B -> Fun (B, A) B -> Property
strictFoldl1Map xs f' g' = foldlMap1 f g xs === foldlMap1' f g xs where
f = applyFun f'
g = applyFun2 g'
defaultFoldMap :: f A -> Fun A [B] -> Property
defaultFoldMap xs f' = F.foldMap f xs === foldrMap1 f (\a m -> f a Data.Semigroup.<> m) xs where
f = applyFun f'
defaultFoldr1Map :: f A -> Fun A [B] -> Fun (A, [B]) [B] -> Property
defaultFoldr1Map xs f' g'
= counterexample ("NE: " ++ show ys)
$ foldrMap1 f g xs === foldrMap1 f g ys
where
f = applyFun f'
g = applyFun2 g'
ys = toNonEmpty xs
defaultFoldl1Map :: f A -> Fun A [B] -> Fun ([B], A) [B] -> Property
defaultFoldl1Map xs f' g'
= counterexample ("NE: " ++ show ys)
$ foldlMap1 f g xs === foldlMap1 f g ys
where
f = applyFun f'
g = applyFun2 g'
ys = toNonEmpty xs
defaultToNonEmpty :: f A -> Property
defaultToNonEmpty xs = toNonEmpty xs === foldMap1 (:|[]) xs
defaultHead :: f A -> Property
defaultHead xs = head xs === getFirst (foldMap1 First xs)
defaultLast :: f A -> Property
defaultLast xs = last xs === getLast (foldMap1 Last xs)
defaultMinimum :: f OrdA -> Property
defaultMinimum xs = minimum xs === getMin (foldMap1 Min xs)
defaultMaximum :: f OrdA -> Property
defaultMaximum xs = maximum xs === getMax (foldMap1 Max xs)
viaFoldMap :: f A -> Fun A [B] -> Property
viaFoldMap xs f' = F.foldMap f xs === F.foldMap f (toNonEmpty xs) where
f = applyFun f'
viaFoldr1 :: f [B] -> Fun ([B],[B]) [B] -> Property
viaFoldr1 xs g' = foldr1 g xs === foldr1 g (toNonEmpty xs) where
g = applyFun2 g'
viaFoldr1' :: f [B] -> Fun ([B],[B]) [B] -> Property
viaFoldr1' xs g' = foldr1' g xs === foldr1' g (toNonEmpty xs) where
g = applyFun2 g'
viaFoldl1 :: f [B] -> Fun ([B],[B]) [B] -> Property
viaFoldl1 xs g' = foldl1 g xs === foldl1 g (toNonEmpty xs) where
g = applyFun2 g'
viaFoldl1' :: f [B] -> Fun ([B],[B]) [B] -> Property
viaFoldl1' xs g' = foldl1' g xs === foldl1' g (toNonEmpty xs) where
g = applyFun2 g'
viaHead :: f A -> Property
viaHead xs = head xs === head (toNonEmpty xs)
viaLast :: f A -> Property
viaLast xs = last xs === last (toNonEmpty xs)
viaMinimum :: f OrdA -> Property
viaMinimum xs = minimum xs === minimum (toNonEmpty xs)
viaMaximum :: f OrdA -> Property
viaMaximum xs = maximum xs === maximum (toNonEmpty xs)
-------------------------------------------------------------------------------
-- NonEmpty variants
-------------------------------------------------------------------------------
-- Using foldMap1 to define Foldable1
newtype NE1 a = NE1 (NonEmpty a)
deriving (Eq, Show, Functor, F.Foldable, Arbitrary)
instance Foldable1 NE1 where
foldMap1 f (NE1 xs) = foldMap1 f xs
-- Using foldrMap1 to define Foldable1
newtype NE3 a = NE3 (NonEmpty a)
deriving (Eq, Show, Functor, F.Foldable, Arbitrary)
instance Foldable1 NE3 where
foldrMap1 g f (NE3 xs) = foldrMap1 g f xs
-------------------------------------------------------------------------------
-- utilities
-------------------------------------------------------------------------------
-- Proxy of right kind
data P1 f
= P1
| Unused (f Int)
_unused :: P1 []
_unused = Unused []