diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 0.0.1.9 + +- Added the following traversal functions to `MonoidMap`: + - `traverse` + - `traverseWithKey` + - `mapAccumL` + - `mapAccumLWithKey` + - `mapAccumR` + - `mapAccumRWithKey` + # 0.0.1.8 - Added strict variant of the `foldMapWithKey` function. diff --git a/monoidmap.cabal b/monoidmap.cabal --- a/monoidmap.cabal +++ b/monoidmap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: monoidmap -version: 0.0.1.8 +version: 0.0.1.9 bug-reports: https://github.com/jonathanknowles/monoidmap/issues license: Apache-2.0 license-file: LICENSE @@ -168,6 +168,7 @@ Data.MonoidMap.MembershipSpec Data.MonoidMap.SingletonSpec Data.MonoidMap.SliceSpec + Data.MonoidMap.TraversalSpec Data.MonoidMap.PrefixSpec Data.MonoidMap.SuffixSpec Data.MonoidMap.IntersectionSpec diff --git a/src/benchmark/Main.hs b/src/benchmark/Main.hs --- a/src/benchmark/Main.hs +++ b/src/benchmark/Main.hs @@ -2,6 +2,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NumericUnderscores #-} +-- Benchmark for the `MonoidMap` type. +-- +-- Instead of benchmarking functions for the `MonoidMap` type directly, we +-- benchmark functions for the `RecoveredMap` type, a newtype wrapper around +-- the `MonoidMap` type designed to provide the same semantics as `Map`. +-- module Main where import Control.DeepSeq @@ -23,7 +29,7 @@ import Data.Semigroup ( Semigroup ((<>)), stimes ) import Prelude - ( Integer, Num, (^) ) + ( Integer, Num, (^), (+) ) import System.IO ( IO ) import Test.Tasty.Bench @@ -51,13 +57,13 @@ [ bgroup "absent" [ bench "Data.Map.Strict" $ nf (deleteMany evens) om_odd - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (deleteMany evens) rm_odd ] , bgroup "present" [ bench "Data.Map.Strict" $ nf (deleteMany evens) om_even - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (deleteMany evens) rm_even ] ] @@ -65,13 +71,13 @@ [ bgroup "absent" [ bench "Data.Map.Strict" $ nf (insertMany elems_even) om_odd - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (insertMany elems_even) rm_odd ] , bgroup "present" [ bench "Data.Map.Strict" $ nf (insertMany elems_even) om_even - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (insertMany elems_even) rm_even ] ] @@ -79,13 +85,13 @@ [ bgroup "absent" [ bench "Data.Map.Strict" $ nf (lookupMany evens) om_odd - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (lookupMany evens) rm_odd ] , bgroup "present" [ bench "Data.Map.Strict" $ nf (lookupMany evens) om_even - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (lookupMany evens) rm_even ] ] @@ -93,22 +99,46 @@ [ bgroup "disjoint" [ bench "Data.Map.Strict" $ nf (<> om_even) om_odd - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (<> rm_even) rm_odd ] , bgroup "identical" [ bench "Data.Map.Strict" $ nf (<> om_even) om_even - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (<> rm_even) rm_even ] ] , bgroup "stimes" [ bench "Data.Map.Strict" $ nf (stimes ten_power_24) om_natural - , bench "Data.MonoidMap" $ + , bench "RecoveredMap" $ nf (stimes ten_power_24) rm_natural ] + , bgroup "mapAccumL" + [ bench "Data.Map.Strict" $ + nf (mapAccumL (\s v -> (s + v, v)) 0) om_natural + , bench "RecoveredMap" $ + nf (mapAccumL (\s v -> (s + v, v)) 0) rm_natural + ] + , bgroup "mapAccumR" + [ bench "Data.Map.Strict" $ + nf (mapAccumR (\s v -> (s + v, v)) 0) om_natural + , bench "RecoveredMap" $ + nf (mapAccumR (\s v -> (s + v, v)) 0) rm_natural + ] + , bgroup "mapAccumLWithKey" + [ bench "Data.Map.Strict" $ + nf (mapAccumL (\s v -> (s + v, v)) 0) om_natural + , bench "RecoveredMap" $ + nf (mapAccumL (\s v -> (s + v, v)) 0) rm_natural + ] + , bgroup "mapAccumRWithKey" + [ bench "Data.Map.Strict" $ + nf (mapAccumRWithKey (\s k v -> (s + k + v, v)) 0) om_natural + , bench "RecoveredMap" $ + nf (mapAccumRWithKey (\s k v -> (s + k + v, v)) 0) rm_natural + ] ] where bound :: Int @@ -140,18 +170,30 @@ delete :: k -> m k v -> m k v insert :: k -> v -> m k v -> m k v lookup :: k -> m k v -> Maybe v + mapAccumL :: (s -> v -> (s, v)) -> s -> m k v -> (s, m k v) + mapAccumR :: (s -> v -> (s, v)) -> s -> m k v -> (s, m k v) + mapAccumLWithKey :: (s -> k -> v -> (s, v)) -> s -> m k v -> (s, m k v) + mapAccumRWithKey :: (s -> k -> v -> (s, v)) -> s -> m k v -> (s, m k v) instance Ord k => Map OMap.Map k v where fromList = OMap.fromList delete = OMap.delete insert = OMap.insert lookup = OMap.lookup + mapAccumL = OMap.mapAccum + mapAccumR f = OMap.mapAccumRWithKey (\s _ v -> f s v) + mapAccumLWithKey = OMap.mapAccumWithKey + mapAccumRWithKey = OMap.mapAccumRWithKey instance (Ord k, Eq v) => Map RMap.Map k v where fromList = RMap.fromList delete = RMap.delete insert = RMap.insert lookup = RMap.lookup + mapAccumL = RMap.mapAccumL + mapAccumR = RMap.mapAccumR + mapAccumLWithKey = RMap.mapAccumLWithKey + mapAccumRWithKey = RMap.mapAccumRWithKey deleteMany :: (Map m k v, Num v) => [k] -> m k v -> m k v deleteMany xs m = foldl' (flip delete) m xs diff --git a/src/examples/Examples/RecoveredMap.hs b/src/examples/Examples/RecoveredMap.hs --- a/src/examples/Examples/RecoveredMap.hs +++ b/src/examples/Examples/RecoveredMap.hs @@ -8,10 +8,27 @@ -- An ordinary left-biased map similar to 'Map', implemented in terms of -- 'MonoidMap'. -- -module Examples.RecoveredMap where +module Examples.RecoveredMap + ( Map + , empty + , singleton + , fromList + , toList + , delete + , insert + , keysSet + , lookup + , member + , map + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey + ) + where import Prelude hiding - ( map ) + ( lookup, map ) import Control.DeepSeq ( NFData ) @@ -74,3 +91,31 @@ map :: (v1 -> v2) -> Map k v1 -> Map k v2 map f = Map . MonoidMap.map (fmap f) . unMap + +mapAccumL :: (s -> v1 -> (s, v2)) -> s -> Map k v1 -> (s, Map k v2) +mapAccumL f s m = Map <$> MonoidMap.mapAccumL (accum f) s (unMap m) + +mapAccumR :: (s -> v1 -> (s, v2)) -> s -> Map k v1 -> (s, Map k v2) +mapAccumR f s m = Map <$> MonoidMap.mapAccumR (accum f) s (unMap m) + +mapAccumLWithKey :: (s -> k -> v1 -> (s, v2)) -> s -> Map k v1 -> (s, Map k v2) +mapAccumLWithKey f s m = + Map <$> MonoidMap.mapAccumLWithKey (accumWithKey f) s (unMap m) + +mapAccumRWithKey :: (s -> k -> v1 -> (s, v2)) -> s -> Map k v1 -> (s, Map k v2) +mapAccumRWithKey f s m = + Map <$> MonoidMap.mapAccumRWithKey (accumWithKey f) s (unMap m) + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +accum :: (s -> v1 -> (s, v2)) -> s -> First v1 -> (s, First v2) +accum f s1 (First mv1) = case mv1 of + Just v1 -> let (s2, v2) = f s1 v1 in (s2, First (Just v2)) + Nothing -> (s1, First Nothing) + +accumWithKey :: (s -> k -> v1 -> (s, v2)) -> s -> k -> First v1 -> (s, First v2) +accumWithKey f s1 k (First mv1) = case mv1 of + Just v1 -> let (s2, v2) = f s1 k v1 in (s2, First (Just v2)) + Nothing -> (s1, First Nothing) diff --git a/src/internal/Data/MonoidMap/Internal.hs b/src/internal/Data/MonoidMap/Internal.hs --- a/src/internal/Data/MonoidMap/Internal.hs +++ b/src/internal/Data/MonoidMap/Internal.hs @@ -67,18 +67,24 @@ -- ** Folding , foldl - , foldr - , foldlWithKey - , foldrWithKey - , foldMapWithKey - - -- *** Strict folding , foldl' + , foldr , foldr' + , foldlWithKey , foldlWithKey' + , foldrWithKey , foldrWithKey' + , foldMapWithKey , foldMapWithKey' + -- ** Traversal + , traverse + , traverseWithKey + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey + -- * Monoidal operations -- ** Association @@ -143,8 +149,11 @@ , splitAt , subtract , take + , traverse ) +import Control.Applicative + ( Applicative (..) ) import Control.DeepSeq ( NFData ) import Data.Bifoldable @@ -206,6 +215,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified GHC.Exts as GHC +import qualified Data.Traversable as Traversable import qualified Data.Group as C import qualified Data.Monoid.GCD as C @@ -225,6 +235,9 @@ deriving (Eq2, Show2, Bifoldable) via Map +-- Internal alias used when extra brevity is required. +type MM = MonoidMap + -------------------------------------------------------------------------------- -- Non-null values -------------------------------------------------------------------------------- @@ -1155,6 +1168,158 @@ {-# INLINE foldMapWithKey' #-} -------------------------------------------------------------------------------- +-- Traversal +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Traverses over the values of a map using the given function. +-- +-- Satisfies the following property: +-- +-- @ +-- 'traverse' f m '==' +-- 'fmap' 'fromMap' ('Traversable'.'Traversable.traverse' f ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +traverse + :: Applicative t + => MonoidNull v2 + => (v1 -> t v2) + -> MonoidMap k v1 + -> t (MonoidMap k v2) +traverse f = traverseWithKey (const f) +{-# INLINE traverse #-} + +-- | \(O(n)\). Traverses over the keys and values of a map using the given +-- function. +-- +-- Satisfies the following property: +-- +-- @ +-- 'traverseWithKey' f m '==' +-- 'fmap' 'fromMap' ('Map'.'Map.traverseWithKey' f ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +traverseWithKey + :: Applicative t + => MonoidNull v2 + => (k -> v1 -> t v2) + -> MonoidMap k v1 + -> t (MonoidMap k v2) +traverseWithKey f (MonoidMap m) = + MonoidMap <$> + Map.traverseMaybeWithKey + (\k v -> maybeNonNull <$> applyNonNull (f k) v) m +{-# INLINE traverseWithKey #-} + +-- | \(O(n)\). Threads an accumulating argument through the map in ascending +-- order of keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'mapAccumL' f s m '==' +-- 'fmap' 'fromMap' ('Traversable'.'Traversable.mapAccumL' f s ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +mapAccumL + :: MonoidNull v2 + => (s -> v1 -> (s, v2)) + -> s + -> MonoidMap k v1 + -> (s, MonoidMap k v2) +mapAccumL f s m = + (coerce + :: ((v1 -> StateL s v2 ) -> MM k v1 -> StateL s (MM k v2)) + -> ((v1 -> s -> (s, v2)) -> MM k v1 -> s -> (s, MM k v2)) + ) + traverse (flip f) m s +{-# INLINE mapAccumL #-} + +-- | \(O(n)\). Threads an accumulating argument through the map in descending +-- order of keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'mapAccumR' f s m '==' +-- 'fmap' 'fromMap' ('Traversable'.'Traversable.mapAccumR' f s ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +mapAccumR + :: MonoidNull v2 + => (s -> v1 -> (s, v2)) + -> s + -> MonoidMap k v1 + -> (s, MonoidMap k v2) +mapAccumR f s m = + (coerce + :: ((v1 -> StateR s v2 ) -> MM k v1 -> StateR s (MM k v2)) + -> ((v1 -> s -> (s, v2)) -> MM k v1 -> s -> (s, MM k v2)) + ) + traverse (flip f) m s +{-# INLINE mapAccumR #-} + +-- | \(O(n)\). Threads an accumulating argument through the map in ascending +-- order of keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'mapAccumLWithKey' f s m '==' +-- 'fmap' 'fromMap' ('Map'.'Map.mapAccumWithKey' f s ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +mapAccumLWithKey + :: MonoidNull v2 + => (s -> k -> v1 -> (s, v2)) + -> s + -> MonoidMap k v1 + -> (s, MonoidMap k v2) +mapAccumLWithKey f s0 m = + (coerce + :: ((k -> v1 -> StateL s v2 ) -> MM k v1 -> StateL s (MM k v2)) + -> ((k -> v1 -> s -> (s, v2)) -> MM k v1 -> s -> (s, MM k v2)) + ) + traverseWithKey (\k v1 s -> f s k v1) m s0 +{-# INLINE mapAccumLWithKey #-} + +-- | \(O(n)\). Threads an accumulating argument through the map in descending +-- order of keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'mapAccumRWithKey' f s m '==' +-- 'fmap' 'fromMap' ('Map'.'Map.mapAccumRWithKey' f s ('toMap' m)) +-- @ +-- +-- @since 0.0.1.9 +-- +mapAccumRWithKey + :: MonoidNull v2 + => (s -> k -> v1 -> (s, v2)) + -> s + -> MonoidMap k v1 + -> (s, MonoidMap k v2) +mapAccumRWithKey f s0 m = + (coerce + :: ((k -> v1 -> StateR s v2 ) -> MM k v1 -> StateR s (MM k v2)) + -> ((k -> v1 -> s -> (s, v2)) -> MM k v1 -> s -> (s, MM k v2)) + ) + traverseWithKey (\k v1 s -> f s k v1) m s0 +{-# INLINE mapAccumRWithKey #-} + +-------------------------------------------------------------------------------- -- Comparison -------------------------------------------------------------------------------- @@ -3248,3 +3413,46 @@ = Map.zipWithMaybeAMatched $ \_k v1 v2 -> maybeNonNull <$> applyNonNull2 f v1 v2 {-# INLINE withBothA #-} + +-------------------------------------------------------------------------------- +-- State +-------------------------------------------------------------------------------- + +newtype StateL s a = StateL (s -> (s, a)) +newtype StateR s a = StateR (s -> (s, a)) + +instance Functor (StateL s) where + fmap f (StateL kx) = + StateL $ \s -> let (s', x) = kx s in (s', f x) + +instance Functor (StateR s) where + fmap f (StateR kx) = + StateR $ \s -> let (s', x) = kx s in (s', f x) + +instance Applicative (StateL s) where + pure a = StateL $ + \s -> (s, a) + StateL kf <*> StateL kx = StateL $ + \s -> + let (s' , f ) = kf s + (s'', x) = kx s' + in (s'', f x) + liftA2 f (StateL kx) (StateL ky) = StateL $ + \s -> + let (s' , x ) = kx s + (s'', y) = ky s' + in (s'', f x y) + +instance Applicative (StateR s) where + pure a = StateR $ + \s -> (s, a) + StateR kf <*> StateR kx = StateR $ + \s -> + let (s', x) = kx s + (s'', f ) = kf s' + in (s'', f x) + liftA2 f (StateR kx) (StateR ky) = StateR $ + \s -> + let (s' , y) = ky s + (s'', x ) = kx s' + in (s'', f x y) diff --git a/src/public/Data/MonoidMap.hs b/src/public/Data/MonoidMap.hs --- a/src/public/Data/MonoidMap.hs +++ b/src/public/Data/MonoidMap.hs @@ -66,17 +66,23 @@ -- ** Folding , foldl - , foldr - , foldlWithKey - , foldrWithKey - , foldMapWithKey - - -- *** Strict folding , foldl' + , foldr , foldr' + , foldlWithKey , foldlWithKey' + , foldrWithKey , foldrWithKey' + , foldMapWithKey , foldMapWithKey' + + -- ** Traversal + , traverse + , traverseWithKey + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey -- * Monoidal operations diff --git a/src/test/Data/MonoidMap/TraversalSpec.hs b/src/test/Data/MonoidMap/TraversalSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Data/MonoidMap/TraversalSpec.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.TraversalSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Functor.Identity + ( Identity (..) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , Fun (..) + , Property + , applyFun + , applyFun2 + , applyFun3 + , (===) + ) +import Data.Semigroup + ( First (..), Last (..) ) + +import qualified Data.Map.Strict as Map +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Traversable as Traversable + +spec :: Spec +spec = describe "Traversal" $ do + + forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + describe "traverse" $ do + + it "prop_traverse_@Identity" $ + prop_traverse @Identity + @k @v & property + it "prop_traverse_@Maybe" $ + prop_traverse @Maybe + @k @v & property + it "prop_traverse_@First" $ + prop_traverse @First + @k @v & property + it "prop_traverse_@Last" $ + prop_traverse @Last + @k @v & property + + describe "traverseWithKey" $ do + + it "prop_traverseWithKey_@Identity" $ + prop_traverseWithKey @Identity + @k @v & property + it "prop_traverseWithKey_@Maybe" $ + prop_traverseWithKey @Maybe + @k @v & property + it "prop_traverseWithKey_@First" $ + prop_traverseWithKey @First + @k @v & property + it "prop_traverseWithKey_@Last" $ + prop_traverseWithKey @Last + @k @v & property + + describe "mapAccumL" $ do + + it "prop_mapAccumL_@Int" $ + prop_mapAccumL @Int + @k @v & property + it "prop_mapAccumL_@String" $ + prop_mapAccumL @String + @k @v & property + + describe "mapAccumR" $ do + + it "prop_mapAccumR_@Int" $ + prop_mapAccumR @Int + @k @v & property + it "prop_mapAccumR_@String" $ + prop_mapAccumR @String + @k @v & property + + describe "mapAccumLWithKey" $ do + + it "prop_mapAccumLWithKey_@Int" $ + prop_mapAccumLWithKey @Int + @k @v & property + it "prop_mapAccumLWithKey_@String" $ + prop_mapAccumLWithKey @String + @k @v & property + + describe "mapAccumRWithKey" $ do + + it "prop_mapAccumRWithKey_@Int" $ + prop_mapAccumRWithKey @Int + @k @v & property + it "prop_mapAccumRWithKey_@String" $ + prop_mapAccumRWithKey @String + @k @v & property + +prop_traverse + :: forall t k v. Test k v + => (Applicative t, Eq (t (MonoidMap k v)), Show (t (MonoidMap k v))) + => Fun v (t v) + -> MonoidMap k v + -> Property +prop_traverse (applyFun -> f) m = + MonoidMap.traverse f m + === + fmap MonoidMap.fromMap (Traversable.traverse f (MonoidMap.toMap m)) + +prop_traverseWithKey + :: forall t k v. Test k v + => (Applicative t, Eq (t (MonoidMap k v)), Show (t (MonoidMap k v))) + => Fun (k, v) (t v) + -> MonoidMap k v + -> Property +prop_traverseWithKey (applyFun2 -> f) m = + MonoidMap.traverseWithKey f m + === + fmap MonoidMap.fromMap (Map.traverseWithKey f (MonoidMap.toMap m)) + +prop_mapAccumL + :: forall s k v. (Test k v, Eq s, Show s) + => Fun (s, v) (s, v) + -> s + -> MonoidMap k v + -> Property +prop_mapAccumL (applyFun2 -> f) s m = + MonoidMap.mapAccumL f s m + === + fmap MonoidMap.fromMap (Traversable.mapAccumL f s (MonoidMap.toMap m)) + +prop_mapAccumR + :: forall s k v. (Test k v, Eq s, Show s) + => Fun (s, v) (s, v) + -> s + -> MonoidMap k v + -> Property +prop_mapAccumR (applyFun2 -> f) s m = + MonoidMap.mapAccumR f s m + === + fmap MonoidMap.fromMap (Traversable.mapAccumR f s (MonoidMap.toMap m)) + +prop_mapAccumLWithKey + :: forall s k v. (Test k v, Eq s, Show s) + => Fun (s, k, v) (s, v) + -> s + -> MonoidMap k v + -> Property +prop_mapAccumLWithKey (applyFun3 -> f) s m = + MonoidMap.mapAccumLWithKey f s m + === + fmap MonoidMap.fromMap (Map.mapAccumWithKey f s (MonoidMap.toMap m)) + +prop_mapAccumRWithKey + :: forall s k v. (Test k v, Eq s, Show s) + => Fun (s, k, v) (s, v) + -> s + -> MonoidMap k v + -> Property +prop_mapAccumRWithKey (applyFun3 -> f) s m = + MonoidMap.mapAccumRWithKey f s m + === + fmap MonoidMap.fromMap (Map.mapAccumRWithKey f s (MonoidMap.toMap m)) + +deriving newtype instance Arbitrary a => Arbitrary (First a) +deriving newtype instance Arbitrary a => Arbitrary (Last a) diff --git a/src/test/Examples/RecoveredMapSpec.hs b/src/test/Examples/RecoveredMapSpec.hs --- a/src/test/Examples/RecoveredMapSpec.hs +++ b/src/test/Examples/RecoveredMapSpec.hs @@ -42,6 +42,8 @@ , Property , Testable , applyFun + , applyFun2 + , applyFun3 , checkCoverage , cover , listOf @@ -74,8 +76,10 @@ :: forall k v. () => ( Arbitrary k , Arbitrary v + , CoArbitrary k , CoArbitrary v , Eq v + , Function k , Function v , Monoid v , Ord k @@ -186,6 +190,38 @@ prop_map_mempty @k @v @v & property + describe "MapAccumL" $ do + it "prop_mapAccumL @Int" $ + prop_mapAccumL @Int + @k @v @v & property + it "prop_mapAccumL @String" $ + prop_mapAccumL @String + @k @v @v & property + + describe "MapAccumR" $ do + it "prop_mapAccumR @Int" $ + prop_mapAccumR @Int + @k @v @v & property + it "prop_mapAccumR @String" $ + prop_mapAccumR @String + @k @v @v & property + + describe "MapAccumWithKeyL" $ do + it "prop_mapAccumLWithKey @Int" $ + prop_mapAccumLWithKey @Int + @k @v @v & property + it "prop_mapAccumLWithKey @String" $ + prop_mapAccumLWithKey @String + @k @v @v & property + + describe "MapAccumWithKeyR" $ do + it "prop_mapAccumRWithKey @Int" $ + prop_mapAccumRWithKey @Int + @k @v @v & property + it "prop_mapAccumRWithKey @String" $ + prop_mapAccumRWithKey @String + @k @v @v & property + -------------------------------------------------------------------------------- -- Conversion to and from lists -------------------------------------------------------------------------------- @@ -461,6 +497,70 @@ (===) (RMap.toList (RMap.map (const (mempty @v2)) (RMap.fromList kvs))) (OMap.toList (OMap.map (const (mempty @v2)) (OMap.fromList kvs))) + +-------------------------------------------------------------------------------- +-- MapAccum +-------------------------------------------------------------------------------- + +prop_mapAccumL + :: forall s k v1 v2. (Eq s, Eq v2, Ord k, Show k, Show s, Show v2) + => Fun (s, v1) (s, v2) + -> s + -> [(k, v1)] + -> Property +prop_mapAccumL (applyFun2 -> f) s0 kvs = + (===) + (RMap.toList <$> rmapAccumL f s0 (RMap.fromList kvs)) + (OMap.toList <$> omapAccumL f s0 (OMap.fromList kvs)) + where + rmapAccumL = RMap.mapAccumL + omapAccumL = OMap.mapAccum + +prop_mapAccumR + :: forall s k v1 v2. (Eq s, Eq v2, Ord k, Show k, Show s, Show v2) + => Fun (s, v1) (s, v2) + -> s + -> [(k, v1)] + -> Property +prop_mapAccumR (applyFun2 -> f) s0 kvs = + (===) + (RMap.toList <$> rmapAccumR f s0 (RMap.fromList kvs)) + (OMap.toList <$> omapAccumR f s0 (OMap.fromList kvs)) + where + rmapAccumR = RMap.mapAccumR + omapAccumR g = OMap.mapAccumRWithKey (\s _ v -> g s v) + +-------------------------------------------------------------------------------- +-- MapAccumWithKey +-------------------------------------------------------------------------------- + +prop_mapAccumLWithKey + :: forall s k v1 v2. (Eq s, Eq v2, Ord k, Show k, Show s, Show v2) + => Fun (s, k, v1) (s, v2) + -> s + -> [(k, v1)] + -> Property +prop_mapAccumLWithKey (applyFun3 -> f) s0 kvs = + (===) + (RMap.toList <$> rmapAccumLWithKey f s0 (RMap.fromList kvs)) + (OMap.toList <$> omapAccumLWithKey f s0 (OMap.fromList kvs)) + where + rmapAccumLWithKey = RMap.mapAccumLWithKey + omapAccumLWithKey = OMap.mapAccumWithKey + +prop_mapAccumRWithKey + :: forall s k v1 v2. (Eq s, Eq v2, Ord k, Show k, Show s, Show v2) + => Fun (s, k, v1) (s, v2) + -> s + -> [(k, v1)] + -> Property +prop_mapAccumRWithKey (applyFun3 -> f) s0 kvs = + (===) + (RMap.toList <$> rmapAccumRWithKey f s0 (RMap.fromList kvs)) + (OMap.toList <$> omapAccumRWithKey f s0 (OMap.fromList kvs)) + where + rmapAccumRWithKey = RMap.mapAccumRWithKey + omapAccumRWithKey = OMap.mapAccumRWithKey -------------------------------------------------------------------------------- -- Arbitrary instances