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

@@ -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

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

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)

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