{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Main (main) where
import Control.Arrow (first)
import Control.Monad ((<=<))
import Control.Monad.Trans.State (State, runState, state)
import Data.Hashable (Hashable)
import Data.Coerce (coerce)
import Data.Function (on)
import Data.Functor.Compose (Compose (..))
import Data.List (nub, nubBy)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep)
import Test.QuickCheck (Arbitrary (..), Fun, Property, applyFun, Function (..), functionMap, CoArbitrary, (===))
import Test.QuickCheck.Instances ()
import Test.Tasty (defaultMain, testGroup, TestTree)
import Test.Tasty.QuickCheck (testProperty)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.IntMap as IntMap
import qualified Data.Map.Lazy as Map
import qualified Data.Vector as V
import qualified Data.Sequence as Seq
import Witherable
import Prelude hiding (filter)
main :: IO ()
main = defaultMain $ testGroup "witherable"
[ testGroup "Filterable"
[ filterableLaws (Proxy @[])
, filterableLaws (Proxy @Maybe)
, filterableLaws (Proxy @(Either String))
, filterableLaws (Proxy @V.Vector)
, filterableLaws (Proxy @Seq.Seq)
, filterableLaws (Proxy @IntMap.IntMap)
, filterableLaws (Proxy @(Map.Map K))
, filterableLaws (Proxy @(HashMap.HashMap K))
, filterableLaws (Proxy @Wicked)
]
, testGroup "Witherable"
[ witherableLaws (Proxy @[])
, witherableLaws (Proxy @Maybe)
, witherableLaws (Proxy @(Either String))
, witherableLaws (Proxy @V.Vector)
, witherableLaws (Proxy @Seq.Seq)
#if MIN_VERSION_containers(0,6,3)
-- traverse @IntMap is broken
, witherableLaws (Proxy @IntMap.IntMap)
#endif
, witherableLaws (Proxy @(Map.Map K))
, witherableLaws (Proxy @(HashMap.HashMap K))
-- Wicked is not Witherable, see https://github.com/fumieval/witherable/issues/63#issuecomment-834631975
-- , witherableLaws (Proxy @Wicked)
]
, nubProperties
]
-------------------------------------------------------------------------------
-- Filterable laws
-------------------------------------------------------------------------------
filterableLaws
:: forall f.
( Filterable f, Typeable f
, Arbitrary (f A), Show (f A), Eq (f A)
, Arbitrary (f (Maybe A)), Show (f (Maybe A))
, Show (f B), Eq (f B), Show (f C), Eq (f C)
)
=> Proxy f
-> TestTree
filterableLaws p = testGroup (show (typeRep p))
[ testProperty "conservation" prop_conservation
, testProperty "composition" prop_composition
, testProperty "default filter" prop_default_filter
, testProperty "default mapMaybe" prop_default_mapMaybe
, testProperty "default catMaybes" prop_default_catMaybes
]
where
prop_conservation :: Fun A B -> f A -> Property
prop_conservation f' xs =
mapMaybe (Just . f) xs === fmap f xs
where
f = applyFun f'
prop_composition :: Fun B (Maybe C) -> Fun A (Maybe B) -> f A -> Property
prop_composition f' g' xs =
mapMaybe f (mapMaybe g xs) === mapMaybe (f <=< g) xs
where
f = applyFun f'
g = applyFun g'
prop_default_filter :: Fun A Bool -> f A -> Property
prop_default_filter f' xs =
filter f xs === mapMaybe (\a -> if f a then Just a else Nothing) xs
where
f = applyFun f'
prop_default_mapMaybe :: Fun A (Maybe B) -> f A -> Property
prop_default_mapMaybe f' xs =
mapMaybe f xs === catMaybes (fmap f xs)
where
f = applyFun f'
prop_default_catMaybes :: f (Maybe A) -> Property
prop_default_catMaybes xs = catMaybes xs === mapMaybe id xs
-------------------------------------------------------------------------------
-- Witherable laws
-------------------------------------------------------------------------------
witherableLaws
:: forall f.
( Witherable f, Typeable f
, Arbitrary (f A), Show (f A), Eq (f A)
, Arbitrary (f (Maybe A)), Show (f (Maybe A))
, Show (f B), Eq (f B), Show (f C), Eq (f C)
)
=> Proxy f
-> TestTree
witherableLaws p = testGroup (show (typeRep p))
[ testProperty "default wither" prop_default_wither
, testProperty "default witherM" prop_default_witherM
, testProperty "default filterA" prop_default_filterA
, testProperty "identity" prop_identity
, testProperty "composition" prop_composition
]
where
prop_default_wither :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property
prop_default_wither s0 f' xs = equalState s0 xs
(wither f)
(fmap catMaybes . traverse f)
where
f :: A -> State S (Maybe B)
f a = state $ \s -> applyFun f' (a, s)
prop_default_witherM :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property
prop_default_witherM s0 f' xs = equalState s0 xs
(witherM f)
(wither f)
where
f a = state $ \s -> applyFun f' (a, s)
prop_default_filterA :: S -> Fun (A, S) (Bool, S) -> f A -> Property
prop_default_filterA s0 f' xs = equalState s0 xs
(filterA f)
(wither (\a -> (\b -> if b then Just a else Nothing) <$> f a))
where
f a = state $ \s -> applyFun f' (a, s)
prop_identity :: S -> Fun (A, S) (B, S) -> f A -> Property
prop_identity s0 f' xs = equalState s0 xs
(wither (fmap Just . f))
(traverse f)
where
f a = state $ \s -> applyFun f' (a, s)
prop_composition :: S -> S -> Fun (B, S) (Maybe C, S) -> Fun (A, S) (Maybe B, S) -> f A -> Property
prop_composition s0 s1 f' g' xs = equalStateC s0 s1 xs
(Compose . fmap (wither f) . wither g)
(wither (Compose . fmap (wither f) . g))
where
f a = state $ \s -> applyFun f' (a, s)
g b = state $ \s -> applyFun g' (b, s)
equalState
:: (Eq b, Show b)
=> S -> a -> (a -> State S b) -> (a -> State S b) -> Property
equalState s0 xs f g = runState (f xs) s0 === runState (g xs) s0
equalStateC
:: forall a b. (Eq b, Show b)
=> S -> S -> a -> (a -> Compose (State S) (State S) b) -> (a -> Compose (State S) (State S) b) -> Property
equalStateC s0 s1 xs f g = run (f xs) === run (g xs)
where
run :: Compose (State S) (State S) b -> ((b, S), S)
run m = first (\x -> runState x s1) (runState (getCompose m) s0)
-------------------------------------------------------------------------------
-- Nub "laws"
-------------------------------------------------------------------------------
nubProperties :: TestTree
nubProperties = testGroup "nub"
[ testProperty "ordNub" prop_ordNub
, testProperty "ordNubOn" prop_ordNubOn
, testProperty "hashNub" prop_hashNub
, testProperty "hashNubOn" prop_hashNubOn
, testProperty "ordNub is lazy" prop_lazy_ordNub
, testProperty "hashNub is lazy" prop_lazy_hashNub
]
where
prop_ordNub :: [A] -> Property
prop_ordNub xs = nub xs === ordNub xs
prop_hashNub :: [A] -> Property
prop_hashNub xs = nub xs === hashNub xs
prop_ordNubOn :: Fun A B -> [A] -> Property
prop_ordNubOn f' xs = nubBy ((==) `on` f) xs === ordNubOn f xs
where
f = applyFun f'
prop_hashNubOn :: Fun A B -> [A] -> Property
prop_hashNubOn f' xs = nubBy ((==) `on` f) xs === hashNubOn f xs
where
f = applyFun f'
prop_lazy_ordNub :: Property
prop_lazy_ordNub = take 3 (ordNub ('x' : 'y' : 'z' : 'z' : error "bottom")) === "xyz"
prop_lazy_hashNub :: Property
prop_lazy_hashNub = take 3 (hashNub ('x' : 'y' : 'z' : 'z' : error "bottom")) === "xyz"
-------------------------------------------------------------------------------
-- "Poly"
-------------------------------------------------------------------------------
newtype A = A Int
deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)
instance Function A where
function = functionMap coerce A
newtype B = B Int
deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)
instance Function B where
function = functionMap coerce B
newtype C = C Int
deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)
instance Function C where
function = functionMap coerce C
newtype K = K Int
deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)
instance Function K where
function = functionMap coerce K
newtype S = S Int
deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)
instance Function S where
function = functionMap coerce S
-------------------------------------------------------------------------------
-- Wicked
-------------------------------------------------------------------------------
newtype Wicked a = W [a]
deriving (Eq, Show, Functor, Foldable, Traversable)
instance Filterable Wicked where
-- mapMaybe f (W [a1,a2,...]) = W [b1, b2, ...]
-- if all of [f a1, f a2, ...] are Just. Otherwise, it returns (W []).
mapMaybe f = fromMaybe (W []) . traverse f
-- default implementation in terms of Filterable
instance Witherable Wicked
instance Arbitrary a => Arbitrary (Wicked a) where
arbitrary = W <$> arbitrary
shrink (W xs) = map W (shrink xs)