From b76fa1f1bbf739924911ae529d8355d81896ffc8 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 7 May 2021 21:52:23 +0300 Subject: [PATCH] Add Wicked example Also add identity and composition laws to Witherable test-suite. If Wicked test case is uncommented, it will fail with e.g. Depending on the order, different effects are performed, even the result is the same. composition: FAIL *** Failed! Falsified (after 10 tests and 47 shrinks): S 0 S 0 {_->(Nothing,S 1)} {(A (-9),S 0)->(Nothing,S 0), _->(Just (B 0),S 0)} W [A (-9),A 0] ((W [],S 0),S 0) /= ((W [],S 1),S 0) --- .github/workflows/haskell.yml | 4 +- witherable-class/witherable-class.cabal | 2 +- witherable/tests/tests.hs | 78 ++++++++++++++++++++++--- witherable/witherable.cabal | 2 +- 4 files changed, 75 insertions(+), 11 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 28df588..6d32af4 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -8,13 +8,13 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - ghc: [ '8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.3' ] + ghc: [ '8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.4', '9.0.1' ] steps: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} - cabal-version: '3.2' + cabal-version: '3.4' - name: cabal Cache uses: actions/cache@v1 diff --git a/witherable-class/witherable-class.cabal b/witherable-class/witherable-class.cabal index e3b299b..2f4a318 100644 --- a/witherable-class/witherable-class.cabal +++ b/witherable-class/witherable-class.cabal @@ -11,7 +11,7 @@ maintainer: fumiexcel@gmail.com copyright: Copyright (c) 2021 Fumiaki Kinoshita category: Data extra-source-files: CHANGELOG.md -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3 || ==9.0.1 source-repository head type: git diff --git a/witherable/tests/tests.hs b/witherable/tests/tests.hs index 87395ee..e54b22c 100644 --- a/witherable/tests/tests.hs +++ b/witherable/tests/tests.hs @@ -1,14 +1,19 @@ +{-# 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 (runState, state) +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, (===)) @@ -36,6 +41,7 @@ main = defaultMain $ testGroup "witherable" , filterableLaws (Proxy @IntMap.IntMap) , filterableLaws (Proxy @(Map.Map K)) , filterableLaws (Proxy @(HashMap.HashMap K)) + , filterableLaws (Proxy @Wicked) ] , testGroup "Witherable" @@ -44,9 +50,14 @@ main = defaultMain $ testGroup "witherable" , 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 @@ -118,26 +129,60 @@ 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 = - runState (wither f xs) s0 === runState (fmap catMaybes (traverse f xs)) s0 + 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 = - runState (witherM f xs) s0 === runState (wither f xs) s0 + 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 = - runState (filterA f xs) s0 === runState (wither (\a -> (\b -> if b then Just a else Nothing) <$> f a) xs) s0 + 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" ------------------------------------------------------------------------------- @@ -207,3 +252,22 @@ newtype S = S Int 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) diff --git a/witherable/witherable.cabal b/witherable/witherable.cabal index 5e40dfb..cd9c7a4 100644 --- a/witherable/witherable.cabal +++ b/witherable/witherable.cabal @@ -12,7 +12,7 @@ copyright: Copyright (c) 2014 Fumiaki Kinoshita category: Data build-type: Simple extra-source-files: CHANGELOG.md -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 source-repository head type: git