diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.0.4.0 + +- Added the `fromMapWith` function to `MonoidMap`. + # 0.0.3.0 - Added the `mapWithKey` function to `MonoidMap`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1124,7 +1124,7 @@ [`MultiAsset`]: https://github.com/input-output-hk/cardano-ledger/blob/b00e28698d9c7fbbeda1c9cfdd1238d3bc4569cf/eras/mary/impl/src/Cardano/Ledger/Mary/Value.hs#L157 [`MultiMap.alterWithKey`]: https://hackage.haskell.org/package/multi-containers/docs/Data-Multimap.html#v:alterWithKey [`MultiMap`]: https://hackage.haskell.org/package/multi-containers/docs/Data-Multimap.html#t:Multimap -[`NestedMonoidMap`]: https://github.com/jonathanknowles/monoidmap/blob/main/src/examples/Examples/NestedMonoidMap.hs +[`NestedMonoidMap`]: https://github.com/jonathanknowles/monoidmap/blob/main/components/monoidmap-examples/Examples/NestedMonoidMap.hs [`NonEmpty`]: https://hackage.haskell.org/package/base/docs/Data-List-NonEmpty.html#t:NonEmpty [`Nothing`]: https://hackage.haskell.org/package/base/docs/Data-Maybe.html#v:Nothing [`Semigroup`]: https://hackage.haskell.org/package/base/docs/Data-Semigroup.html#t:Semigroup diff --git a/components/monoidmap-benchmark/Main.hs b/components/monoidmap-benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-benchmark/Main.hs @@ -0,0 +1,205 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- 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 + ( rnf ) +import Control.Exception + ( evaluate ) +import Data.Eq + ( Eq ) +import Data.Function + ( flip, ($) ) +import Data.Int + ( Int ) +import Data.List + ( foldl', zip ) +import Data.Maybe + ( Maybe, fromMaybe ) +import Data.Ord + ( Ord ) +import Data.Semigroup + ( Semigroup ((<>)), stimes ) +import Prelude + ( Integer, Num, (^), (+) ) +import System.IO + ( IO ) +import Test.Tasty.Bench + ( bench, bgroup, defaultMain, nf ) + +import qualified Data.Map.Strict as OMap +import qualified Examples.RecoveredMap as RMap + +main :: IO () +main = do + + let om_natural = fromList elems_natural :: OMap.Map Int Int + om_even = fromList elems_even :: OMap.Map Int Int + om_odd = fromList elems_odd :: OMap.Map Int Int + + rm_natural = fromList elems_natural :: RMap.Map Int Int + rm_even = fromList elems_even :: RMap.Map Int Int + rm_odd = fromList elems_odd :: RMap.Map Int Int + + evaluate $ rnf [om_natural, om_even, om_odd] + evaluate $ rnf [rm_natural, rm_even, rm_odd] + + defaultMain + [ bgroup "delete" + [ bgroup "absent" + [ bench "Data.Map.Strict" $ + nf (deleteMany evens) om_odd + , bench "RecoveredMap" $ + nf (deleteMany evens) rm_odd + ] + , bgroup "present" + [ bench "Data.Map.Strict" $ + nf (deleteMany evens) om_even + , bench "RecoveredMap" $ + nf (deleteMany evens) rm_even + ] + ] + , bgroup "insert" + [ bgroup "absent" + [ bench "Data.Map.Strict" $ + nf (insertMany elems_even) om_odd + , bench "RecoveredMap" $ + nf (insertMany elems_even) rm_odd + ] + , bgroup "present" + [ bench "Data.Map.Strict" $ + nf (insertMany elems_even) om_even + , bench "RecoveredMap" $ + nf (insertMany elems_even) rm_even + ] + ] + , bgroup "lookup" + [ bgroup "absent" + [ bench "Data.Map.Strict" $ + nf (lookupMany evens) om_odd + , bench "RecoveredMap" $ + nf (lookupMany evens) rm_odd + ] + , bgroup "present" + [ bench "Data.Map.Strict" $ + nf (lookupMany evens) om_even + , bench "RecoveredMap" $ + nf (lookupMany evens) rm_even + ] + ] + , bgroup "mappend" + [ bgroup "disjoint" + [ bench "Data.Map.Strict" $ + nf (<> om_even) om_odd + , bench "RecoveredMap" $ + nf (<> rm_even) rm_odd + ] + , bgroup "identical" + [ bench "Data.Map.Strict" $ + nf (<> om_even) om_even + , bench "RecoveredMap" $ + nf (<> rm_even) rm_even + ] + ] + , bgroup "stimes" + [ bench "Data.Map.Strict" $ + nf (stimes ten_power_24) om_natural + , 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 + bound = 2 ^ (16 :: Int) + + elems_natural :: [(Int, Int)] + elems_natural = zip naturals naturals + + elems_even :: [(Int, Int)] + elems_even = zip evens evens + + elems_odd :: [(Int, Int)] + elems_odd = zip odds odds + + naturals :: [Int] + naturals = [1 .. bound] + + evens :: [Int] + evens = [2, 4 .. bound] + + odds :: [Int] + odds = [1, 3 .. bound] + + ten_power_24 :: Integer + ten_power_24 = 1_000_000_000_000_000_000_000_000 + +class Ord k => Map m k v where + fromList :: [(k, v)] -> m k v + 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 + +insertMany :: (Map m k v, Num v) => [(k, v)] -> m k v -> m k v +insertMany xs m = foldl' (\m' (k, v) -> insert k v m') m xs + +lookupMany :: (Map m k v, Num v) => [k] -> m k v -> v +lookupMany xs m = foldl' (\n k -> fromMaybe n (lookup k m)) 0 xs diff --git a/components/monoidmap-examples/Examples/MultiMap.hs b/components/monoidmap-examples/Examples/MultiMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides the 'MultiMap' class, which models a total relation from unique +-- keys to sets of values. +-- +-- = Implementations +-- +-- The following example implementations are provided: +-- +-- +----------------+------------------------+---------+ +-- | Implementation | Types used | Lawful? | +-- +================+=============+==========+=========+ +-- | 'MultiMap1' | 'Map' | 'Set' | 💥 No | +-- +----------------+-------------+----------+---------+ +-- | 'MultiMap2' | 'Map' | 'Set' | ✅ Yes | +-- +----------------+-------------+----------+---------+ +-- | 'MultiMap3' | 'Map' | 'NESet' | ✅ Yes | +-- +----------------+-------------+----------+---------+ +-- | 'MultiMap4' | 'MonoidMap' | 'Set' | ✅ Yes | +-- +----------------+-------------+----------+---------+ +-- +module Examples.MultiMap + ( MultiMap (..) + ) where + +import Data.Map.Strict + ( Map ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Set + ( Set ) +import Data.Set.NonEmpty + ( NESet ) +import Examples.MultiMap.Class + ( MultiMap (..) ) +import Examples.MultiMap.Instances.MultiMap1 + ( MultiMap1 ) +import Examples.MultiMap.Instances.MultiMap2 + ( MultiMap2 ) +import Examples.MultiMap.Instances.MultiMap3 + ( MultiMap3 ) +import Examples.MultiMap.Instances.MultiMap4 + ( MultiMap4 ) diff --git a/components/monoidmap-examples/Examples/MultiMap/Class.hs b/components/monoidmap-examples/Examples/MultiMap/Class.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap/Class.hs @@ -0,0 +1,180 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides the 'MultiMap' class, which models a total relation from unique +-- keys to sets of values. +-- +module Examples.MultiMap.Class where + +import Data.Set + ( Set ) +import Prelude hiding + ( lookup ) + +-- | Models a total relation from unique keys to sets of values. +-- +class (Eq (m k v), Ord k, Ord v) => MultiMap m k v where + + -- | Constructs a multimap from a list of key to value set mappings. + -- + -- Removing empty sets from the input list does not affect the result: + -- + -- > fromList ≡ fromList . filter ((/= Set.empty) . snd) + -- + fromList :: [(k, Set v)] -> m k v + + -- | Converts a multimap to a list of key to value-set mappings. + -- + -- Removing empty sets from the output list does not affect the result: + -- + -- > toList ≡ filter ((/= Set.empty) . snd) . toList + -- + -- The resulting list can be used to reconstruct the original multimap: + -- + -- > fromList . toList ≡ id + -- + toList :: m k v -> [(k, Set v)] + + -- | Constructs an empty multimap. + -- + -- > empty ≡ fromList [] + -- + empty :: m k v + + -- | Returns the set of values associated with a given key. + -- + -- > lookup k (fromList kvs) ≡ foldMap snd (filter ((== k) . fst) kvs) + -- + lookup :: k -> m k v -> Set v + + -- | Indicates whether or not a multimap is empty. + -- + -- > null m ≡ (∀ k. lookup k m == Set.empty) + -- + null :: m k v -> Bool + + -- | Indicates whether or not a multimap is non-empty. + -- + -- > nonNull m ≡ (∃ k. lookup k m /= Set.empty) + -- + nonNull :: m k v -> Bool + + -- | Returns 'True' iff. the given key is associated with a non-empty set. + -- + -- > nonNullKey k m ≡ (lookup k m /= Set.empty) + -- + nonNullKey :: k -> m k v -> Bool + + -- | Returns the set of keys that are associated with non-empty sets. + -- + -- > all (`nonNullKey` m) (nonNullKeys m) + -- + nonNullKeys :: m k v -> Set k + + -- | Indicates how many keys are associated with non-empty sets. + -- + -- > nonNullCount m ≡ Set.size (nonNullKeys m) + -- + nonNullCount :: m k v -> Int + + -- | Indicates whether or not the first map is a sub-map of the second. + -- + -- > m1 `isSubmapOf` m2 ≡ ∀ k. (lookup k m1 `Set.isSubsetOf` lookup k m2) + -- + isSubmapOf :: m k v -> m k v -> Bool + + -- | Updates the set of values associated with a given key. + -- + -- > lookup k1 (update k2 vs m) ≡ + -- > if k1 == k2 + -- > then vs + -- > else lookup k1 m + -- + update :: k -> Set v -> m k v -> m k v + + -- | Inserts values into the set of values associated with a given key. + -- + -- > lookup k1 (insert k2 vs m) ≡ + -- > if k1 == k2 + -- > then lookup k1 m `Set.union` vs + -- > else lookup k1 m + -- + insert :: k -> Set v -> m k v -> m k v + + -- | Removes values from the set of values associated with a given key. + -- + -- > lookup k1 (remove k2 vs m) ≡ + -- > if k1 == k2 + -- > then lookup k1 m `Set.difference` vs + -- > else lookup k1 m + -- + remove :: k -> Set v -> m k v -> m k v + + -- | Computes the union of two multimaps. + -- + -- Instances must satisfy the following properties: + -- + -- __/Idempotence/__ + -- + -- > union m m ≡ m + -- + -- __/Identity/__ + -- + -- > union empty m ≡ m + -- > union m empty ≡ m + -- + -- __/Commutativity/__ + -- + -- > union m1 m2 ≡ union m2 m1 + -- + -- __/Associativity/__ + -- + -- > union m1 (union m2 m3) ≡ + -- > union (union m1 m2) m3 + -- + -- __/Containment/__ + -- + -- > m1 `isSubmapOf` union m1 m2 + -- > m2 `isSubmapOf` union m1 m2 + -- + -- __/Distributivity/__ + -- + -- > lookup k (union m1 m2) ≡ Set.union (lookup k m1) + -- > (lookup k m2) + -- + union :: m k v -> m k v -> m k v + + -- | Computes the intersection of two multimaps. + -- + -- Instances must satisfy the following properties: + -- + -- __/Idempotence/__ + -- + -- > intersection m m ≡ m + -- + -- __/Identity/__ + -- + -- > intersection empty m ≡ empty + -- > intersection m empty ≡ empty + -- + -- __/Commutativity/__ + -- + -- > intersection m1 m2 ≡ intersection m2 m1 + -- + -- __/Associativity/__ + -- + -- > intersection m1 (intersection m2 m3) ≡ + -- > intersection (intersection m1 m2) m3 + -- + -- __/Containment/__ + -- + -- > intersection m1 m2 `isSubmapOf` m1 + -- > intersection m1 m2 `isSubmapOf` m2 + -- + -- __/Distributivity/__ + -- + -- > lookup k (intersection m1 m2) ≡ Set.intersection (lookup k m1) + -- > (lookup k m2) + -- + intersection :: m k v -> m k v -> m k v diff --git a/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap1.hs b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap1.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap1.hs @@ -0,0 +1,61 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- An __unlawful__ implementation of 'MultiMap', implemented in terms of 'Map' +-- and 'Set'. +-- +-- This implementation has several subtle bugs. 💥 +-- +module Examples.MultiMap.Instances.MultiMap1 where + +import Prelude + +import Data.Map.Strict + ( Map ) +import Data.Set + ( Set ) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Examples.MultiMap.Class as Class + +newtype MultiMap1 k v = MultiMap (Map k (Set v)) + deriving stock (Eq, Show) + +instance (Ord k, Ord v) => Class.MultiMap MultiMap1 k v where + + fromList = MultiMap . Map.fromList + + toList (MultiMap m) = Map.toList m + + empty = MultiMap Map.empty + + lookup k (MultiMap m) = Map.findWithDefault Set.empty k m + + null (MultiMap m) = Map.null m + + nonNull (MultiMap m) = not (Map.null m) + + nonNullKey k (MultiMap m) = Map.member k m + + nonNullKeys (MultiMap m) = Map.keysSet m + + nonNullCount (MultiMap m) = Map.size m + + isSubmapOf (MultiMap m1) (MultiMap m2) = + Map.isSubmapOfBy Set.isSubsetOf m1 m2 + + update k vs (MultiMap m) = MultiMap (Map.insert k vs m) + + insert k vs (MultiMap m) = MultiMap $ + Map.insert k (Map.findWithDefault Set.empty k m `Set.union` vs) m + + remove k vs (MultiMap m) = MultiMap $ + Map.insert k (Map.findWithDefault Set.empty k m `Set.difference` vs) m + + union (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.unionWith Set.union m1 m2 + + intersection (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.intersectionWith Set.intersection m1 m2 diff --git a/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap2.hs b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap2.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap2.hs @@ -0,0 +1,80 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and +-- 'Set'. +-- +module Examples.MultiMap.Instances.MultiMap2 where + +import Prelude + +import Data.Map.Strict + ( Map ) +import Data.Set + ( Set ) + +import qualified Data.Map.Merge.Strict as Map +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Examples.MultiMap.Class as Class + +newtype MultiMap2 k v = MultiMap (Map k (Set v)) + deriving stock (Eq, Show) + +instance (Ord k, Ord v) => Class.MultiMap MultiMap2 k v where + + fromList = MultiMap . Map.fromListWith (<>) . filter ((/= mempty) . snd) + + toList (MultiMap m) = Map.toList m + + empty = MultiMap Map.empty + + lookup k (MultiMap m) = Map.findWithDefault Set.empty k m + + null (MultiMap m) = Map.null m + + nonNull (MultiMap m) = not (Map.null m) + + nonNullKey k (MultiMap m) = Map.member k m + + nonNullKeys (MultiMap m) = Map.keysSet m + + nonNullCount (MultiMap m) = Map.size m + + isSubmapOf (MultiMap m1) (MultiMap m2) = + Map.isSubmapOfBy Set.isSubsetOf m1 m2 + + update k vs (MultiMap m) + | Set.null vs = MultiMap (Map.delete k m) + | otherwise = MultiMap (Map.insert k vs m) + + insert k vs (MultiMap m) + | Set.null xs = MultiMap (Map.delete k m) + | otherwise = MultiMap (Map.insert k xs m) + where + xs = Map.findWithDefault Set.empty k m `Set.union` vs + + remove k vs (MultiMap m) + | Set.null xs = MultiMap (Map.delete k m) + | otherwise = MultiMap (Map.insert k xs m) + where + xs = Map.findWithDefault Set.empty k m `Set.difference` vs + + union (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.unionWith Set.union m1 m2 + + intersection (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.merge + Map.dropMissing + Map.dropMissing + (Map.zipWithMaybeMatched mergeValues) + m1 + m2 + where + mergeValues :: k -> Set v -> Set v -> Maybe (Set v) + mergeValues _k s1 s2 + | Set.null s3 = Nothing + | otherwise = Just s3 + where + s3 = Set.intersection s1 s2 diff --git a/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap3.hs b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap3.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap3.hs @@ -0,0 +1,85 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and +-- 'NESet'. +-- +module Examples.MultiMap.Instances.MultiMap3 where + +import Prelude + +import Data.Map.Strict + ( Map ) +import Data.Maybe + ( mapMaybe ) +import Data.Set.NonEmpty + ( NESet ) + +import qualified Data.Map.Merge.Strict as Map +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet +import qualified Examples.MultiMap.Class as Class + +newtype MultiMap3 k v = MultiMap (Map k (NESet v)) + deriving stock (Eq, Show) + +instance (Ord k, Ord v) => Class.MultiMap MultiMap3 k v where + + fromList + = MultiMap + . Map.fromListWith (<>) + . mapMaybe (traverse NESet.nonEmptySet) + + toList (MultiMap m) = fmap NESet.toSet <$> Map.toList m + + empty = MultiMap Map.empty + + lookup k (MultiMap m) = maybe Set.empty NESet.toSet (Map.lookup k m) + + null (MultiMap m) = Map.null m + + nonNull (MultiMap m) = not (Map.null m) + + nonNullKey k (MultiMap m) = Map.member k m + + nonNullKeys (MultiMap m) = Map.keysSet m + + nonNullCount (MultiMap m) = Map.size m + + isSubmapOf (MultiMap m1) (MultiMap m2) = + Map.isSubmapOfBy NESet.isSubsetOf m1 m2 + + update k vs (MultiMap m) = + case NESet.nonEmptySet vs of + Nothing -> MultiMap (Map.delete k m) + Just ys -> MultiMap (Map.insert k ys m) + + insert k vs (MultiMap m) = + case NESet.nonEmptySet xs of + Nothing -> MultiMap (Map.delete k m) + Just ys -> MultiMap (Map.insert k ys m) + where + xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.union` vs + + remove k vs (MultiMap m) = + case NESet.nonEmptySet xs of + Nothing -> MultiMap (Map.delete k m) + Just ys -> MultiMap (Map.insert k ys m) + where + xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.difference` vs + + union (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.unionWith NESet.union m1 m2 + + intersection (MultiMap m1) (MultiMap m2) = MultiMap $ + Map.merge + Map.dropMissing + Map.dropMissing + (Map.zipWithMaybeMatched mergeValues) + m1 + m2 + where + mergeValues :: Ord v => k -> NESet v -> NESet v -> Maybe (NESet v) + mergeValues _k s1 s2 = NESet.nonEmptySet (NESet.intersection s1 s2) diff --git a/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap4.hs b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap4.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiMap/Instances/MultiMap4.hs @@ -0,0 +1,59 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- A __lawful__ implementation of 'MultiMap', implemented in terms of +-- 'MonoidMap' and 'Set'. +-- +module Examples.MultiMap.Instances.MultiMap4 where + +import Prelude + +import Data.MonoidMap + ( MonoidMap ) +import Data.Set + ( Set ) + +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set +import qualified Examples.MultiMap.Class as Class + +newtype MultiMap4 k v = MultiMap (MonoidMap k (Set v)) + deriving stock (Eq, Show) + +instance (Ord k, Ord v) => Class.MultiMap MultiMap4 k v where + + fromList = MultiMap . MonoidMap.fromListWith (<>) + + toList (MultiMap m) = MonoidMap.toList m + + empty = MultiMap MonoidMap.empty + + lookup k (MultiMap m) = MonoidMap.get k m + + null (MultiMap m) = MonoidMap.null m + + nonNull (MultiMap m) = MonoidMap.nonNull m + + nonNullKey k (MultiMap m) = MonoidMap.nonNullKey k m + + nonNullKeys (MultiMap m) = MonoidMap.nonNullKeys m + + nonNullCount (MultiMap m) = MonoidMap.nonNullCount m + + isSubmapOf (MultiMap m1) (MultiMap m2) = m1 `MonoidMap.isSubmapOf` m2 + + update k vs (MultiMap m) = + MultiMap (MonoidMap.set k vs m) + + insert k vs (MultiMap m) = + MultiMap (MonoidMap.adjust (`Set.union` vs) k m) + + remove k vs (MultiMap m) = + MultiMap (MonoidMap.adjust (`Set.difference` vs) k m) + + union (MultiMap m1) (MultiMap m2) = + MultiMap (MonoidMap.union m1 m2) + + intersection (MultiMap m1) (MultiMap m2) = + MultiMap (MonoidMap.intersection m1 m2) diff --git a/components/monoidmap-examples/Examples/MultiSet.hs b/components/monoidmap-examples/Examples/MultiSet.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/MultiSet.hs @@ -0,0 +1,156 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- A multiset type, implemented in terms of 'MonoidMap'. +-- +-- See: https://en.wikipedia.org/wiki/Multiset +-- +module Examples.MultiSet + ( fromList + , toList + , null + , member + , multiplicity + , root + , cardinality + , dimension + , height + , isSubsetOf + , intersection + , union + , disjointUnion + , add + , subtract + , subtractMaybe + ) + where + +import Prelude hiding + ( null, subtract ) + +import Data.Function + ( on ) +import Data.Monoid + ( Sum (..) ) +import Data.Monoid.GCD + ( DistributiveGCDMonoid + , GCDMonoid + , LeftDistributiveGCDMonoid + , LeftGCDMonoid + , OverlappingGCDMonoid + , RightDistributiveGCDMonoid + , RightGCDMonoid + ) +import Data.Monoid.LCM + ( DistributiveLCMMonoid, LCMMonoid ) +import Data.Monoid.Monus + ( Monus ((<\>)) ) +import Data.Monoid.Null + ( MonoidNull, PositiveMonoid ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Semigroup.Cancellative + ( Cancellative + , Commutative + , LeftCancellative + , LeftReductive + , Reductive (()) + , RightCancellative + , RightReductive + ) +import Data.Set + ( Set ) +import Numeric.Natural + ( Natural ) +import Text.Read + ( Read (..) ) + +import qualified Data.Foldable as F +import qualified Data.MonoidMap as MonoidMap + +newtype MultiSet a = MultiSet + { unMultiSet :: MonoidMap a (Sum Natural) + } + deriving newtype + ( Eq + , Semigroup + , Commutative + , Monoid + , MonoidNull + , PositiveMonoid + , LeftReductive + , LeftCancellative + , LeftGCDMonoid + , LeftDistributiveGCDMonoid + , RightReductive + , RightCancellative + , RightGCDMonoid + , RightDistributiveGCDMonoid + , Reductive + , Cancellative + , GCDMonoid + , LCMMonoid + , DistributiveGCDMonoid + , DistributiveLCMMonoid + , OverlappingGCDMonoid + , Monus + ) + +instance (Ord a, Read a) => Read (MultiSet a) where + readPrec = fromList <$> readPrec + +instance Show a => Show (MultiSet a) where + show = show . toList + +fromList :: Ord a => [(a, Natural)] -> MultiSet a +fromList = MultiSet . MonoidMap.fromList . fmap (fmap Sum) + +toList :: MultiSet a -> [(a, Natural)] +toList = fmap (fmap getSum) . MonoidMap.toList . unMultiSet + +null :: MultiSet a -> Bool +null = MonoidMap.null . unMultiSet + +member :: Ord a => a -> MultiSet a -> Bool +member a = MonoidMap.nonNullKey a . unMultiSet + +multiplicity :: Ord a => a -> MultiSet a -> Natural +multiplicity a = getSum . MonoidMap.get a . unMultiSet + +root :: Ord a => MultiSet a -> Set a +root = MonoidMap.nonNullKeys . unMultiSet + +cardinality :: MultiSet a -> Natural +cardinality = getSum . F.fold . unMultiSet + +dimension :: MultiSet a -> Natural +dimension = fromIntegral . MonoidMap.nonNullCount . unMultiSet + +height :: Ord a => MultiSet a -> Natural +height s + | null s = 0 + | otherwise = getSum $ F.maximum $ unMultiSet s + +isSubsetOf :: Ord a => MultiSet a -> MultiSet a -> Bool +isSubsetOf = MonoidMap.isSubmapOf `on` unMultiSet + +intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +intersection (MultiSet s1) (MultiSet s2) = + MultiSet (MonoidMap.intersection s1 s2) + +union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +union (MultiSet s1) (MultiSet s2) = + MultiSet (MonoidMap.union s1 s2) + +disjointUnion :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +disjointUnion m1 m2 = (m1 <\> m2) <> (m2 <\> m1) + +add :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +add = (<>) + +subtract :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +subtract = (<\>) + +subtractMaybe :: Ord a => MultiSet a -> MultiSet a -> Maybe (MultiSet a) +subtractMaybe = () diff --git a/components/monoidmap-examples/Examples/NestedMonoidMap.hs b/components/monoidmap-examples/Examples/NestedMonoidMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/NestedMonoidMap.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- A nested map with compound keys, implemented in terms of 'MonoidMap'. +-- +module Examples.NestedMonoidMap + ( + -- * Type + NestedMonoidMap + + -- * Construction + , fromFlatList + , fromFlatMap + , fromNestedList + , fromNestedMap + + -- * Deconstruction + , toFlatList + , toFlatMap + , toNestedList + , toNestedMap + + -- * Basic operations + , get + , set + , adjust + , nullify + + -- * Membership + , nonNullCount + , nonNullKey + , nonNullKeys + + -- * Intersection + , intersection + , intersectionWith + + -- * Union + , union + , unionWith + + -- * Comparison + , isSubmapOf + , isSubmapOfBy + , disjoint + , disjointBy + ) + where + +import Prelude + +import Data.Map.Strict + ( Map ) +import Data.Monoid + ( Sum (..) ) +import Data.Monoid.GCD + ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) +import Data.Monoid.LCM + ( LCMMonoid ) +import Data.Monoid.Monus + ( Monus ) +import Data.Monoid.Null + ( MonoidNull, PositiveMonoid ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Semigroup.Cancellative + ( Cancellative + , Commutative + , LeftCancellative + , LeftReductive + , Reductive + , RightCancellative + , RightReductive + ) +import Data.Set + ( Set ) +import GHC.Exts + ( IsList (..) ) + +import qualified Data.Foldable as F +import qualified Data.Map.Strict as Map +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +-------------------------------------------------------------------------------- +-- Type +-------------------------------------------------------------------------------- + +newtype NestedMonoidMap k1 k2 v = + NestedMonoidMap (MonoidMap k1 (MonoidMap k2 v)) + deriving stock Eq + deriving newtype + ( Cancellative + , Commutative + , GCDMonoid + , LCMMonoid + , LeftCancellative + , LeftGCDMonoid + , LeftReductive + , Monoid + , MonoidNull + , Monus + , OverlappingGCDMonoid + , PositiveMonoid + , Reductive + , RightCancellative + , RightGCDMonoid + , RightReductive + , Semigroup + , Show + ) + +-------------------------------------------------------------------------------- +-- Construction +-------------------------------------------------------------------------------- + +fromFlatList + :: (Ord k1, Ord k2, MonoidNull v) + => [((k1, k2), v)] + -> NestedMonoidMap k1 k2 v +fromFlatList = F.foldl' acc mempty + where + acc m ((k1, k2), v) = adjust (<> v) k1 k2 m + +fromFlatMap + :: (Ord k1, Ord k2, MonoidNull v) + => Map (k1, k2) v + -> NestedMonoidMap k1 k2 v +fromFlatMap = fromFlatList . Map.toList + +fromNestedList + :: (Ord k1, Ord k2, MonoidNull v) + => [(k1, [(k2, v)])] + -> NestedMonoidMap k1 k2 v +fromNestedList entries = + fromFlatList [((k1, k2), v) | (k1, n) <- entries, (k2, v) <- n] + +fromNestedMap + :: (Ord k2, MonoidNull v) + => Map k1 (Map k2 v) + -> NestedMonoidMap k1 k2 v +fromNestedMap = NestedMonoidMap . MonoidMap.fromMap . fmap MonoidMap.fromMap + +-------------------------------------------------------------------------------- +-- Deconstruction +-------------------------------------------------------------------------------- + +toFlatList + :: (Ord k1, Ord k2, MonoidNull v) + => NestedMonoidMap k1 k2 v + -> [((k1, k2), v)] +toFlatList m = [((k1, k2), v) | (k1, n) <- toNestedList m, (k2, v) <- toList n] + +toFlatMap + :: (Ord k1, Ord k2, MonoidNull v) + => NestedMonoidMap k1 k2 v + -> Map (k1, k2) v +toFlatMap = Map.fromList . toFlatList + +toNestedList + :: (Ord k1, Ord k2, MonoidNull v) + => NestedMonoidMap k1 k2 v + -> [(k1, [(k2, v)])] +toNestedList (NestedMonoidMap m) = fmap toList <$> toList m + +toNestedMap + :: NestedMonoidMap k1 k2 v + -> Map k1 (Map k2 v) +toNestedMap (NestedMonoidMap m) = MonoidMap.toMap <$> MonoidMap.toMap m + +-------------------------------------------------------------------------------- +-- Basic operations +-------------------------------------------------------------------------------- + +get :: (Ord k1, Ord k2, MonoidNull v) + => k1 + -> k2 + -> NestedMonoidMap k1 k2 v + -> v +get k1 k2 (NestedMonoidMap m) = MonoidMap.get k2 (MonoidMap.get k1 m) + +set :: (Ord k1, Ord k2, MonoidNull v) + => k1 + -> k2 + -> v + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +set k1 k2 v (NestedMonoidMap m) = + NestedMonoidMap $ MonoidMap.adjust (MonoidMap.set k2 v) k1 m + +adjust + :: (Ord k1, Ord k2, MonoidNull v) + => (v -> v) + -> k1 + -> k2 + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +adjust f k1 k2 (NestedMonoidMap m) = + NestedMonoidMap $ MonoidMap.adjust (MonoidMap.adjust f k2) k1 m + +nullify + :: (Ord k1, Ord k2, MonoidNull v) + => k1 + -> k2 + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +nullify k1 k2 (NestedMonoidMap m) = + NestedMonoidMap $ MonoidMap.adjust (MonoidMap.nullify k2) k1 m + +-------------------------------------------------------------------------------- +-- Membership +-------------------------------------------------------------------------------- + +nonNullCount :: NestedMonoidMap k1 k2 v -> Int +nonNullCount (NestedMonoidMap m) = + getSum $ F.foldMap (Sum . MonoidMap.nonNullCount) m + +nonNullKey + :: (Ord k1, Ord k2, MonoidNull v) + => k1 + -> k2 + -> NestedMonoidMap k1 k2 v + -> Bool +nonNullKey k1 k2 (NestedMonoidMap m) = + MonoidMap.nonNullKey k2 (MonoidMap.get k1 m) + +nonNullKeys + :: (Ord k1, Ord k2, MonoidNull v) + => NestedMonoidMap k1 k2 v + -> Set (k1, k2) +nonNullKeys = Set.fromList . fmap fst . toFlatList + +-------------------------------------------------------------------------------- +-- Intersection +-------------------------------------------------------------------------------- + +intersection + :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) + => NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +intersection (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ + MonoidMap.intersection m1 m2 + +intersectionWith + :: (Ord k1, Ord k2, MonoidNull v) + => (v -> v -> v) + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +intersectionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ + MonoidMap.intersectionWith (MonoidMap.intersectionWith f) m1 m2 + +-------------------------------------------------------------------------------- +-- Union +-------------------------------------------------------------------------------- + +union + :: (Ord k1, Ord k2, MonoidNull v, LCMMonoid v) + => NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +union (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ + MonoidMap.union m1 m2 + +unionWith + :: (Ord k1, Ord k2, MonoidNull v) + => (v -> v -> v) + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v +unionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ + MonoidMap.unionWith (MonoidMap.unionWith f) m1 m2 + +-------------------------------------------------------------------------------- +-- Comparison +-------------------------------------------------------------------------------- + +isSubmapOf + :: (Ord k1, Ord k2, MonoidNull v, Reductive v) + => NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> Bool +isSubmapOf (NestedMonoidMap m1) (NestedMonoidMap m2) = + MonoidMap.isSubmapOf m1 m2 + +isSubmapOfBy + :: (Ord k1, Ord k2, MonoidNull v, Reductive v) + => (v -> v -> Bool) + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> Bool +isSubmapOfBy f (NestedMonoidMap m1) (NestedMonoidMap m2) = + MonoidMap.isSubmapOfBy (MonoidMap.isSubmapOfBy f) m1 m2 + +disjoint + :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) + => NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> Bool +disjoint (NestedMonoidMap m1) (NestedMonoidMap m2) = + MonoidMap.disjoint m1 m2 + +disjointBy + :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) + => (v -> v -> Bool) + -> NestedMonoidMap k1 k2 v + -> NestedMonoidMap k1 k2 v + -> Bool +disjointBy f (NestedMonoidMap m1) (NestedMonoidMap m2) = + MonoidMap.disjointBy (MonoidMap.disjointBy f) m1 m2 diff --git a/components/monoidmap-examples/Examples/RecoveredMap.hs b/components/monoidmap-examples/Examples/RecoveredMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Examples/RecoveredMap.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- An ordinary left-biased map similar to 'Map', implemented in terms of +-- 'MonoidMap'. +-- +module Examples.RecoveredMap + ( Map + , empty + , singleton + , fromList + , toList + , delete + , insert + , keysSet + , lookup + , member + , map + , mapWithKey + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey + ) + where + +import Prelude hiding + ( lookup, map ) + +import Control.DeepSeq + ( NFData ) +import Data.Coerce + ( coerce ) +import Data.Maybe + ( mapMaybe ) +import Data.Monoid + ( First (..) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Semigroup + ( Semigroup (stimes), stimesIdempotentMonoid ) +import Data.Set + ( Set ) + +import qualified Data.MonoidMap as MonoidMap + +newtype Map k v = Map + -- 'First' is used to mimic the left-biased nature of 'Data.Map': + {unMap :: MonoidMap k (First v)} + deriving newtype (Eq, NFData, Monoid) + +instance Ord k => Semigroup (Map k v) where + (<>) = coerce @(MonoidMap k (First v) -> _ -> _) (<>) + stimes = stimesIdempotentMonoid + +instance (Show k, Show v) => Show (Map k v) where + show = ("fromList " <>) . show . toList + +instance Functor (Map k) where + fmap = map + +empty :: Map k v +empty = Map MonoidMap.empty + +singleton :: Ord k => k -> v -> Map k v +singleton k = Map . MonoidMap.singleton k . pure + +fromList :: Ord k => [(k, v)] -> Map k v +fromList = Map . MonoidMap.fromListWith (const id) . fmap (fmap pure) + +toList :: Map k v -> [(k, v)] +toList = mapMaybe (getFirst . sequenceA) . MonoidMap.toList . unMap + +delete :: Ord k => k -> Map k v -> Map k v +delete k = Map . MonoidMap.nullify k . unMap + +insert :: Ord k => k -> v -> Map k v -> Map k v +insert k v = Map . MonoidMap.set k (pure v) . unMap + +keysSet :: Map k v -> Set k +keysSet = MonoidMap.nonNullKeys . unMap + +lookup :: Ord k => k -> Map k v -> Maybe v +lookup k = getFirst . MonoidMap.get k . unMap + +member :: Ord k => k -> Map k v -> Bool +member k = MonoidMap.nonNullKey k . unMap + +map :: (v1 -> v2) -> Map k v1 -> Map k v2 +map f = Map . MonoidMap.map (fmap f) . unMap + +mapWithKey :: (k -> v1 -> v2) -> Map k v1 -> Map k v2 +mapWithKey f = Map . MonoidMap.mapWithKey (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/components/monoidmap-internal/Data/MonoidMap/Internal.hs b/components/monoidmap-internal/Data/MonoidMap/Internal.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-internal/Data/MonoidMap/Internal.hs @@ -0,0 +1,3520 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{- HLINT ignore "Avoid lambda" -} +{- HLINT ignore "Avoid lambda using `infix`" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides /internal/ operations for the 'MonoidMap' type. +-- +module Data.MonoidMap.Internal + ( + -- * Types + MonoidMap (..) + , NonNull (..) + + -- * General operations + + -- ** Construction + , empty + , fromList + , fromListWith + , fromMap + , fromMapWith + , fromSet + , singleton + + -- ** Deconstruction + , toList + , toMap + + -- ** Lookup + , get + + -- ** Modification + , set + , adjust + , nullify + + -- ** Membership + , null + , nullKey + , nonNull + , nonNullCount + , nonNullKey + , nonNullKeys + + -- ** Slicing + , take + , drop + , splitAt + + -- ** Filtering + , filter + , filterKeys + , filterWithKey + + -- ** Partitioning + , partition + , partitionKeys + , partitionWithKey + + -- ** Mapping + , map + , mapKeys + , mapKeysWith + , mapWithKey + + -- ** Folding + , foldl + , foldl' + , foldr + , foldr' + , foldlWithKey + , foldlWithKey' + , foldrWithKey + , foldrWithKey' + , foldMapWithKey + , foldMapWithKey' + + -- ** Traversal + , traverse + , traverseWithKey + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey + + -- * Monoidal operations + + -- ** Association + , append + + -- ** Subtraction + , minus + , minusMaybe + , monus + + -- ** Inversion + , invert + + -- ** Exponentiation + , power + + -- ** Comparison + , isSubmapOf + , isSubmapOfBy + , disjoint + , disjointBy + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithA + + -- ** Union + , union + , unionWith + , unionWithA + + -- ** Prefixes + , isPrefixOf + , stripPrefix + , commonPrefix + , stripCommonPrefix + + -- ** Suffixes + , isSuffixOf + , stripSuffix + , commonSuffix + , stripCommonSuffix + + -- ** Overlap + , overlap + , stripPrefixOverlap + , stripSuffixOverlap + , stripOverlap + ) + where + +import Prelude hiding + ( drop + , filter + , foldl + , foldl' + , foldr + , lookup + , map + , null + , splitAt + , subtract + , take + , traverse + ) + +import Control.Applicative + ( Applicative (..) ) +import Control.DeepSeq + ( NFData ) +import Data.Bifoldable + ( Bifoldable ) +import Data.Coerce + ( coerce ) +import Data.Function + ( (&) ) +import Data.Functor.Classes + ( Eq1, Eq2, Show1, Show2 ) +import Data.Functor.Identity + ( Identity (..) ) +import Data.Group + ( Abelian, Group ) +import Data.Map.Strict + ( Map, lookup ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Monoid.GCD + ( DistributiveGCDMonoid + , GCDMonoid + , LeftDistributiveGCDMonoid + , LeftGCDMonoid + , OverlappingGCDMonoid + , RightDistributiveGCDMonoid + , RightGCDMonoid + ) +import Data.Monoid.LCM + ( DistributiveLCMMonoid, LCMMonoid ) +import Data.Monoid.Monus + ( Monus (..) ) +import Data.Monoid.Null + ( MonoidNull, PositiveMonoid ) +import Data.Semigroup + ( stimes ) +import Data.Semigroup.Cancellative + ( Cancellative + , Commutative + , LeftCancellative + , LeftReductive + , Reductive (..) + , RightCancellative + , RightReductive + ) +import Data.Set + ( Set ) +import GHC.Exts + ( IsList (Item) ) +import NoThunks.Class + ( NoThunks ) +import Text.Read + ( Read (..) ) + +import qualified Data.Bifunctor as B +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Merge.Strict as Map +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 +import qualified Data.Monoid.LCM as C +import qualified Data.Monoid.Null as C +import qualified Data.Semigroup.Cancellative as C + +-------------------------------------------------------------------------------- +-- Type +-------------------------------------------------------------------------------- + +newtype MonoidMap k v = MonoidMap (Map k (NonNull v)) + deriving (Eq, Show, NFData, NoThunks) + via Map k v + deriving (Eq1, Show1, Foldable) + via Map k + deriving (Eq2, Show2, Bifoldable) + via Map + +-- Internal alias used when extra brevity is required. +type MM = MonoidMap + +-------------------------------------------------------------------------------- +-- Non-null values +-------------------------------------------------------------------------------- + +newtype NonNull v = UnsafeNonNull {getNonNull :: v} + +maybeNonNull :: MonoidNull v => v -> Maybe (NonNull v) +maybeNonNull !v + | C.null v = Nothing + | otherwise = Just (UnsafeNonNull v) +{-# INLINE maybeNonNull #-} + +applyNonNull :: (v -> a) -> (NonNull v -> a) +applyNonNull = coerce +{-# INLINE applyNonNull #-} + +applyNonNull2 :: (v1 -> v2 -> a) -> (NonNull v1 -> NonNull v2 -> a) +applyNonNull2 = coerce +{-# INLINE applyNonNull2 #-} + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +instance (Ord k, MonoidNull v) => + IsList (MonoidMap k v) + where + type Item (MonoidMap k v) = (k, v) + fromList = fromList + toList = toList + +instance (Ord k, Read k, MonoidNull v, Read v) => + Read (MonoidMap k v) + where + readPrec = fromMap <$> readPrec + +-------------------------------------------------------------------------------- +-- Instances: Semigroup and subclasses +-------------------------------------------------------------------------------- + +instance (Ord k, MonoidNull v) => + Semigroup (MonoidMap k v) + where + (<>) = append + stimes 0 = const mempty + stimes 1 = id + stimes n = map (stimes n) + +instance (Ord k, MonoidNull v, Commutative v) => + Commutative (MonoidMap k v) + +instance (Ord k, MonoidNull v, LeftReductive v) => + LeftReductive (MonoidMap k v) + where + isPrefixOf = isPrefixOf + stripPrefix = stripPrefix + +instance (Ord k, MonoidNull v, RightReductive v) => + RightReductive (MonoidMap k v) + where + isSuffixOf = isSuffixOf + stripSuffix = stripSuffix + +instance (Ord k, MonoidNull v, Reductive v) => + Reductive (MonoidMap k v) + where + () = minusMaybe + +instance (Ord k, MonoidNull v, LeftCancellative v) => + LeftCancellative (MonoidMap k v) + +instance (Ord k, MonoidNull v, RightCancellative v) => + RightCancellative (MonoidMap k v) + +instance (Ord k, MonoidNull v, Cancellative v) => + Cancellative (MonoidMap k v) + +-------------------------------------------------------------------------------- +-- Instances: Monoid and subclasses +-------------------------------------------------------------------------------- + +instance (Ord k, MonoidNull v) => + Monoid (MonoidMap k v) + where + mempty = empty + +instance (Ord k, MonoidNull v) => + MonoidNull (MonoidMap k v) + where + null = null + +instance (Ord k, PositiveMonoid v) => + PositiveMonoid (MonoidMap k v) + +instance (Ord k, MonoidNull v, LeftGCDMonoid v) => + LeftGCDMonoid (MonoidMap k v) + where + commonPrefix = commonPrefix + +instance (Ord k, MonoidNull v, LeftDistributiveGCDMonoid v) => + LeftDistributiveGCDMonoid (MonoidMap k v) + +instance (Ord k, MonoidNull v, RightGCDMonoid v) => + RightGCDMonoid (MonoidMap k v) + where + commonSuffix = commonSuffix + +instance (Ord k, MonoidNull v, RightDistributiveGCDMonoid v) => + RightDistributiveGCDMonoid (MonoidMap k v) + +instance (Ord k, MonoidNull v, OverlappingGCDMonoid v) => + OverlappingGCDMonoid (MonoidMap k v) + where + overlap = overlap + stripPrefixOverlap = stripPrefixOverlap + stripSuffixOverlap = stripSuffixOverlap + stripOverlap = stripOverlap + +instance (Ord k, MonoidNull v, GCDMonoid v) => + GCDMonoid (MonoidMap k v) + where + gcd = intersection + +instance (Ord k, MonoidNull v, DistributiveGCDMonoid v) => + DistributiveGCDMonoid (MonoidMap k v) + +instance (Ord k, MonoidNull v, LCMMonoid v) => + LCMMonoid (MonoidMap k v) + where + lcm = union + +instance (Ord k, MonoidNull v, DistributiveLCMMonoid v) => + DistributiveLCMMonoid (MonoidMap k v) + +instance (Ord k, MonoidNull v, Monus v) => + Monus (MonoidMap k v) + where + (<\>) = monus + +-------------------------------------------------------------------------------- +-- Instances: Group and subclasses +-------------------------------------------------------------------------------- + +instance (Ord k, MonoidNull v, Group v) => + Group (MonoidMap k v) + where + invert = invert + (~~) = minus + pow = power + +instance (Ord k, MonoidNull v, Abelian v) => + Abelian (MonoidMap k v) + +-------------------------------------------------------------------------------- +-- Construction +-------------------------------------------------------------------------------- + +-- | \(O(1)\). The empty 'MonoidMap'. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k 'empty' '==' 'mempty' +-- @ +-- +-- Provides the definition of 'mempty' for the 'MonoidMap' instance of +-- 'Monoid'. +-- +empty :: MonoidMap k v +empty = MonoidMap Map.empty + +-- | \(O(n \log n)\). Constructs a 'MonoidMap' from a list of key-value pairs. +-- +-- If the list contains more than one value for the same key, values are +-- combined together in the order that they appear with the '(<>)' operator. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('fromList' kvs) '==' +-- 'foldMap' 'snd' ('L.filter' (('==' k) . fst) kvs) +-- @ +-- +-- Satisfies the following round-trip property: +-- +-- @ +-- 'fromList' ('toList' m) '==' m +-- @ +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> 'fromList' [(1,"a"), (2,"x"), (1,"b"), (2,"y"), (1,"c"), (2,"z")] +-- 'fromList' [(1,"abc"), (2,"xyz")] +-- @ +-- +fromList :: (Ord k, MonoidNull v) => [(k, v)] -> MonoidMap k v +fromList = fromListWith (<>) + +-- | \(O(n \log n)\). Constructs a 'MonoidMap' from a list of key-value pairs, +-- with a combining function for values. +-- +-- If the list contains more than one value for the same key, values are +-- combined together in the order that they appear with the given combining +-- function. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('fromListWith' f kvs) '==' +-- 'maybe' 'mempty' ('F.foldl1' f) +-- ('NE.nonEmpty' ('snd' '<$>' 'L.filter' (('==' k) . fst) kvs)) +-- @ +-- +fromListWith + :: (Ord k, MonoidNull v) + => (v -> v -> v) + -- ^ Function with which to combine values for duplicate keys. + -> [(k, v)] + -> MonoidMap k v +fromListWith f = + -- The 'Map.fromListWith' function combines values for duplicate keys in + -- /reverse order/, so we must flip the provided combining function. + fromMap . Map.fromListWith (flip f) + +-- | \(O(n)\). Constructs a 'MonoidMap' from an ordinary 'Map'. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('fromMap' m) '==' 'Map'.'Map.findWithDefault' 'mempty' k m +-- @ +-- +-- This function performs canonicalisation of 'C.null' values, and has a time +-- complexity that is linear in the size of the map. +-- +fromMap :: MonoidNull v => Map k v -> MonoidMap k v +fromMap = MonoidMap . Map.mapMaybe maybeNonNull + +-- | \(O(n)\). Constructs a 'MonoidMap' from an ordinary 'Map', applying +-- the given function to all values. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('fromMapWith' f m) '==' 'maybe' 'mempty' f ('Map'.'Map.lookup' k m) +-- @ +-- +-- This function performs canonicalisation of 'C.null' values, and has a time +-- complexity that is linear in the size of the map. +-- +-- @since 0.0.4.0 +-- +fromMapWith :: MonoidNull v2 => (v1 -> v2) -> Map k v1 -> MonoidMap k v2 +fromMapWith f = MonoidMap . Map.mapMaybe (maybeNonNull . f) + +-- | \(O(n)\). Constructs a 'MonoidMap' from a 'Set' and a function from +-- keys to values. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('fromSet' f ks) '==' +-- if 'Set'.'Set.member' k ks +-- then f k +-- else 'mempty' +-- @ +-- +-- This function performs canonicalisation of 'C.null' values, and has a time +-- complexity that is linear in the 'Set.size' of the set. +-- +-- @since 0.0.2.0 +-- +fromSet :: MonoidNull v => (k -> v) -> Set k -> MonoidMap k v +fromSet f = fromMap . Map.fromSet f + +-- | \(O(1)\). Constructs a 'MonoidMap' from a single key-value pair. +-- +-- Satisfies the following property: +-- +-- @ +-- 'get' k ('singleton' k v) '==' v +-- @ +-- +-- Nullifying the value for key __@k@__ produces an 'empty' map: +-- +-- @ +-- 'nullify' k ('singleton' k v) '==' 'empty' +-- @ +-- +singleton :: (Ord k, MonoidNull v) => k -> v -> MonoidMap k v +singleton k v = set k v mempty + +-------------------------------------------------------------------------------- +-- Deconstruction +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Converts a 'MonoidMap' to a list of key-value pairs, where the +-- keys are in ascending order. +-- +-- The result only includes entries with values that are not 'C.null'. +-- +-- Satisfies the following round-trip property: +-- +-- @ +-- 'fromList' ('toList' m) '==' m +-- @ +-- +-- The resulting list is sorted in ascending key order: +-- +-- @ +-- 'L.sortOn' 'fst' ('toList' m) '==' 'toList' m +-- @ +-- +toList :: MonoidMap k v -> [(k, v)] +toList = Map.toAscList . toMap + +-- | \(O(1)\). Converts a 'MonoidMap' to an ordinary 'Map'. +-- +-- The result only includes entries with values that are not 'C.null'. +-- +-- Satisfies the following round-trip property: +-- +-- @ +-- 'fromMap' ('toMap' m) '==' m +-- @ +-- +toMap :: forall k v. MonoidMap k v -> Map k v +toMap = coerce + +-------------------------------------------------------------------------------- +-- Lookup +-------------------------------------------------------------------------------- + +-- | \(O(\log n)\). Gets the value associated with the given key. +-- +-- By default, every key in an 'empty' map is associated with a value of +-- 'mempty': +-- +-- @ +-- ∀ k. 'get' k 'empty' '==' 'mempty' +-- @ +-- +get :: (Ord k, Monoid v) => k -> MonoidMap k v -> v +get k m = fromMaybe mempty $ Map.lookup k $ toMap m + +-------------------------------------------------------------------------------- +-- Modification +-------------------------------------------------------------------------------- + +-- | \(O(\log n)\). Sets the value associated with the given key. +-- +-- Satisfies the following property: +-- +-- @ +-- 'get' k ('set' k v m) '==' v +-- @ +-- +set :: (Ord k, MonoidNull v) => k -> v -> MonoidMap k v -> MonoidMap k v +set k v (MonoidMap m) = MonoidMap $ case maybeNonNull v of + Just v0 -> Map.insert k v0 m + Nothing -> Map.delete k m + +-- | \(O(\log n)\). Adjusts the value associated with the given key. +-- +-- Satisfies the following property: +-- +-- @ +-- 'adjust' f k m '==' 'set' k (f ('get' k m)) m +-- @ +-- +adjust + :: (Ord k, MonoidNull v) + => (v -> v) + -> k + -> MonoidMap k v + -> MonoidMap k v +adjust f k (MonoidMap m) = MonoidMap $ + Map.alter (maybeNonNull . maybe (f mempty) (applyNonNull f)) k m + +-- | \(O(\log n)\). Sets the value associated with the given key to 'mempty'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'get' k ('nullify' k m) '==' 'mempty' +-- @ +-- +nullify :: Ord k => k -> MonoidMap k v -> MonoidMap k v +nullify k (MonoidMap m) = MonoidMap $ Map.delete k m + +-------------------------------------------------------------------------------- +-- Membership +-------------------------------------------------------------------------------- + +-- | \(O(1)\). Returns 'True' if (and only if) all values in the map are +-- 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'null' m '==' (∀ k. 'nullKey' k m) +-- @ +-- +-- Provides the definition of 'C.null' for the 'MonoidMap' instance of +-- 'MonoidNull'. +-- +null :: MonoidMap k v -> Bool +null = Map.null . toMap + +-- | \(O(\log n)\). Returns 'True' if (and only if) the given key is associated +-- with a value that is 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'nullKey' k m '==' 'C.null' ('get' k m) +-- @ +-- +nullKey :: Ord k => k -> MonoidMap k v -> Bool +nullKey k = Map.notMember k . toMap + +-- | \(O(1)\). Returns 'True' if (and only if) the map contains at least one +-- value that is not 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'nonNull' m '==' (∃ k. 'nonNullKey' k m) +-- @ +-- +nonNull :: MonoidMap k v -> Bool +nonNull = not . null + +-- | \(O(1)\). Returns a count of all values in the map that are not 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'nonNullCount' m '==' 'Set.size' ('nonNullKeys' m) +-- @ +-- +nonNullCount :: MonoidMap k v -> Int +nonNullCount = Map.size . toMap + +-- | \(O(\log n)\). Returns 'True' if (and only if) the given key is associated +-- with a value that is not 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'nonNullKey' k m '==' 'not' ('C.null' ('get' k m)) +-- @ +-- +nonNullKey :: Ord k => k -> MonoidMap k v -> Bool +nonNullKey k = Map.member k . toMap + +-- | \(O(n)\). Returns the set of keys associated with values that are not +-- 'C.null'. +-- +-- Satisfies the following property: +-- +-- @ +-- k '`Set.member`' ('nonNullKeys' m) '==' 'nonNullKey' k m +-- @ +-- +nonNullKeys :: MonoidMap k v -> Set k +nonNullKeys = Map.keysSet . toMap + +-------------------------------------------------------------------------------- +-- Slicing +-------------------------------------------------------------------------------- + +-- | \(O(\log n)\). /Takes/ a slice from a map. +-- +-- This function takes a given number of non-'C.null' entries from a map, +-- producing a new map from the entries that were /taken/. +-- +-- Entries are taken in /key order/, beginning with the /smallest/ keys. +-- +-- Satifies the following property: +-- +-- @ +-- 'take' n '==' 'fromList' . 'Prelude.take' n . 'toList' +-- @ +-- +take :: Int -> MonoidMap k v -> MonoidMap k v +take i (MonoidMap m) = MonoidMap (Map.take i m) + +-- | \(O(\log n)\). /Drops/ a slice from a map. +-- +-- This function drops a given number of non-'C.null' entries from a map, +-- producing a new map from the entries that /remain/. +-- +-- Entries are dropped in /key order/, beginning with the /smallest/ keys. +-- +-- Satifies the following property: +-- +-- @ +-- 'drop' n '==' 'fromList' . 'Prelude.drop' n . 'toList' +-- @ +-- +drop :: Int -> MonoidMap k v -> MonoidMap k v +drop i (MonoidMap m) = MonoidMap (Map.drop i m) + +-- | \(O(\log n)\). /Splits/ a map into /two/ slices. +-- +-- This function is equivalent to a combination of 'take' and 'drop': +-- +-- @ +-- 'splitAt' n m '==' ('take' n m, 'drop' n m) +-- @ +-- +-- The resulting maps can be combined to reproduce the original map: +-- +-- @ +-- 'splitAt' n m '&' +-- \\(m1, m2) -> m1 '<>' m2 '==' m +-- @ +-- +-- The resulting maps have disjoint sets of non-'C.null' entries: +-- +-- @ +-- 'splitAt' n m '&' +-- \\(m1, m2) -> 'Set.disjoint' ('nonNullKeys' m1) ('nonNullKeys' m2) +-- @ +-- +splitAt :: Int -> MonoidMap k a -> (MonoidMap k a, MonoidMap k a) +splitAt i m = (take i m, drop i m) + +-------------------------------------------------------------------------------- +-- Filtering +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Filters a map according to a predicate on /values/. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('filter' f m) '==' +-- if f ('get' k m) +-- then 'get' k m +-- else 'mempty' +-- @ +-- +-- The resulting map is identical to that obtained by constructing a map from a +-- filtered list of key-value pairs: +-- +-- @ +-- 'filter' f m '==' 'fromList' ('L.filter' (f . 'snd') ('toList' m)) +-- @ +-- +filter :: (v -> Bool) -> MonoidMap k v -> MonoidMap k v +filter f (MonoidMap m) = MonoidMap $ Map.filter (applyNonNull f) m + +-- | \(O(n)\). Filters a map according to a predicate on /keys/. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('filterKeys' f m) '==' +-- if f k +-- then 'get' k m +-- else 'mempty' +-- @ +-- +-- The resulting map is identical to that obtained by constructing a map from a +-- filtered list of key-value pairs: +-- +-- @ +-- 'filter' f m '==' 'fromList' ('L.filter' (f . 'fst') ('toList' m)) +-- @ +-- +filterKeys :: (k -> Bool) -> MonoidMap k v -> MonoidMap k v +filterKeys f (MonoidMap m) = MonoidMap $ Map.filterWithKey (\k _ -> f k) m + +-- | \(O(n)\). Filters a map according to a predicate on /keys and values/. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('filterWithKey' f m) '==' +-- if f k ('get' k m) +-- then 'get' k m +-- else 'mempty' +-- @ +-- +-- The resulting map is identical to that obtained by constructing a map from a +-- filtered list of key-value pairs: +-- +-- @ +-- 'filterWithKey' f m '==' 'fromList' ('L.filter' ('uncurry' f) ('toList' m)) +-- @ +-- +filterWithKey :: (k -> v -> Bool) -> MonoidMap k v -> MonoidMap k v +filterWithKey f (MonoidMap m) = + MonoidMap $ Map.filterWithKey (applyNonNull . f) m + +-------------------------------------------------------------------------------- +-- Partitioning +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Partitions a map according to a predicate on /values/. +-- +-- Satisfies the following property: +-- +-- @ +-- 'partition' f m '==' +-- ( 'filter' \ \ f m +-- , 'filter' ('not' . f) m +-- ) +-- @ +-- +-- The resulting maps can be combined to reproduce the original map: +-- +-- @ +-- 'partition' f m '&' \\(m1, m2) -> +-- m1 '<>' m2 '==' m +-- @ +-- +-- The resulting maps have disjoint sets of non-'C.null' entries: +-- +-- @ +-- 'partition' f m '&' \\(m1, m2) -> +-- 'Set.disjoint' +-- ('nonNullKeys' m1) +-- ('nonNullKeys' m2) +-- @ +-- +partition :: (v -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) +partition f (MonoidMap m) = + B.bimap MonoidMap MonoidMap $ Map.partition (applyNonNull f) m + +-- | \(O(n)\). Partitions a map according to a predicate on /keys/. +-- +-- Satisfies the following property: +-- +-- @ +-- 'partitionKeys' f m '==' +-- ( 'filterKeys' \ \ f m +-- , 'filterKeys' ('not' . f) m +-- ) +-- @ +-- +-- The resulting maps can be combined to reproduce the original map: +-- +-- @ +-- 'partitionKeys' f m '&' \\(m1, m2) -> +-- m1 '<>' m2 '==' m +-- @ +-- +-- The resulting maps have disjoint sets of non-'C.null' entries: +-- +-- @ +-- 'partitionKeys' f m '&' \\(m1, m2) -> +-- 'Set.disjoint' +-- ('nonNullKeys' m1) +-- ('nonNullKeys' m2) +-- @ +-- +partitionKeys + :: (k -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) +partitionKeys f (MonoidMap m) = + B.bimap MonoidMap MonoidMap $ Map.partitionWithKey (\k _ -> f k) m + +-- | \(O(n)\). Partitions a map according to a predicate on /keys and values/. +-- +-- Satisfies the following property: +-- +-- @ +-- 'partitionWithKey' f m '==' +-- ( 'filterWithKey' \ \ \ \ \ \ f m +-- , 'filterWithKey' (('fmap' . 'fmap') 'not' f) m +-- ) +-- @ +-- +-- The resulting maps can be combined to reproduce the original map: +-- +-- @ +-- 'partitionWithKey' f m '&' \\(m1, m2) -> +-- m1 '<>' m2 '==' m +-- @ +-- +-- The resulting maps have disjoint sets of non-'C.null' entries: +-- +-- @ +-- 'partitionWithKey' f m '&' \\(m1, m2) -> +-- 'Set.disjoint' +-- ('nonNullKeys' m1) +-- ('nonNullKeys' m2) +-- @ +-- +partitionWithKey + :: (k -> v -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) +partitionWithKey f (MonoidMap m) = + B.bimap MonoidMap MonoidMap $ Map.partitionWithKey (applyNonNull . f) m + +-------------------------------------------------------------------------------- +-- Mapping +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Applies a function to all non-'C.null' values of a 'MonoidMap'. +-- +-- Satisfies the following properties for all functions __@f@__: +-- +-- @ +-- ('get' k m '==' 'mempty') ==> ('get' k ('map' f m) '==' 'mempty' ) +-- ('get' k m '/=' 'mempty') ==> ('get' k ('map' f m) '==' f ('get' k m)) +-- @ +-- +-- === Conditional properties +-- +-- If applying function __@f@__ to 'mempty' produces 'mempty', then the +-- following additional properties hold: +-- +-- @ +-- (f 'mempty' '==' 'mempty') +-- ==> +-- (∀ k. 'get' k ('map' f m) '==' f ('get' k m)) +-- @ +-- +-- @ +-- (f 'mempty' '==' 'mempty') +-- ==> +-- (∀ g. 'map' (f . g) m '==' 'map' f ('map' g m)) +-- @ +-- +map + :: MonoidNull v2 + => (v1 -> v2) + -> MonoidMap k v1 + -> MonoidMap k v2 +map f (MonoidMap m) = + MonoidMap $ Map.mapMaybe (maybeNonNull . applyNonNull f) m + +-- | \(O(n \log n)\). Applies a function to all the keys of a 'MonoidMap' that +-- are associated with non-'C.null' values. +-- +-- If the resultant map would contain more than one value for the same key, +-- values are combined together in ascending key order with the '(<>)' +-- operator. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('mapKeys' f m) '==' +-- 'F.foldMap' +-- ('`get`' m) +-- ('Set.filter' (('==') k . f) ('nonNullKeys' m)) +-- @ +-- +mapKeys + :: (Ord k2, MonoidNull v) + => (k1 -> k2) + -> MonoidMap k1 v + -> MonoidMap k2 v +mapKeys = mapKeysWith (<>) + +-- | \(O(n \log n)\). Applies a function to all the keys of a 'MonoidMap' that +-- are associated with non-'C.null' values, with a combining function for +-- values. +-- +-- If the resultant map would contain more than one value for the same key, +-- values are combined together in ascending key order with the given +-- combining function. +-- +-- Satisfies the following property: +-- +-- @ +-- 'mapKeysWith' c f '==' 'fromListWith' c . 'fmap' ('B.first' f) . 'toList' +-- @ +-- +mapKeysWith + :: (Ord k2, MonoidNull v) + => (v -> v -> v) + -- ^ Function with which to combine values for duplicate keys. + -> (k1 -> k2) + -> MonoidMap k1 v + -> MonoidMap k2 v +mapKeysWith combine fk = fromListWith combine . fmap (B.first fk) . toList + +-- | \(O(n)\). Applies a key-dependent function to all non-'C.null' values of +-- a 'MonoidMap'. +-- +-- Satisfies the following properties for all functions __@f@__: +-- +-- @ +-- ('nonNullKey' k m) ==> ('get' k ('mapWithKey' f m) '==' f k ('get' k m)) +-- ( 'nullKey' k m) ==> ('get' k ('mapWithKey' f m) '==' 'mempty' ) +-- @ +-- +-- @since 0.0.3.0 +-- +mapWithKey + :: MonoidNull v2 + => (k -> v1 -> v2) + -> MonoidMap k v1 + -> MonoidMap k v2 +mapWithKey f (MonoidMap m) = + MonoidMap . runIdentity $ + Map.traverseMaybeWithKey + (\k v -> Identity $ maybeNonNull $ applyNonNull (f k) v) m + +-------------------------------------------------------------------------------- +-- Lazy folding +-------------------------------------------------------------------------------- + +-- | \(O(n)\). Folds over the values in the map using the given +-- left-associative binary operator. +-- +-- Satisfies the following property: +-- +-- @ +-- 'foldl' f r m '==' 'Map'.'Map.foldl' f r ('toMap' m) +-- @ +-- +-- @since 0.0.1.7 +-- +foldl :: (r -> v -> r) -> r -> MonoidMap k v -> r +foldl = + (coerce + :: ((r -> v -> r) -> r -> Map k v -> r) + -> ((r -> v -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldl +{-# INLINE foldl #-} + +-- | \(O(n)\). Folds over the values in the map using the given +-- right-associative binary operator. +-- +-- Satisfies the following property: +-- +-- @ +-- 'foldr' f r m '==' 'Map'.'Map.foldr' f r ('toMap' m) +-- @ +-- +-- @since 0.0.1.7 +-- +foldr :: (v -> r -> r) -> r -> MonoidMap k v -> r +foldr = + (coerce + :: ((v -> r -> r) -> r -> Map k v -> r) + -> ((v -> r -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldr +{-# INLINE foldr #-} + +-- | \(O(n)\). Folds over the keys and values in the map using the given +-- left-associative binary operator. +-- +-- Satisfies the following property: +-- +-- @ +-- 'foldlWithKey' f r m '==' 'Map'.'Map.foldlWithKey' f r ('toMap' m) +-- @ +-- +-- @since 0.0.1.7 +-- +foldlWithKey :: (r -> k -> v -> r) -> r -> MonoidMap k v -> r +foldlWithKey = + (coerce + :: ((r -> k -> v -> r) -> r -> Map k v -> r) + -> ((r -> k -> v -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldlWithKey +{-# INLINE foldlWithKey #-} + +-- | \(O(n)\). Folds over the keys and values in the map using the given +-- right-associative binary operator. +-- +-- Satisfies the following property: +-- +-- @ +-- 'foldrWithKey' f r m '==' 'Map'.'Map.foldrWithKey' f r ('toMap' m) +-- @ +-- +-- @since 0.0.1.7 +-- +foldrWithKey :: (k -> v -> r -> r) -> r -> MonoidMap k v -> r +foldrWithKey = + (coerce + :: ((k -> v -> r -> r) -> r -> Map k v -> r) + -> ((k -> v -> r -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldrWithKey +{-# INLINE foldrWithKey #-} + +-- | \(O(n)\). Folds over the keys and values in the map using the given +-- monoid. +-- +-- Satisfies the following property: +-- +-- @ +-- 'foldMapWithKey' f m '==' 'Map'.'Map.foldMapWithKey' f ('toMap' m) +-- @ +-- +-- @since 0.0.1.7 +-- +foldMapWithKey :: Monoid r => (k -> v -> r) -> MonoidMap k v -> r +foldMapWithKey = + (coerce + :: ((k -> v -> r) -> Map k v -> r) + -> ((k -> v -> r) -> MonoidMap k v -> r) + ) + Map.foldMapWithKey +{-# INLINE foldMapWithKey #-} + +-------------------------------------------------------------------------------- +-- Strict folding +-------------------------------------------------------------------------------- + +-- | \(O(n)\). A strict version of 'foldl'. +-- +-- Each application of the operator is evaluated before using the result in the +-- next application. This function is strict in the starting value. +-- +-- @since 0.0.1.7 +-- +foldl' :: (r -> v -> r) -> r -> MonoidMap k v -> r +foldl' = + (coerce + :: ((r -> v -> r) -> r -> Map k v -> r) + -> ((r -> v -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldl' +{-# INLINE foldl' #-} + +-- | \(O(n)\). A strict version of 'foldr'. +-- +-- Each application of the operator is evaluated before using the result in the +-- next application. This function is strict in the starting value. +-- +-- @since 0.0.1.7 +-- +foldr' :: (v -> r -> r) -> r -> MonoidMap k v -> r +foldr' = + (coerce + :: ((v -> r -> r) -> r -> Map k v -> r) + -> ((v -> r -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldr' +{-# INLINE foldr' #-} + +-- | \(O(n)\). A strict version of 'foldlWithKey'. +-- +-- Each application of the operator is evaluated before using the result in the +-- next application. This function is strict in the starting value. +-- +-- @since 0.0.1.7 +-- +foldlWithKey' :: (r -> k -> v -> r) -> r -> MonoidMap k v -> r +foldlWithKey' = + (coerce + :: ((r -> k -> v -> r) -> r -> Map k v -> r) + -> ((r -> k -> v -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldlWithKey' +{-# INLINE foldlWithKey' #-} + +-- | \(O(n)\). A strict version of 'foldrWithKey'. +-- +-- Each application of the operator is evaluated before using the result in the +-- next application. This function is strict in the starting value. +-- +-- @since 0.0.1.7 +-- +foldrWithKey' :: (k -> v -> r -> r) -> r -> MonoidMap k v -> r +foldrWithKey' = + (coerce + :: ((k -> v -> r -> r) -> r -> Map k v -> r) + -> ((k -> v -> r -> r) -> r -> MonoidMap k v -> r) + ) + Map.foldrWithKey' +{-# INLINE foldrWithKey' #-} + +-- | \(O(n)\). A strict version of 'foldMapWithKey'. +-- +-- Each application of `mappend` is evaluated before using the result in the +-- next application. +-- +-- @since 0.0.1.8 +-- +foldMapWithKey' :: Monoid r => (k -> v -> r) -> MonoidMap k v -> r +foldMapWithKey' f = foldlWithKey' (\r k v -> r <> f k v) mempty +{-# 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 +-------------------------------------------------------------------------------- + +-- | Indicates whether or not the first map is a /submap/ of the second. +-- +-- Map __@m1@__ is a submap of map __@m2@__ if (and only if) __@m1@__ can be +-- subtracted from __@m2@__ with the 'minusMaybe' operation: +-- +-- @ +-- m1 '`isSubmapOf`' m2 '==' 'isJust' (m2 '`minusMaybe`' m1) +-- @ +-- +-- Equivalently, map __@m1@__ is a submap of map __@m2@__ if (and only if) for +-- all possible keys __@k@__, the value for __@k@__ in __@m1@__ can be +-- subtracted from the value for __@k@__ in __@m2@__ with the '()' operator: +-- +-- @ +-- m1 '`isSubmapOf`' m2 '==' (∀ k. 'isJust' ('get' k m2 '' 'get' k m1)) +-- @ +-- +isSubmapOf + :: (Ord k, Monoid v, Reductive v) + => MonoidMap k v + -> MonoidMap k v + -> Bool +isSubmapOf = isSubmapOfBy $ \v1 v2 -> isJust (v2 v1) +{-# INLINE isSubmapOf #-} + +-- | Indicates whether or not the first map is a /submap/ of the second, using +-- the given function to compare values for matching keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'isSubmapOfBy' f m1 m2 '==' +-- 'all' (\\k -> f ('get' k m1) ('get' k m2)) ('nonNullKeys' m1) +-- @ +-- +-- === Conditional totality +-- +-- /If/ the given comparison function __@f@__ /always/ evaluates to 'True' +-- when its first argument is 'mempty': +-- +-- @ +-- ∀ v. f 'mempty' v +-- @ +-- +-- /Then/ the following property holds: +-- +-- @ +-- 'isSubmapOfBy' f m1 m2 '==' (∀ k. f ('get' k m1) ('get' k m2)) +-- @ +-- +isSubmapOfBy + :: (Ord k, Monoid v1, Monoid v2) + => (v1 -> v2 -> Bool) + -- ^ Function with which to compare values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> Bool +isSubmapOfBy leq m1 m2 = + all + (\k -> get k m1 `leq` get k m2) + (nonNullKeys m1) +{-# INLINE isSubmapOfBy #-} + +-- | Indicates whether or not a pair of maps are /disjoint/. +-- +-- Maps __@m1@__ and __@m2@__ are disjoint if (and only if) their intersection +-- is empty: +-- +-- @ +-- 'disjoint' m1 m2 '==' ('intersection' m1 m2 '==' 'mempty') +-- @ +-- +-- Equivalently, maps __@m1@__ and __@m2@__ are disjoint if (and only if) for +-- all possible keys __@k@__, the values for __@k@__ in __@m1@__ and __@m2@__ +-- have a 'C.gcd' that is 'C.null': +-- +-- @ +-- 'disjoint' m1 m2 '==' (∀ k. 'C.null' ('C.gcd' ('get' k m1) ('get' k m2))) +-- @ +-- +disjoint + :: (Ord k, GCDMonoid v, MonoidNull v) + => MonoidMap k v + -> MonoidMap k v + -> Bool +disjoint = disjointBy (\v1 v2 -> C.null (C.gcd v1 v2)) +{-# INLINE disjoint #-} + +-- | Indicates whether or not a pair of maps are /disjoint/ using the given +-- indicator function to test pairs of values for matching keys. +-- +-- Satisfies the following property: +-- +-- @ +-- 'disjointBy' f m1 m2 '==' +-- 'all' +-- (\\k -> f ('get' k m1) ('get' k m2)) +-- ('Set.intersection' ('nonNullKeys' m1) ('nonNullKeys' m2)) +-- @ +-- +-- === Conditional totality +-- +-- /If/ the given indicator function __@f@__ /always/ evaluates to 'True' +-- when /either/ or /both/ of its arguments are 'mempty': +-- +-- @ +-- ∀ v. (f v 'mempty') '&&' (f 'mempty' v) +-- @ +-- +-- /Then/ the following property holds: +-- +-- @ +-- 'disjointBy' f m1 m2 '==' (∀ k. f ('get' k m1) ('get' k m2)) +-- @ +-- +disjointBy + :: (Ord k, Monoid v1, Monoid v2) + => (v1 -> v2 -> Bool) + -- ^ Function with which to test pairs of values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> Bool +disjointBy f m1 m2 = + all + (\k -> f (get k m1) (get k m2)) + (Set.intersection (nonNullKeys m1) (nonNullKeys m2)) +{-# INLINE disjointBy #-} + +-------------------------------------------------------------------------------- +-- Association +-------------------------------------------------------------------------------- + +-- | Appends a pair of maps together. +-- +-- Uses the 'Semigroup' operator '(<>)' to append each value in the first map +-- to its matching value in the second map. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('append' m1 m2) '==' 'get' k m1 '<>' 'get' k m2 +-- @ +-- +-- This function provides the definition of '(<>)' for the 'MonoidMap' instance +-- of 'Semigroup'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1, "abc"), (2, "ij" ), (3, "p" ) ] +-- >>> m2 = 'fromList' [ (2, " k"), (3, "qr"), (4, "xyz")] +-- >>> m3 = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] +-- @ +-- @ +-- >>> 'append' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 4), ("b", 2), ("c", 1) ] +-- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 4)] +-- >>> m3 = 'fromList' [("a", 4), ("b", 3), ("c", 3), ("d", 4)] +-- @ +-- @ +-- >>> 'append' m1 m2 '==' m3 +-- 'True' +-- @ +-- +append + :: (Ord k, MonoidNull v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +append = merge MergeStrategy + { withNonNullL = + keepNonNull + -- Justification: + -- + -- v <> mempty ≡ v + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- mempty <> v ≡ v + + , withNonNullP = + withBoth (<>) + } +{-# INLINE append #-} + +-------------------------------------------------------------------------------- +-- Prefixes and suffixes +-------------------------------------------------------------------------------- + +-- | Indicates whether or not the first map is a /prefix/ of the second. +-- +-- 'MonoidMap' __@m1@__ is a /prefix/ of 'MonoidMap' __@m2@__ if (and only if) +-- for all possible keys __@k@__, the value for __@k@__ in __@m1@__ is a +-- /prefix/ of the value for __@k@__ in __@m2@__: +-- +-- @ +-- m1 '`isPrefixOf`' m2 '==' (∀ k. 'get' k m1 '`C.isPrefixOf`' 'get' k m2) +-- @ +-- +-- This function provides the definition of 'C.isPrefixOf' for the 'MonoidMap' +-- instance of 'LeftReductive'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1, "a" ), (2, "p" ), (3, "x" )] +-- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isPrefixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [ (2, "p" ) ] +-- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isPrefixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [(1, "abc"), (2, "p" ), (3, "x" )] +-- >>> m2 = 'fromList' [(1, "a" ), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isPrefixOf`' m2 +-- 'False' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 1), ("b", 1), ("c", 1)] +-- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] +-- >>> m1 '`isPrefixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [ ("b", 1) ] +-- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] +-- >>> m1 '`isPrefixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 1), ("c", 1)] +-- >>> m2 = 'fromList' [("a", 1), ("b", 4), ("c", 8)] +-- >>> m1 '`isPrefixOf`' m2 +-- 'False' +-- @ +-- +isPrefixOf + :: (Ord k, Monoid v, LeftReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Bool +isPrefixOf = isSubmapOfBy C.isPrefixOf + -- Note that in practice, it's sufficient to check the following property: + -- + -- @ + -- m1 '`isPrefixOf`' m2 '==' + -- 'all' + -- (\\k -> 'get' k m1 '`C.isPrefixOf`' 'get' k m2) + -- ('nonNullKeys' m1) + -- @ + -- + -- ==== Justification + -- + -- According to the laws for 'LeftReductive': + -- + -- @ + -- ∀ a b. b '`C.isPrefixOf`' (b '<>' a) + -- @ + -- + -- Substituting 'mempty' for @b@: + -- + -- @ + -- ∀ a. 'mempty' '`C.isPrefixOf`' ('mempty' '<>' a) + -- @ + -- + -- According to the left identity law for 'Monoid': + -- + -- @ + -- ∀ a. 'mempty' '<>' a '==' a + -- @ + -- + -- We can therefore assert that: + -- + -- @ + -- ∀ a. 'mempty' '`C.isPrefixOf`' a + -- @ + -- + -- Since 'mempty' is /always/ a valid prefix, we only need to consider + -- values in 'm1' that are /not/ 'mempty'. + -- + -- The 'nonNullKeys' function, when applied to 'm1', gives us /precisely/ + -- the set of keys that are not associated with 'mempty' in 'm1': + -- + -- @ + -- (k '`Data.Set.member`' 'nonNullKeys' m1) '==' ('get' k m1 '/=' 'mempty') + -- @ + -- +{-# INLINE isPrefixOf #-} + +-- | Indicates whether or not the first map is a /suffix/ of the second. +-- +-- 'MonoidMap' __@m1@__ is a /suffix/ of 'MonoidMap' __@m2@__ if (and only if) +-- for all possible keys __@k@__, the value for __@k@__ in __@m1@__ is a +-- /suffix/ of the value for __@k@__ in __@m2@__: +-- +-- @ +-- m1 '`isSuffixOf`' m2 '==' (∀ k. 'get' k m1 '`C.isSuffixOf`' 'get' k m2) +-- @ +-- +-- This function provides the definition of 'C.isSuffixOf' for the 'MonoidMap' +-- instance of 'RightReductive'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1, "c"), (2, "r"), (3, "z")] +-- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isSuffixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [ (2, "r") ] +-- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isSuffixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [(1, "abc"), (2, "r"), (3, "z")] +-- >>> m2 = 'fromList' [(1, "c"), (2, "pqr"), (3, "xyz")] +-- >>> m1 '`isSuffixOf`' m2 +-- 'False' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 1), ("b", 1), ("c", 1)] +-- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] +-- >>> m1 '`isSuffixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [ ("b", 1) ] +-- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] +-- >>> m1 '`isSuffixOf`' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 1), ("c", 1)] +-- >>> m2 = 'fromList' [("a", 1), ("b", 4), ("c", 8)] +-- >>> m1 '`isSuffixOf`' m2 +-- 'False' +-- @ +-- +isSuffixOf + :: (Ord k, Monoid v, RightReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Bool +isSuffixOf = isSubmapOfBy C.isSuffixOf + -- Note that in practice, it's sufficient to check the following property: + -- + -- @ + -- m1 '`isSuffixOf`' m2 '==' + -- 'all' + -- (\\k -> 'get' k m1 '`C.isSuffixOf`' 'get' k m2) + -- ('nonNullKeys' m1) + -- @ + -- + -- ==== Justification + -- + -- According to the laws for 'RightReductive': + -- + -- @ + -- ∀ a b. b '`C.isSuffixOf`' (a '<>' b) + -- @ + -- + -- Substituting 'mempty' for @b@: + -- + -- @ + -- ∀ a. 'mempty' '`C.isSuffixOf`' (a '<>' 'mempty') + -- @ + -- + -- According to the right identity law for 'Monoid': + -- + -- @ + -- ∀ a. a '<>' 'mempty' '==' a + -- @ + -- + -- We can therefore assert that: + -- + -- @ + -- ∀ a. 'mempty' '`C.isSuffixOf`' a + -- @ + -- + -- Since 'mempty' is /always/ a valid suffix, we only need to consider + -- values in 'm1' that are /not/ 'mempty'. + -- + -- The 'nonNullKeys' function, when applied to 'm1', gives us /precisely/ + -- the set of keys that are not associated with 'mempty' in 'm1': + -- + -- @ + -- (k '`Data.Set.member`' 'nonNullKeys' m1) '==' ('get' k m1 '/=' 'mempty') + -- @ + -- +{-# INLINE isSuffixOf #-} + +-- | Strips a /prefix/ from a 'MonoidMap'. +-- +-- If map __@m1@__ is a /prefix/ of map __@m2@__, then 'stripPrefix' __@m1@__ +-- __@m2@__ will produce a /reduced/ map where prefix __@m1@__ is /stripped/ +-- from __@m2@__. +-- +-- === Properties +-- +-- The 'stripPrefix' function, when applied to maps __@m1@__ and __@m2@__, +-- produces a result if (and only if) __@m1@__ is a prefix of __@m2@__: +-- +-- @ +-- 'isJust' ('stripPrefix' m1 m2) '==' m1 '`isPrefixOf`' m2 +-- @ +-- +-- The value for any key __@k@__ in the result is /identical/ to the result of +-- stripping the value for __@k@__ in map __@m1@__ from the value for __@k@__ +-- in map __@m2@__: +-- +-- @ +-- 'all' +-- (\\r -> 'Just' ('get' k r) '==' 'C.stripPrefix' ('get' k m1) ('get' k m2)) +-- ('stripPrefix' m1 m2) +-- @ +-- +-- If we append prefix __@m1@__ to the /left-hand/ side of the result, we can +-- always recover the original map __@m2@__: +-- +-- @ +-- 'all' +-- (\\r -> m1 '<>' r '==' m2) +-- ('stripPrefix' m1 m2) +-- @ +-- +-- This function provides the definition of 'C.stripPrefix' for the 'MonoidMap' +-- instance of 'LeftReductive'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [(1, "" ), (2, "i" ), (3, "pq" ), (4, "xyz")] +-- >>> __m2__ = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] +-- >>> __m3__ = 'fromList' [(1, "abc"), (2, "jk"), (3, "r"), (4, "")] +-- @ +-- @ +-- >>> 'stripPrefix' __m1__ __m2__ '==' 'Just' __m3__ +-- 'True' +-- @ +-- @ +-- >>> 'stripPrefix' __m2__ __m1__ '==' 'Nothing' +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> __m2__ = 'fromList' [("a", 3), ("b", 3), ("c", 3), ("d", 3)] +-- >>> __m3__ = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] +-- @ +-- @ +-- >>> 'stripPrefix' __m1__ __m2__ '==' 'Just' __m3__ +-- 'True' +-- @ +-- @ +-- >>> 'stripPrefix' __m2__ __m1__ '==' 'Nothing' +-- 'True' +-- @ +-- +stripPrefix + :: (Ord k, MonoidNull v, LeftReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Maybe (MonoidMap k v) +stripPrefix = mergeA MergeStrategy + { withNonNullL = + withNonNullA (\v -> C.stripPrefix v mempty) + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- stripPrefix mempty a ≡ a + + , withNonNullP = + withBothA C.stripPrefix + } +{-# INLINE stripPrefix #-} + +-- | Strips a /suffix/ from a 'MonoidMap'. +-- +-- If map __@m1@__ is a /suffix/ of map __@m2@__, then 'stripSuffix' __@m1@__ +-- __@m2@__ will produce a /reduced/ map where suffix __@m1@__ is /stripped/ +-- from __@m2@__. +-- +-- === Properties +-- +-- The 'stripSuffix' function, when applied to maps __@m1@__ and __@m2@__, +-- produces a result if (and only if) __@m1@__ is a suffix of __@m2@__: +-- +-- @ +-- 'isJust' ('stripSuffix' m1 m2) '==' m1 '`isSuffixOf`' m2 +-- @ +-- +-- The value for any key __@k@__ in the result is /identical/ to the result of +-- stripping the value for __@k@__ in map __@m1@__ from the value for __@k@__ +-- in map __@m2@__: +-- +-- @ +-- 'all' +-- (\\r -> 'Just' ('get' k r) '==' 'C.stripSuffix' ('get' k m1) ('get' k m2)) +-- ('stripSuffix' m1 m2) +-- @ +-- +-- If we append suffix __@m1@__ to the /right-hand/ side of the result, we can +-- always recover the original map __@m2@__: +-- +-- @ +-- 'all' +-- (\\r -> r '<>' m1 '==' m2) +-- ('stripSuffix' m1 m2) +-- @ +-- +-- This function provides the definition of 'C.stripSuffix' for the 'MonoidMap' +-- instance of 'RightReductive'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [(1, ""), (2, "k"), (3, "qr"), (4, "xyz")] +-- >>> __m2__ = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] +-- >>> __m3__ = 'fromList' [(1, "abc"), (2, "ij" ), (3, "p" ), (4, "" )] +-- @ +-- @ +-- >>> 'stripSuffix' __m1__ __m2__ '==' 'Just' __m3__ +-- 'True' +-- @ +-- @ +-- >>> 'stripSuffix' __m2__ __m1__ '==' 'Nothing' +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> __m2__ = 'fromList' [("a", 3), ("b", 3), ("c", 3), ("d", 3)] +-- >>> __m3__ = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] +-- @ +-- @ +-- >>> 'stripSuffix' __m1__ __m2__ '==' 'Just' __m3__ +-- 'True' +-- @ +-- @ +-- >>> 'stripSuffix' __m2__ __m1__ '==' 'Nothing' +-- 'True' +-- @ +-- +stripSuffix + :: (Ord k, MonoidNull v, RightReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Maybe (MonoidMap k v) +stripSuffix = mergeA MergeStrategy + { withNonNullL = + withNonNullA (\v -> C.stripSuffix v mempty) + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- stripSuffix mempty a ≡ a + + , withNonNullP = + withBothA C.stripSuffix + } +{-# INLINE stripSuffix #-} + +-- | Finds the /greatest common prefix/ of two maps. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('commonPrefix' m1 m2) +-- '==' 'C.commonPrefix' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.commonPrefix' for the +-- 'MonoidMap' instance of 'LeftGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [(1, "+++"), (2, "b++"), (3, "cc+"), (4, "ddd")] +-- >>> __m2__ = 'fromList' [(1, "---"), (2, "b--"), (3, "cc-"), (4, "ddd")] +-- >>> __m3__ = 'fromList' [(1, "" ), (2, "b" ), (3, "cc" ), (4, "ddd")] +-- @ +-- @ +-- >>> 'commonPrefix' __m1__ __m2__ '==' __m3__ +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> __m2__ = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] +-- >>> __m3__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 2)] +-- @ +-- @ +-- >>> 'commonPrefix' __m1__ __m2__ '==' __m3__ +-- 'True' +-- @ +-- +commonPrefix + :: (Ord k, MonoidNull v, LeftGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +commonPrefix = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- commonPrefix a mempty ≡ mempty + + , withNonNullR = + keepNull + -- Justification: + -- + -- commonPrefix mempty a ≡ mempty + + , withNonNullP = + withBoth C.commonPrefix + } +{-# INLINE commonPrefix #-} + +-- | Finds the /greatest common suffix/ of two maps. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('commonSuffix' m1 m2) +-- '==' 'C.commonSuffix' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.commonSuffix' for the +-- 'MonoidMap' instance of 'RightGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [(1, "+++"), (2, "++b"), (3, "+cc"), (4, "ddd")] +-- >>> __m2__ = 'fromList' [(1, "---"), (2, "--b"), (3, "-cc"), (4, "ddd")] +-- >>> __m3__ = 'fromList' [(1, ""), (2, "b"), (3, "cc"), (4, "ddd")] +-- @ +-- @ +-- >>> 'commonSuffix' __m1__ __m2__ '==' __m3__ +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> __m2__ = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] +-- >>> __m3__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 2)] +-- @ +-- @ +-- >>> 'commonSuffix' __m1__ __m2__ '==' __m3__ +-- 'True' +-- @ +-- +commonSuffix + :: (Ord k, MonoidNull v, RightGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +commonSuffix = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- commonSuffix a mempty ≡ mempty + + , withNonNullR = + keepNull + -- Justification: + -- + -- commonSuffix mempty a ≡ mempty + + , withNonNullP = + withBoth C.commonSuffix + } +{-# INLINE commonSuffix #-} + +-- | Strips the /greatest common prefix/ from a pair of maps. +-- +-- Given two maps __@m1@__ and __@m2@__, 'stripCommonPrefix' produces a +-- tuple __@(p, r1, r2)@__, where: +-- +-- - __@p@__ is the /greatest common prefix/ of __@m1@__ and __@m2@__ +-- - __@r1@__ is the /remainder/ of stripping prefix __@p@__ from __@m1@__ +-- - __@r2@__ is the /remainder/ of stripping prefix __@p@__ from __@m2@__ +-- +-- The resulting prefix __@p@__ can be appended to the /left-hand/ side of +-- either remainder __@r1@__ or __@r2@__ to /reproduce/ either of the original +-- maps __@m1@__ or __@m2@__ respectively: +-- +-- @ +-- 'stripCommonPrefix' m1 m2 +-- '&' \\(p, r1, _) -> p '<>' r1 '==' m1 +-- 'stripCommonPrefix' m1 m2 +-- '&' \\(p, _, r2) -> p '<>' r2 '==' m2 +-- @ +-- +-- Prefix __@p@__ is /identical/ to the result of applying 'commonPrefix' to +-- __@m1@__ and __@m2@__: +-- +-- @ +-- 'stripCommonPrefix' m1 m2 +-- '&' \\(p, _, _) -> p '==' 'commonPrefix' m1 m2 +-- @ +-- +-- Remainders __@r1@__ and __@r2@__ are /identical/ to the results of applying +-- 'stripPrefix' to __@p@__ and __@m1@__ or to __@p@__ and __@m2@__ +-- respectively: +-- +-- @ +-- 'stripCommonPrefix' m1 m2 +-- '&' \\(p, r1, _) -> 'Just' r1 '==' 'stripPrefix' p m1 +-- 'stripCommonPrefix' m1 m2 +-- '&' \\(p, _, r2) -> 'Just' r2 '==' 'stripPrefix' p m2 +-- @ +-- +-- This function provides the definition of 'C.stripCommonPrefix' for the +-- 'MonoidMap' instance of 'LeftGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1, "+++"), (2, "a++"), (3, "aa+"), (4, "aaa")] +-- >>> m2 = 'fromList' [(1, "---"), (2, "a--"), (3, "aa-"), (4, "aaa")] +-- @ +-- @ +-- >>> p = 'fromList' [(1, "" ), (2, "a" ), (3, "aa" ), (4, "aaa")] +-- >>> r1 = 'fromList' [(1, "+++"), (2, "++"), (3, "+"), (4, "")] +-- >>> r2 = 'fromList' [(1, "---"), (2, "--"), (3, "-"), (4, "")] +-- @ +-- @ +-- >>> 'stripCommonPrefix' m1 m2 '==' (p, r1, r2) +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] +-- @ +-- @ +-- >>> p = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] +-- >>> r1 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] +-- >>> r2 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] +-- @ +-- @ +-- >>> 'stripCommonPrefix' m1 m2 '==' (p, r1, r2) +-- 'True' +-- @ +-- +stripCommonPrefix + :: (Ord k, MonoidNull v, LeftGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) +stripCommonPrefix = C.stripCommonPrefix + +-- | Strips the /greatest common suffix/ from a pair of maps. +-- +-- Given two maps __@m1@__ and __@m2@__, 'stripCommonSuffix' produces a +-- tuple __@(r1, r2, s)@__, where: +-- +-- - __@s@__ is the /greatest common suffix/ of __@m1@__ and __@m2@__ +-- - __@r1@__ is the /remainder/ of stripping suffix __@s@__ from __@m1@__ +-- - __@r2@__ is the /remainder/ of stripping suffix __@s@__ from __@m2@__ +-- +-- The resulting suffix __@s@__ can be appended to the /right-hand/ side of +-- either remainder __@r1@__ or __@r2@__ to /reproduce/ either of the original +-- maps __@m1@__ or __@m2@__ respectively: +-- +-- @ +-- 'stripCommonSuffix' m1 m2 +-- '&' \\(r1, _, s) -> r1 '<>' s '==' m1 +-- 'stripCommonSuffix' m1 m2 +-- '&' \\(_, r2, s) -> r2 '<>' s '==' m2 +-- @ +-- +-- Suffix __@s@__ is /identical/ to the result of applying 'commonSuffix' to +-- __@m1@__ and __@m2@__: +-- +-- @ +-- 'stripCommonSuffix' m1 m2 +-- '&' \\(_, _, s) -> s '==' 'commonSuffix' m1 m2 +-- @ +-- +-- Remainders __@r1@__ and __@r2@__ are /identical/ to the results of applying +-- 'stripSuffix' to __@s@__ and __@m1@__ or to __@s@__ and __@m2@__ +-- respectively: +-- +-- @ +-- 'stripCommonSuffix' m1 m2 +-- '&' \\(r1, _, s) -> 'Just' r1 '==' 'stripSuffix' s m1 +-- 'stripCommonSuffix' m1 m2 +-- '&' \\(_, r2, s) -> 'Just' r2 '==' 'stripSuffix' s m2 +-- @ +-- +-- This function provides the definition of 'C.stripCommonSuffix' for the +-- 'MonoidMap' instance of 'RightGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1, "+++"), (2, "++a"), (3, "+aa"), (4, "aaa")] +-- >>> m2 = 'fromList' [(1, "---"), (2, "--a"), (3, "-aa"), (4, "aaa")] +-- @ +-- @ +-- >>> r1 = 'fromList' [(1, "+++"), (2, "++" ), (3, "+" ), (4, "" )] +-- >>> r2 = 'fromList' [(1, "---"), (2, "--" ), (3, "-" ), (4, "" )] +-- >>> s = 'fromList' [(1, ""), (2, "a"), (3, "aa"), (4, "aaa")] +-- @ +-- @ +-- >>> 'stripCommonSuffix' m1 m2 '==' (r1, r2, s) +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] +-- @ +-- @ +-- >>> r1 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] +-- >>> r2 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] +-- >>> s = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] +-- @ +-- @ +-- >>> 'stripCommonSuffix' m1 m2 '==' (r1, r2, s) +-- 'True' +-- @ +-- +stripCommonSuffix + :: (Ord k, MonoidNull v, RightGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) +stripCommonSuffix = C.stripCommonSuffix + +-------------------------------------------------------------------------------- +-- Overlap +-------------------------------------------------------------------------------- + +-- | Finds the /greatest overlap/ of two maps. +-- +-- The /greatest overlap/ __@o@__ of maps __@m1@__ and __@m2@__ is the /unique/ +-- greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of __@m2@__: +-- +-- @ +-- m1 '==' r1 '<>' o \ \ +-- m2 '==' \ \ o '<>' r2 +-- @ +-- +-- Where: +-- +-- - __@r1@__ is the /remainder/ obtained by stripping /suffix overlap/ +-- __@o@__ from __@m1@__. +-- +-- (see 'stripSuffixOverlap') +-- +-- - __@r2@__ is the /remainder/ obtained by stripping /prefix overlap/ +-- __@o@__ from __@m2@__. +-- +-- (see 'stripPrefixOverlap') +-- +-- This function satisfies the following property: +-- +-- @ +-- 'get' k ('overlap' m1 m2) '==' 'C.overlap' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.overlap' for the 'MonoidMap' +-- instance of 'OverlappingGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde "), (4,"abcdef")] +-- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3," bcdef"), (4,"abcdef")] +-- >>> m3 = 'fromList' [(1, "" ), (2, "cd" ), (3," bcde" ), (4,"abcdef")] +-- @ +-- @ +-- >>> 'overlap' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] +-- @ +-- @ +-- >>> 'overlap' m1 m2 '==' m3 +-- 'True' +-- @ +-- +overlap + :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +overlap = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- overlap a mempty ≡ mempty + + , withNonNullR = + keepNull + -- Justification: + -- + -- overlap mempty a ≡ mempty + + , withNonNullP = + withBoth C.overlap + } +{-# INLINE overlap #-} + +-- | /Strips/ from the second map its /greatest prefix overlap/ with suffixes +-- of the first map. +-- +-- Evaluating 'stripPrefixOverlap' __@m1@__ __@m2@__ produces the /remainder/ +-- __@r2@__: +-- +-- @ +-- m1 '==' r1 '<>' o \ \ +-- m2 '==' \ \ o '<>' r2 +-- @ +-- +-- Where __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the +-- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of +-- __@m2@__. +-- +-- This function satisfies the following property: +-- +-- @ +-- 'get' k ('stripPrefixOverlap' m1 m2) +-- '==' 'C.stripPrefixOverlap' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.stripPrefixOverlap' for the +-- 'MonoidMap' instance of 'OverlappingGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde" ), (4,"abcdef")] +-- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3, "bcdef"), (4,"abcdef")] +-- >>> m3 = 'fromList' [(1, "def"), (2, "ef"), (3, "f"), (4, "")] +-- @ +-- @ +-- >>> 'stripPrefixOverlap' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] +-- >>> m3 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] +-- @ +-- @ +-- >>> 'stripPrefixOverlap' m1 m2 '==' m3 +-- 'True' +-- @ +-- +stripPrefixOverlap + :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +stripPrefixOverlap = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- overlap a b <> stripPrefixOverlap a b ≡ b + -- overlap a mempty <> stripPrefixOverlap a mempty ≡ mempty + -- mempty <> stripPrefixOverlap a mempty ≡ mempty + -- stripPrefixOverlap a mempty ≡ mempty + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- overlap a b <> stripPrefixOverlap a b ≡ b + -- overlap mempty b <> stripPrefixOverlap mempty b ≡ b + -- mempty <> stripPrefixOverlap mempty b ≡ b + -- stripPrefixOverlap mempty b ≡ b + + , withNonNullP = + withBoth C.stripPrefixOverlap + } +{-# INLINE stripPrefixOverlap #-} + +-- | /Strips/ from the second map its /greatest suffix overlap/ with prefixes +-- of the first map. +-- +-- Evaluating 'stripSuffixOverlap' __@m2@__ __@m1@__ produces the /remainder/ +-- __@r1@__: +-- +-- @ +-- m1 '==' r1 '<>' o \ \ +-- m2 '==' \ \ o '<>' r2 +-- @ +-- +-- Where __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the +-- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of +-- __@m2@__. +-- +-- This function satisfies the following property: +-- +-- @ +-- 'get' k ('stripSuffixOverlap' m2 m1) +-- '==' 'C.stripSuffixOverlap' ('get' k m2) ('get' k m1) +-- @ +-- +-- This function provides the definition of 'C.stripSuffixOverlap' for the +-- 'MonoidMap' instance of 'OverlappingGCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'String' values: +-- +-- @ +-- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde" ), (4,"abcdef")] +-- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3, "bcdef"), (4,"abcdef")] +-- >>> m3 = 'fromList' [(1,"abc" ), (2,"ab" ), (3,"a" ), (4,"" )] +-- @ +-- @ +-- >>> 'stripSuffixOverlap' m2 m1 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] +-- @ +-- @ +-- >>> 'stripSuffixOverlap' m2 m1 '==' m3 +-- 'True' +-- @ +-- +stripSuffixOverlap + :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +stripSuffixOverlap = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- stripSuffixOverlap b a <> overlap a b ≡ a + -- stripSuffixOverlap b mempty <> overlap mempty b ≡ mempty + -- stripSuffixOverlap b mempty <> mempty ≡ mempty + -- stripSuffixOverlap b mempty ≡ mempty + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- stripSuffixOverlap b a <> overlap a b ≡ a + -- stripSuffixOverlap mempty a <> overlap a mempty ≡ a + -- stripSuffixOverlap mempty a <> mempty ≡ a + -- stripSuffixOverlap mempty a ≡ a + + , withNonNullP = + withBoth C.stripSuffixOverlap + } +{-# INLINE stripSuffixOverlap #-} + +-- | Finds the /greatest overlap/ of two maps and /strips/ it from both maps. +-- +-- Evaluating 'stripOverlap' __@m1@__ __@m2@__ produces the tuple +-- __@(r1, o, r2)@__, where: +-- +-- @ +-- m1 '==' r1 '<>' o \ \ +-- m2 '==' \ \ o '<>' r2 +-- @ +-- +-- Where: +-- +-- - __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the +-- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ +-- of __@m2@__. +-- +-- (see 'overlap') +-- +-- - __@r1@__ is the /remainder/ obtained by stripping /suffix overlap/ +-- __@o@__ from __@m1@__. +-- +-- (see 'stripSuffixOverlap') +-- +-- - __@r2@__ is the /remainder/ obtained by stripping /prefix overlap/ +-- __@o@__ from __@m2@__. +-- +-- (see 'stripPrefixOverlap') +-- +-- This function satisfies the following property: +-- +-- @ +-- 'stripOverlap' m1 m2 '==' +-- ( 'stripSuffixOverlap' m2 m1 +-- , 'overlap' m1 m2 +-- , 'stripPrefixOverlap' m1 m2 +-- ) +-- @ +-- +-- This function provides the definition of 'C.stripOverlap' for the +-- 'MonoidMap' instance of 'OverlappingGCDMonoid'. +-- +stripOverlap + :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) +stripOverlap m1 m2 = + ( stripSuffixOverlap m2 m1 + , m1 `overlap` m2 + , stripPrefixOverlap m1 m2 + ) + +-------------------------------------------------------------------------------- +-- Intersection +-------------------------------------------------------------------------------- + +-- | Finds the /intersection/ of two maps. +-- +-- The intersection of maps __@m1@__ and __@m2@__ is the greatest single map +-- __@m@__ that is a /submap/ of both __@m1@__ /and/ __@m2@__: +-- +-- @ +-- 'intersection' m1 m2 '`isSubmapOf`' m1 +-- 'intersection' m1 m2 '`isSubmapOf`' m2 +-- @ +-- +-- The intersection is /unique/: +-- +-- @ +-- 'and' +-- [ 'intersection' m1 m2 '`isSubmapOf`' m +-- , \ \ \ \ m '`isSubmapOf`' m1 +-- , \ \ \ \ m '`isSubmapOf`' m2 +-- ] +-- ==> +-- (m '==' 'intersection' m1 m2) +-- @ +-- +-- The following property holds for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('intersection' m1 m2) '==' 'C.gcd' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.gcd' for the 'MonoidMap' +-- instance of 'GCDMonoid'. +-- +-- === __Examples__ +-- +-- With 'Data.Monoid.Product' 'Numeric.Natural.Natural' values, this function +-- computes the /greatest common divisor/ of each pair of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 6), ("c", 15), ("d", 35)] +-- >>> m2 = 'fromList' [("a", 6), ("b", 15), ("c", 35), ("d", 77)] +-- >>> m3 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 7)] +-- @ +-- @ +-- >>> 'intersection' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function +-- computes the /minimum/ of each pair of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 1), ("d", 0)] +-- @ +-- @ +-- >>> 'intersection' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Set' 'Numeric.Natural.Natural' values, this function computes the +-- /set/ /intersection/ of each pair of matching values: +-- +-- @ +-- f xs = 'fromList' ('Set.fromList' '<$>' xs) +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] +-- >>> m2 = f [("a", [0,1,2]), ("b", [ 1,2,3]), ("c", [ 2,3,4])] +-- >>> m3 = f [("a", [0,1,2]), ("b", [ 1,2 ]), ("c", [ 2 ])] +-- @ +-- @ +-- >>> 'intersection' m1 m2 '==' m3 +-- 'True' +-- @ +-- +intersection + :: (Ord k, MonoidNull v, GCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +intersection = merge MergeStrategy + { withNonNullL = + keepNull + -- Justification: + -- + -- gcd a mempty ≡ mempty + + , withNonNullR = + keepNull + -- Justification: + -- + -- gcd mempty b ≡ mempty + + , withNonNullP = + withBoth C.gcd + } +{-# INLINE intersection #-} + +-------------------------------------------------------------------------------- +-- Union +-------------------------------------------------------------------------------- + +-- | Finds the /union/ of two maps. +-- +-- The union of maps __@m1@__ and __@m2@__ is the smallest single map __@m@__ +-- that includes both __@m1@__ /and/ __@m2@__ as /submaps/: +-- +-- @ +-- m1 '`isSubmapOf`' 'union' m1 m2 +-- m2 '`isSubmapOf`' 'union' m1 m2 +-- @ +-- +-- The union is /unique/: +-- +-- @ +-- 'and' +-- [ m1 '`isSubmapOf`' m +-- , m2 '`isSubmapOf`' m +-- , \ \ m '`isSubmapOf`' 'union' m1 m2 +-- ] +-- ==> +-- (m '==' 'union' m1 m2) +-- @ +-- +-- The following property holds for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('union' m1 m2) '==' 'C.lcm' ('get' k m1) ('get' k m2) +-- @ +-- +-- This function provides the definition of 'C.lcm' for the 'MonoidMap' +-- instance of 'LCMMonoid'. +-- +-- === __Examples__ +-- +-- With 'Data.Monoid.Product' 'Numeric.Natural.Natural' values, this function +-- computes the /least common multiple/ of each pair of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 6), ("c", 15), ("d", 35)] +-- >>> m2 = 'fromList' [("a", 6), ("b", 15), ("c", 35), ("d", 77)] +-- >>> m3 = 'fromList' [("a", 6), ("b", 30), ("c", 105), ("d", 385)] +-- @ +-- @ +-- >>> 'union' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function +-- computes the /maximum/ of each pair of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] +-- >>> m3 = 'fromList' [("a", 3), ("b", 2), ("c", 2), ("d", 3)] +-- @ +-- @ +-- >>> 'union' m1 m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Set' 'Numeric.Natural.Natural' values, this function computes the +-- /set/ /union/ of each pair of matching values: +-- +-- @ +-- f xs = 'fromList' ('Set.fromList' '<$>' xs) +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] +-- >>> m2 = f [("a", [0,1,2]), ("b", [ 1,2,3]), ("c", [ 2,3,4])] +-- >>> m3 = f [("a", [0,1,2]), ("b", [0,1,2,3]), ("c", [0,1,2,3,4])] +-- @ +-- @ +-- >>> 'union' m1 m2 '==' m3 +-- 'True' +-- @ +-- +union + :: (Ord k, MonoidNull v, LCMMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +union = merge MergeStrategy + { withNonNullL = + keepNonNull + -- Justification: + -- + -- lcm a mempty ≡ a + + , withNonNullR = + keepNonNull + -- Justification: + -- + -- lcm mempty a ≡ a + + , withNonNullP = + withBoth C.lcm + } +{-# INLINE union #-} + +-------------------------------------------------------------------------------- +-- Subtraction +-------------------------------------------------------------------------------- + +-- | Performs /group subtraction/ of the second map from the first. +-- +-- Uses the 'Group' subtraction operator '(C.~~)' to subtract each value in the +-- second map from its matching value in the first map. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k (m1 '`minus`' m2) '==' 'get' k m1 'C.~~' 'get' k m2 +-- @ +-- +-- This function provides the definition of '(C.~~)' for the 'MonoidMap' +-- instance of 'Group'. +-- +-- === __Examples__ +-- +-- With 'Data.Monoid.Sum' 'Integer' values, this function performs normal +-- integer subtraction of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", (-1)), ("b", 0 ), ("c", 1)] +-- >>> m2 = 'fromList' [("a", 1 ), ("b", 1 ), ("c", 1)] +-- >>> m3 = 'fromList' [("a", (-2)), ("b", (-1)), ("c", 0)] +-- @ +-- @ +-- >>> m1 '`minus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", (-1)), ("b", 0 ), ("c", 1 )] +-- >>> m2 = 'fromList' [("a", (-1)), ("b", (-1)), ("c", (-1))] +-- >>> m3 = 'fromList' [("a", 0 ), ("b", 1 ), ("c", 2 )] +-- @ +-- @ +-- >>> m1 '`minus`' m2 '==' m3 +-- 'True' +-- @ +-- +minus + :: (Ord k, MonoidNull v, Group v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +minus = merge MergeStrategy + { withNonNullL = + keepNonNull + -- Justification: + -- + -- a ~~ mempty ≡ a + + , withNonNullR = + withNonNull C.invert + -- Justification: + -- + -- a ~~ b ≡ a <> invert b + -- mempty ~~ b ≡ mempty <> invert b + -- mempty ~~ b ≡ invert b + + , withNonNullP = + withBoth (C.~~) + } +{-# INLINE minus #-} + +-- | Performs /reductive subtraction/ of the second map from the first. +-- +-- Uses the 'Reductive' subtraction operator '()' to subtract each value in +-- the second map from its matching value in the first map. +-- +-- This function produces a result if (and only if) for all possible keys +-- __@k@__, it is possible to subtract the value for __@k@__ in the second map +-- from the value for __@k@__ in the first map: +-- +-- @ +-- 'isJust' (m1 '`minusMaybe`' m2) +-- '==' (∀ k. 'isJust' ('get' k m1 '' 'get' k m2)) +-- @ +-- +-- Otherwise, this function returns 'Nothing'. +-- +-- This function satisfies the following property: +-- +-- @ +-- 'all' +-- (\\r -> 'Just' ('get' k r) '==' 'get' k m1 '' 'get' k m2) +-- (m1 '`minusMaybe`' m2) +-- @ +-- +-- This function provides the definition of '()' for the 'MonoidMap' +-- instance of 'Reductive'. +-- +-- === __Examples__ +-- +-- With 'Set' 'Numeric.Natural.Natural' values, this function performs /set/ +-- /subtraction/ of matching values, succeeding if (and only if) each value +-- from the second map is a subset of its matching value from the first map: +-- +-- @ +-- f xs = 'fromList' ('Set.fromList' '<$>' xs) +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2])] +-- >>> m2 = f [("a", [ ]), ("b", [0,1,2])] +-- >>> m3 = f [("a", [0,1,2]), ("b", [ ])] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2]), ("c", [0,1,2])] +-- >>> m2 = f [("a", [0 ]), ("b", [ 1 ]), ("c", [ 2])] +-- >>> m3 = f [("a", [ 1,2]), ("b", [0, 2]), ("c", [0,1 ])] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2 ]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] +-- >>> m2 = f [("a", [ 2,3,4]), ("b", [ 1,2,3,4]), ("c", [0,1,2,3,4])] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Nothing' +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function +-- performs /ordinary/ /subtraction/ of matching values, succeeding if (and only +-- if) each value from the second map is less than or equal to its matching +-- value from the first map: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- >>> m2 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] +-- >>> m3 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- >>> m2 = 'fromList' [("a", 1), ("b", 2), ("c", 3), ("d", 5)] +-- >>> m3 = 'fromList' [("a", 1), ("b", 1), ("c", 2), ("d", 3)] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- >>> m2 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] +-- >>> m2 = 'fromList' [("a", 3), ("b", 3), ("c", 5), ("d", 8)] +-- @ +-- @ +-- >>> m1 '`minusMaybe`' m2 '==' 'Nothing' +-- 'True' +-- @ +-- +minusMaybe + :: (Ord k, MonoidNull v, Reductive v) + => MonoidMap k v + -> MonoidMap k v + -> Maybe (MonoidMap k v) +minusMaybe = mergeA MergeStrategy + { withNonNullL = + keepNonNull + -- Justification: + -- + -- According to laws for Reductive: + -- maybe a (b <>) (a b ) ≡ a + -- maybe a (mempty <>) (a mempty) ≡ a + -- maybe a (id ) (a mempty) ≡ a + -- (a mempty) ∈ {Just a, Nothing} + -- + -- According to laws for LeftReductive and RightReductive: + -- isJust (a b ) ≡ b `isPrefixOf` a ≡ b `isSuffixOf` a + -- isJust (a mempty) ≡ mempty `isPrefixOf` a ≡ mempty `isSuffixOf` a + -- + -- According to laws for LeftReductive and RightReductive: + -- b `isPrefixOf` (b <> a) + -- mempty `isPrefixOf` (mempty <> a) + -- mempty `isPrefixOf` a + -- + -- Therefore: + -- a mempty ≡ Just a + + , withNonNullR = + withNonNullA (\v -> mempty v) + + , withNonNullP = + withBothA () + } +{-# INLINE minusMaybe #-} + +-- | Performs /monus subtraction/ of the second map from the first. +-- +-- Uses the 'Monus' subtraction operator '(<\>)' to subtract each value in +-- the second map from its matching value in the first map. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k (m1 '`monus`' m2) '==' 'get' k m1 '<\>' 'get' k m2 +-- @ +-- +-- This function provides the definition of '(<\>)' for the 'MonoidMap' +-- instance of 'Monus'. +-- +-- === __Examples__ +-- +-- With 'Set' 'Numeric.Natural.Natural' values, this function performs /set/ +-- /subtraction/ of matching values: +-- +-- @ +-- f xs = 'fromList' ('Set.fromList' '<$>' xs) +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2])] +-- >>> m2 = f [("a", [ ]), ("b", [0,1,2])] +-- >>> m3 = f [("a", [0,1,2]), ("b", [ ])] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2]), ("c", [0,1,2])] +-- >>> m2 = f [("a", [0 ]), ("b", [ 1 ]), ("c", [ 2])] +-- >>> m3 = f [("a", [ 1,2]), ("b", [0, 2]), ("c", [0,1 ])] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = f [("a", [0,1,2 ]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] +-- >>> m2 = f [("a", [ 2,3,4]), ("b", [ 1,2,3,4]), ("c", [0,1,2,3,4])] +-- >>> m3 = f [("a", [0,1 ]), ("b", [0 ]), ("c", [ ])] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function +-- performs /truncated/ /subtraction/ of matching values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 1), ("b", 1), ("c", 1), ("d", 1)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 1), ("d", 2)] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 1)] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 4), ("b", 4), ("c", 4), ("d", 4)] +-- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] +-- @ +-- @ +-- >>> m1 '`monus`' m2 '==' m3 +-- 'True' +-- @ +-- +monus + :: (Ord k, MonoidNull v, Monus v) + => MonoidMap k v + -> MonoidMap k v + -> MonoidMap k v +monus = merge MergeStrategy + { withNonNullL = + keepNonNull + -- Justification: + -- + -- a <> (b <\> a ) ≡ b <> (a <\> b) + -- mempty <> (b <\> mempty) ≡ b <> (mempty <\> a) + -- b <\> mempty ≡ b <> (mempty <\> a) + -- b <\> mempty ≡ b <> mempty + -- b <\> mempty ≡ b + + , withNonNullR = + keepNull + -- Justification: + -- + -- mempty <\> a ≡ mempty + + , withNonNullP = + withBoth (<\>) + } +{-# INLINE monus #-} + +-------------------------------------------------------------------------------- +-- Inversion +-------------------------------------------------------------------------------- + +-- | Inverts every value in a map. +-- +-- Applies the 'Group' method 'C.invert' to every value in a map. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('invert' m) '==' 'C.invert' ('get' k m) +-- @ +-- +-- This function provides the definition of 'C.invert' for the 'MonoidMap' +-- instance of 'Group'. +-- +-- === __Examples__ +-- +-- With 'Data.Monoid.Sum' 'Integer' values, this function performs negation +-- of values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", (-1)), ("b", 0), ("c", 1) ] +-- >>> m2 = 'fromList' [("a", 1 ), ("b", 0), ("c", (-1))] +-- @ +-- @ +-- >>> 'negate' m1 '==' m2 +-- 'True' +-- @ +-- +invert + :: (MonoidNull v, Group v) + => MonoidMap k v + -> MonoidMap k v +invert = map C.invert +{-# INLINE invert #-} + +-------------------------------------------------------------------------------- +-- Exponentiation +-------------------------------------------------------------------------------- + +-- | Performs exponentiation of every value in a map. +-- +-- Uses the 'Group' exponentiation method 'C.pow' to raise every value in a map +-- to the power of the given exponent. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k (m '`power`' i) '==' 'get' k m '`C.pow`' i +-- @ +-- +-- This function provides the definition of 'C.pow' for the 'MonoidMap' +-- instance of 'Group'. +-- +-- === __Examples__ +-- +-- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function +-- performs /ordinary multiplication/ of all values by the given exponent: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] +-- >>> m2 = 'fromList' [("a", 0), ("b", 2), ("c", 4), ("d", 6)] +-- @ +-- @ +-- >>> m1 '`power`' 2 '==' m2 +-- 'True' +-- @ +-- +-- @ +-- >>> m1 = 'fromList' [("a", 0), ("b", 1 ), ("c", 2 ), ("d", 3 )] +-- >>> m2 = 'fromList' [("a", 0), ("b", (-1)), ("c", (-2)), ("d", (-3))] +-- @ +-- @ +-- >>> m1 '`power`' (-1) '==' m2 +-- 'True' +-- @ +-- +power + :: (Integral i, MonoidNull v, Group v) + => MonoidMap k v + -> i + -> MonoidMap k v +power m i = map (`C.pow` i) m +{-# INLINE power #-} + +-------------------------------------------------------------------------------- +-- Intersection +-------------------------------------------------------------------------------- + +-- | Computes the /intersection/ of a pair of maps using the given function +-- to combine values for matching keys. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('intersectionWith' f m1 m2) '==' +-- if k '`Set.member`' +-- 'Set.intersection' +-- ('nonNullKeys' m1) +-- ('nonNullKeys' m2) +-- then f ('get' k m1) ('get' k m2) +-- else 'mempty' +-- @ +-- +-- === Conditional totality +-- +-- /If/ the given combining function __@f@__ /always/ produces 'mempty' when +-- /either/ or /both/ of its arguments are 'mempty': +-- +-- @ +-- (f v 'mempty' '==' 'mempty') '&&' +-- (f 'mempty' v '==' 'mempty') +-- @ +-- +-- /Then/ the following property holds for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('intersectionWith' f m1 m2) '==' f ('get' k m1) ('get' k m2) +-- @ +-- +-- === __Examples__ +-- +-- With the 'Prelude.min' function applied to 'Data.Monoid.Sum' +-- 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1) ] +-- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m3 = 'fromList' [ ("b", 1), ("c", 2), ("d", 1) ] +-- @ +-- @ +-- >>> 'intersectionWith' 'Prelude.min' m1 m2 '==' m3 +-- 'True' +-- @ +-- +intersectionWith + :: (Ord k, MonoidNull v3) + => (v1 -> v2 -> v3) + -- ^ Function with which to combine values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> MonoidMap k v3 +intersectionWith f = merge MergeStrategy + { withNonNullL = + keepNull + , withNonNullR = + keepNull + , withNonNullP = + withBoth f + } +{-# INLINE intersectionWith #-} + +-- | An /applicative/ version of 'intersectionWith'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'runIdentity' ('intersectionWithA' (('fmap' . 'fmap') 'Identity' f) m1 m2) +-- '==' ('intersectionWith' \ \ \ \ \ \ f m1 m2) +-- @ +-- +intersectionWithA + :: (Applicative f, Ord k, MonoidNull v3) + => (v1 -> v2 -> f v3) + -- ^ Function with which to combine values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> f (MonoidMap k v3) +intersectionWithA f = mergeA MergeStrategy + { withNonNullL = + keepNull + , withNonNullR = + keepNull + , withNonNullP = + withBothA f + } +{-# INLINE intersectionWithA #-} + +-------------------------------------------------------------------------------- +-- Union +-------------------------------------------------------------------------------- + +-- | Computes the /union/ of a pair of maps using the given function to combine +-- values for matching keys. +-- +-- Satisfies the following property for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('unionWith' f m1 m2) '==' +-- if k '`Set.member`' +-- 'Set.union' +-- ('nonNullKeys' m1) +-- ('nonNullKeys' m2) +-- then f ('get' k m1) ('get' k m2) +-- else 'mempty' +-- @ +-- +-- === Conditional totality +-- +-- /If/ the given combining function __@f@__ /always/ produces 'mempty' when +-- /both/ of its arguments are 'mempty': +-- +-- @ +-- f 'mempty' 'mempty' '==' 'mempty' +-- @ +-- +-- /Then/ the following property holds for all possible keys __@k@__: +-- +-- @ +-- 'get' k ('unionWith' f m1 m2) '==' f ('get' k m1) ('get' k m2) +-- @ +-- +-- === __Examples__ +-- +-- With the 'Prelude.max' function applied to 'Data.Monoid.Sum' +-- 'Numeric.Natural.Natural' values: +-- +-- @ +-- >>> m1 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1) ] +-- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 3), ("e", 4)] +-- >>> m3 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 3), ("e", 4)] +-- @ +-- @ +-- >>> 'unionWith' 'Prelude.max' m1 m2 '==' m3 +-- 'True' +-- @ +-- +unionWith + :: (Ord k, Monoid v1, Monoid v2, MonoidNull v3) + => (v1 -> v2 -> v3) + -- ^ Function with which to combine values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> MonoidMap k v3 +unionWith f = merge MergeStrategy + { withNonNullL = + withNonNull (\v -> f v mempty) + , withNonNullR = + withNonNull (\v -> f mempty v) + , withNonNullP = + withBoth f + } +{-# INLINE unionWith #-} + +-- | An /applicative/ version of 'unionWith'. +-- +-- Satisfies the following property: +-- +-- @ +-- 'runIdentity' ('unionWithA' (('fmap' . 'fmap') 'Identity' f) m1 m2) +-- '==' ('unionWith' \ \ \ \ \ \ f m1 m2) +-- @ +-- +unionWithA + :: (Applicative f, Ord k, Monoid v1, Monoid v2, MonoidNull v3) + => (v1 -> v2 -> f v3) + -- ^ Function with which to combine values for matching keys. + -> MonoidMap k v1 + -> MonoidMap k v2 + -> f (MonoidMap k v3) +unionWithA f = mergeA MergeStrategy + { withNonNullL = + withNonNullA (\v -> f v mempty) + , withNonNullR = + withNonNullA (\v -> f mempty v) + , withNonNullP = + withBothA f + } +{-# INLINE unionWithA #-} + +-------------------------------------------------------------------------------- +-- Merging +-------------------------------------------------------------------------------- + +type WhenOneSideNull f k vx vr + = Map.WhenMissing f k (NonNull vx) (NonNull vr) +type WhenBothNonNull f k v1 v2 vr + = Map.WhenMatched f k (NonNull v1) (NonNull v2) (NonNull vr) + +data MergeStrategy f k v1 v2 v3 = MergeStrategy + { withNonNullL :: !(WhenOneSideNull f k v1 v3) + , withNonNullR :: !(WhenOneSideNull f k v2 v3) + , withNonNullP :: !(WhenBothNonNull f k v1 v2 v3) + } + +merge + :: Ord k + => MergeStrategy Identity k v1 v2 v3 + -> MonoidMap k v1 + -> MonoidMap k v2 + -> MonoidMap k v3 +merge (MergeStrategy nnl nnr nnp) (MonoidMap m1) (MonoidMap m2) = + MonoidMap $ Map.merge nnl nnr nnp m1 m2 +{-# INLINE merge #-} + +mergeA + :: (Applicative f, Ord k) + => MergeStrategy f k v1 v2 v3 + -> MonoidMap k v1 + -> MonoidMap k v2 + -> f (MonoidMap k v3) +mergeA (MergeStrategy nnl nnr nnp) (MonoidMap m1) (MonoidMap m2) = + MonoidMap <$> Map.mergeA nnl nnr nnp m1 m2 +{-# INLINE mergeA #-} + +keepNull + :: Applicative f + => WhenOneSideNull f k v1 v2 +keepNull = Map.dropMissing +{-# INLINE keepNull #-} + +keepNonNull + :: Applicative f + => WhenOneSideNull f k v v +keepNonNull = Map.preserveMissing +{-# INLINE keepNonNull #-} + +withNonNull + :: (Applicative f, MonoidNull v2) + => (v1 -> v2) + -> WhenOneSideNull f k v1 v2 +withNonNull f + = Map.mapMaybeMissing + $ \_k v -> maybeNonNull $ applyNonNull f v +{-# INLINE withNonNull #-} + +withNonNullA + :: (Applicative f, MonoidNull v2) + => (v1 -> f v2) + -> WhenOneSideNull f k v1 v2 +withNonNullA f + = Map.traverseMaybeMissing + $ \_k v -> maybeNonNull <$> applyNonNull f v +{-# INLINE withNonNullA #-} + +withBoth + :: (Applicative f, MonoidNull v3) + => (v1 -> v2 -> v3) + -> WhenBothNonNull f k v1 v2 v3 +withBoth f + = Map.zipWithMaybeMatched + $ \_k v1 v2 -> maybeNonNull $ applyNonNull2 f v1 v2 +{-# INLINE withBoth #-} + +withBothA + :: (Applicative f, MonoidNull v3) + => (v1 -> v2 -> f v3) + -> WhenBothNonNull f k v1 v2 v3 +withBothA f + = 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/components/monoidmap-internal/Data/MonoidMap/Unsafe.hs b/components/monoidmap-internal/Data/MonoidMap/Unsafe.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-internal/Data/MonoidMap/Unsafe.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides /unsafe/ operations for the 'MonoidMap' type. +-- +module Data.MonoidMap.Unsafe + ( + -- * Construction + unsafeFromMap + ) + where + +import Prelude + +import Data.Coerce + ( coerce ) +import Data.Map.Strict + ( Map ) +import Data.MonoidMap.Internal + ( MonoidMap (..), NonNull (..), fromMap ) + +import qualified Data.Foldable as F +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap.Internal as Internal + +-------------------------------------------------------------------------------- +-- Unsafe construction +-------------------------------------------------------------------------------- + +-- | \(O(1)\). /Unsafely/ constructs a 'MonoidMap' from an ordinary 'Map'. +-- +-- Constructs a 'MonoidMap' in /constant time/, without imposing the burden +-- of a canonicalisation step to remove 'null' values. +-- +-- When applied to a given 'Map' @m@, this function /expects/ but does /not/ +-- check the following pre-condition: +-- +-- @ +-- 'F.all' ('not' . 'Null.null') m +-- @ +-- +-- Not satisfying this pre-condition will result in undefined behaviour. +-- +-- See 'fromMap' for a safe version of this function. +-- +unsafeFromMap :: Map k v -> MonoidMap k v +unsafeFromMap = coerce diff --git a/components/monoidmap-test/Data/MonoidMap/AccessSpec.hs b/components/monoidmap-test/Data/MonoidMap/AccessSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/AccessSpec.hs @@ -0,0 +1,172 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.AccessSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun, Property, applyFun, cover, (===) ) + +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Accessors" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + describe "Get" $ do + it "prop_get_nonNullKey" $ + prop_get_nonNullKey + @k @v & property + it "prop_get_nonNullKeys" $ + prop_get_nonNullKeys + @k @v & property + + describe "Set" $ do + it "prop_set_get" $ + prop_set_get + @k @v & property + it "prop_set_nonNullKey" $ + prop_set_nonNullKey + @k @v & property + it "prop_set_nonNullKeys" $ + prop_set_nonNullKeys + @k @v & property + it "prop_set_toList" $ + prop_set_toList + @k @v & property + + describe "Adjust" $ do + it "prop_adjust_get_set" $ + prop_adjust_get_set + @k @v & property + +-------------------------------------------------------------------------------- +-- Get +-------------------------------------------------------------------------------- + +prop_get_nonNullKey + :: Test k v => MonoidMap k v -> k -> Property +prop_get_nonNullKey m k = + MonoidMap.nonNullKey k m === (MonoidMap.get k m /= mempty) + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +prop_get_nonNullKeys + :: Test k v => MonoidMap k v -> k -> Property +prop_get_nonNullKeys m k = + Set.member k (MonoidMap.nonNullKeys m) === (MonoidMap.get k m /= mempty) + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +-------------------------------------------------------------------------------- +-- Set +-------------------------------------------------------------------------------- + +prop_set_get + :: Test k v => MonoidMap k v -> k -> v -> Property +prop_set_get m k v = + MonoidMap.get k (MonoidMap.set k v m) === v + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +prop_set_nonNullKey + :: Test k v => MonoidMap k v -> k -> v -> Property +prop_set_nonNullKey m k v = + MonoidMap.nonNullKey k (MonoidMap.set k v m) === + (v /= mempty) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_set_nonNullKeys + :: Test k v => MonoidMap k v -> k -> v -> Property +prop_set_nonNullKeys m k v = + Set.member k (MonoidMap.nonNullKeys (MonoidMap.set k v m)) === + (v /= mempty) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_set_toList + :: Test k v => MonoidMap k v -> k -> v -> Property +prop_set_toList m k v = + filter ((== k) . fst) (MonoidMap.toList (MonoidMap.set k v m)) === + [(k, v) | v /= mempty] + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +-------------------------------------------------------------------------------- +-- Adjust +-------------------------------------------------------------------------------- + +prop_adjust_get_set + :: Test k v => MonoidMap k v -> Fun v v -> k -> Property +prop_adjust_get_set m (applyFun -> f) k = + MonoidMap.adjust f k m === MonoidMap.set k (f (MonoidMap.get k m)) m + & cover 1 + (MonoidMap.nullKey k m && Null.null (f mempty)) + "MonoidMap.nullKey k m && Null.null (f mempty)" + & cover 1 + (MonoidMap.nullKey k m && not (Null.null (f mempty))) + "MonoidMap.nullKey k m && not (Null.null (f mempty))" + & cover 0.1 + (MonoidMap.nonNullKey k m && Null.null (f (MonoidMap.get k m))) + "MonoidMap.nonNullKey k m && Null.null (f (MonoidMap.get k m))" + & cover 0.1 + (MonoidMap.nonNullKey k m && not (Null.null (f (MonoidMap.get k m)))) + "MonoidMap.nonNullKey k m && not (Null.null (f (MonoidMap.get k m)))" diff --git a/components/monoidmap-test/Data/MonoidMap/ClassSpec.hs b/components/monoidmap-test/Data/MonoidMap/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/ClassSpec.hs @@ -0,0 +1,336 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.ClassSpec + where + +import Prelude + +import Data.Monoid + ( Product (..), Sum (..) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Data.Set + ( Set ) +import Data.Typeable + ( Typeable, typeRep ) +import Numeric.Natural + ( Natural ) +import Test.Combinators.NonZero + ( NonZero, genNonZero, shrinkNonZero ) +import Test.Common () +import Test.Hspec + ( Spec, describe ) +import Test.Key + ( Key1, Key2, Key4, Key8 ) +import Test.QuickCheck + ( Arbitrary (..) ) +import Test.QuickCheck.Classes + ( eqLaws + , isListLaws + , monoidLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ) +import Test.QuickCheck.Classes.Group + ( groupLaws ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) +import Test.QuickCheck.Classes.Monoid.GCD + ( distributiveGCDMonoidLaws + , gcdMonoidLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , overlappingGCDMonoidLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + ) +import Test.QuickCheck.Classes.Monoid.LCM + ( distributiveLCMMonoidLaws, lcmMonoidLaws ) +import Test.QuickCheck.Classes.Monoid.Monus + ( monusLaws ) +import Test.QuickCheck.Classes.Monoid.Null + ( monoidNullLaws, positiveMonoidLaws ) +import Test.QuickCheck.Classes.Semigroup.Cancellative + ( cancellativeLaws + , commutativeLaws + , leftCancellativeLaws + , leftReductiveLaws + , reductiveLaws + , rightCancellativeLaws + , rightReductiveLaws + ) + +spec :: Spec +spec = do + describe "Class laws" $ do + -- Test against a variety of key sizes: + specLawsFor (Proxy @Key1) + specLawsFor (Proxy @Key2) + specLawsFor (Proxy @Key4) + specLawsFor (Proxy @Key8) + +specLawsFor + :: forall k. () => + ( Arbitrary k + , Ord k + , Read k + , Show k + , Typeable k + ) + => Proxy k + -> Spec +specLawsFor keyType = do + let description = "Class laws for key type " <> show (typeRep keyType) + describe description $ do + testLawsMany @(MonoidMap k String) + [ eqLaws + , isListLaws + , leftCancellativeLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Product Integer)) + [ commutativeLaws + , eqLaws + , isListLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , reductiveLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Product Natural)) + [ commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + -- Here we restrict the generator and shrinker so that they can never + -- produce zero values, to avoid running into cases of ArithException + -- caused by operations that may produce zero demoninators: + testLawsMany @(MonoidMap k (NonZero (Product Rational))) + [ commutativeLaws + , eqLaws + , groupLaws + , isListLaws + , monoidLaws + , monoidNullLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Sum Integer)) + [ cancellativeLaws + , commutativeLaws + , eqLaws + , groupLaws + , isListLaws + , leftCancellativeLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , reductiveLaws + , rightCancellativeLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Sum Natural)) + [ cancellativeLaws + , commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftCancellativeLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightCancellativeLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Set ())) + [ commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Set k)) + [ commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Set Ordering)) + [ commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (Set Int)) + [ commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + testLawsMany @(MonoidMap k (MonoidMap k (Sum Natural))) + [ cancellativeLaws + , commutativeLaws + , distributiveGCDMonoidLaws + , distributiveLCMMonoidLaws + , eqLaws + , gcdMonoidLaws + , lcmMonoidLaws + , isListLaws + , leftCancellativeLaws + , leftDistributiveGCDMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightCancellativeLaws + , rightDistributiveGCDMonoidLaws + , rightGCDMonoidLaws + , rightReductiveLaws + , semigroupLaws + , semigroupMonoidLaws + , showReadLaws + ] + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance (Arbitrary a, Eq a, Num a) => Arbitrary (NonZero a) where + arbitrary = genNonZero arbitrary + shrink = shrinkNonZero shrink diff --git a/components/monoidmap-test/Data/MonoidMap/ComparisonSpec.hs b/components/monoidmap-test/Data/MonoidMap/ComparisonSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/ComparisonSpec.hs @@ -0,0 +1,278 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.ComparisonSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.Monoid.Cancellative + ( Reductive (..) ) +import Data.Monoid.GCD + ( GCDMonoid ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesGCDMonoid + , testValueTypesAll + , testValueTypesReductive + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun2, cover, expectFailure, (.||.), (===) ) + +import qualified Data.Monoid.GCD as GCDMonoid + ( GCDMonoid (..) ) +import qualified Data.Monoid.Null as Null + ( MonoidNull (..) ) +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Comparison" $ do + + forM_ testValueTypesGCDMonoid $ + \(TestValueType p) -> specGCDMonoid + (Proxy @Key) p + + forM_ testValueTypesReductive $ + \(TestValueType p) -> specReductive + (Proxy @Key) p + + forM_ testValueTypesAll $ + \(TestValueType p) -> specMonoidNull + (Proxy @Key) p + +specGCDMonoid + :: forall k v. (Test k v, GCDMonoid v) => Proxy k -> Proxy v -> Spec +specGCDMonoid = makeSpec $ do + it "prop_disjoint_gcd" $ + prop_disjoint_gcd + @k @v & property + it "prop_disjoint_intersection" $ + prop_disjoint_intersection + @k @v & property + +specReductive + :: forall k v. (Test k v, Reductive v) => Proxy k -> Proxy v -> Spec +specReductive = makeSpec $ do + it "prop_isSubmapOf_minusMaybe" $ + prop_isSubmapOf_minusMaybe + @k @v & property + it "prop_isSubmapOf_reduce" $ + prop_isSubmapOf_reduce + @k @v & property + +specMonoidNull + :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specMonoidNull = makeSpec $ do + it "prop_disjointBy_get_total" $ + prop_disjointBy_get_total + @k @v & property + it "prop_disjointBy_get_total_failure" $ + prop_disjointBy_get_total_failure + @k @v & property + it "prop_isSubmapOfBy_get_total" $ + prop_isSubmapOfBy_get_total + @k @v & property + it "prop_isSubmapOfBy_get_total_failure" $ + prop_isSubmapOfBy_get_total_failure + @k @v & property + +prop_disjoint_gcd + :: (Test k v, GCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_disjoint_gcd m1 m2 k = + MonoidMap.disjoint m1 m2 ==> + (Null.null (GCDMonoid.gcd (MonoidMap.get k m1) (MonoidMap.get k m2))) + & cover 8 + (MonoidMap.disjoint m1 m2) + "MonoidMap.disjoint m1 m2" + & cover 8 + (not (MonoidMap.disjoint m1 m2)) + "not (MonoidMap.disjoint m1 m2)" + +prop_disjoint_intersection + :: (Test k v, GCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_disjoint_intersection m1 m2 = + MonoidMap.disjoint m1 m2 === (MonoidMap.intersection m1 m2 == mempty) + & cover 8 + (MonoidMap.disjoint m1 m2) + "MonoidMap.disjoint m1 m2" + & cover 8 + (not (MonoidMap.disjoint m1 m2)) + "not (MonoidMap.disjoint m1 m2)" + +prop_disjointBy_get_total + :: Test k v + => Fun (v, v) Bool + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_disjointBy_get_total (applyFun2 -> f0) m1 m2 k = + MonoidMap.disjointBy f m1 m2 + ==> + f (MonoidMap.get k m1) (MonoidMap.get k m2) + & cover 8 + (m1 /= mempty && m2 /= mempty && MonoidMap.disjointBy f m1 m2) + "m1 /= mempty && m2 /= mempty && MonoidMap.disjointBy f m1 m2" + & cover 2 + (keyWithinIntersection) + "keyWithinIntersection" + & cover 2 + (not keyWithinIntersection) + "not keyWithinIntersection" + where + keyWithinIntersection = + k `Set.member` Set.intersection + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + f v1 v2 + | Null.null v1 = True + | Null.null v2 = True + | otherwise = f0 v1 v2 + +prop_disjointBy_get_total_failure + :: Test k v + => Fun (v, v) Bool + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_disjointBy_get_total_failure (applyFun2 -> f) m1 m2 k = + expectFailure $ + MonoidMap.disjointBy f m1 m2 + ==> + f (MonoidMap.get k m1) (MonoidMap.get k m2) + +prop_isSubmapOf_minusMaybe + :: (Test k v, Reductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_isSubmapOf_minusMaybe m1 m2 = + MonoidMap.isSubmapOf m1 m2 + ==> isJust (m2 `MonoidMap.minusMaybe` m1) + & cover 0.01 + (nonTrivialSubmap) + "nonTrivialSubmap" + where + nonTrivialSubmap = + MonoidMap.isSubmapOf m1 m2 + && m1 /= mempty + && m2 /= mempty + && m1 /= m2 + +prop_isSubmapOf_reduce + :: (Test k v, Reductive v) + => MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_isSubmapOf_reduce m1 m2 k = + MonoidMap.isSubmapOf m1 m2 + ==> isJust (MonoidMap.get k m2 MonoidMap.get k m1) + & cover 0.001 + (nonTrivialSubmap && nonNullKeyL && nonNullKeyR) + "nonTrivialSubmap && nonNullKeyL && nonNullKeyR" + & cover 0.001 + (nonTrivialSubmap && nullKeyL && nonNullKeyR) + "nonTrivialSubmap && nullKeyL && nonNullKeyR" + & cover 0.001 + (nonTrivialSubmap && nullKeyL && nullKeyR) + "nonTrivialSubmap && nullKeyL && nullKeyR" + where + nonTrivialSubmap = + MonoidMap.isSubmapOf m1 m2 + && m1 /= mempty + && m2 /= mempty + && m1 /= m2 + nonNullKeyL = MonoidMap.nonNullKey k m1 + nonNullKeyR = MonoidMap.nonNullKey k m2 + nullKeyL = MonoidMap.nullKey k m1 + nullKeyR = MonoidMap.nullKey k m2 + +prop_isSubmapOfBy_get_total + :: Test k v + => Fun (v, v) Bool + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_isSubmapOfBy_get_total (applyFun2 -> f0) m1 m2 k = + MonoidMap.isSubmapOfBy f m1 m2 + ==> + f (MonoidMap.get k m1) (MonoidMap.get k m2) + & cover 0.01 + (nonTrivialSubmap && nonNullKeyL && nonNullKeyR) + "nonTrivialSubmap && nonNullKeyL && nonNullKeyR" + & cover 0.1 + (nonTrivialSubmap && nullKeyL && nonNullKeyR) + "nonTrivialSubmap && nullKeyL && nonNullKeyR" + & cover 0.1 + (nonTrivialSubmap && nonNullKeyL && nullKeyR) + "nonTrivialSubmap && nonNullKeyL && nullKeyR" + & cover 0.1 + (nonTrivialSubmap && nullKeyL && nullKeyR) + "nonTrivialSubmap && nullKeyL && nullKeyR" + where + f v1 v2 + | Null.null v1 = True + | otherwise = f0 v1 v2 + nonTrivialSubmap = + MonoidMap.isSubmapOfBy f m1 m2 + && m1 /= mempty + && m2 /= mempty + && m1 /= m2 + nonNullKeyL = MonoidMap.nonNullKey k m1 + nonNullKeyR = MonoidMap.nonNullKey k m2 + nullKeyL = MonoidMap.nullKey k m1 + nullKeyR = MonoidMap.nullKey k m2 + +prop_isSubmapOfBy_get_total_failure + :: Test k v + => Fun (v, v) Bool + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_isSubmapOfBy_get_total_failure (applyFun2 -> f) m1 m2 k = + expectFailure $ + MonoidMap.isSubmapOfBy f m1 m2 + ==> + f (MonoidMap.get k m1) (MonoidMap.get k m2) + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +infixr 3 ==> +(==>) :: Bool -> Bool -> Property +a ==> b = not a .||. b diff --git a/components/monoidmap-test/Data/MonoidMap/ConversionSpec.hs b/components/monoidmap-test/Data/MonoidMap/ConversionSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/ConversionSpec.hs @@ -0,0 +1,267 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.ConversionSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Map.Strict + ( Map ) +import Data.MonoidMap + ( MonoidMap, nonNullCount ) +import Data.Proxy + ( Proxy (..) ) +import Data.Set + ( Set ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) + +import qualified Data.Foldable as F +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Conversions" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + describe "Conversion to and from lists" $ do + it "prop_fromList_get" $ + prop_fromList_get + @k @v & property + it "prop_fromList_toMap" $ + prop_fromList_toMap + @k @v & property + it "prop_fromList_toList" $ + prop_fromList_toList + @k @v & property + it "prop_toList_fromList" $ + prop_toList_fromList + @k @v & property + it "prop_toList_sort" $ + prop_toList_sort + @k @v & property + it "prop_fromListWith_get" $ + prop_fromListWith_get + @k @v & property + + describe "Conversion to and from ordinary maps" $ do + it "prop_fromMap_get" $ + prop_fromMap_get + @k @v & property + it "prop_fromMap_toMap" $ + prop_fromMap_toMap + @k @v & property + it "prop_fromMapWith_fromMap" $ + prop_fromMapWith_fromMap + @k @v & property + it "prop_fromMapWith_get" $ + prop_fromMapWith_get + @k @v & property + it "prop_toMap_fromMap" $ + prop_toMap_fromMap + @k @v & property + + describe "Conversion from sets" $ do + it "prop_fromSet_get" $ + prop_fromSet_get + @k @v & property + +-------------------------------------------------------------------------------- +-- Conversion to and from lists +-------------------------------------------------------------------------------- + +prop_fromList_get + :: Test k v => [(k, v)] -> k -> Property +prop_fromList_get kvs k = + MonoidMap.get k (MonoidMap.fromList kvs) + === + F.foldMap snd (filter ((== k) . fst) kvs) + & cover 2 + (matchingKeyCount == 0) + "matchingKeyCount == 0" + & cover 2 + (matchingKeyCount == 1) + "matchingKeyCount == 1" + & cover 2 + (matchingKeyCount == 2) + "matchingKeyCount == 2" + & cover 2 + (matchingKeyCount >= 3) + "matchingKeyCount >= 3" + where + matchingKeyCount = + length $ filter ((== k) . fst) kvs + +prop_fromList_toMap + :: Test k v => [(k, v)] -> Property +prop_fromList_toMap kvs = + MonoidMap.toMap m === Map.filter (/= mempty) o + & cover 2 + (MonoidMap.nonNull m && nonNullCount m /= Map.size o) + "MonoidMap.nonNull m && nonNullCount m /= Map.size o" + & cover 2 + (MonoidMap.nonNull m && nonNullCount m == Map.size o) + "MonoidMap.nonNull m && nonNullCount m == Map.size o" + where + m = MonoidMap.fromList kvs + o = Map.fromListWith (flip (<>)) kvs + +prop_fromList_toList + :: Test k v => [(k, v)] -> Property +prop_fromList_toList kvs = + MonoidMap.toList m === Map.toList (Map.filter (/= mempty) o) + & cover 2 + (MonoidMap.nonNull m && nonNullCount m /= Map.size o) + "MonoidMap.nonNull m && nonNullCount m /= Map.size o" + & cover 2 + (MonoidMap.nonNull m && nonNullCount m == Map.size o) + "MonoidMap.nonNull m && nonNullCount m == Map.size o" + where + m = MonoidMap.fromList kvs + o = Map.fromListWith (flip (<>)) kvs + +prop_toList_fromList + :: Test k v => MonoidMap k v -> Property +prop_toList_fromList m = + MonoidMap.fromList (MonoidMap.toList m) === m + & cover 2 + (MonoidMap.nonNull m) + "MonoidMap.nonNull m" + +prop_toList_sort + :: Test k v => MonoidMap k v -> Property +prop_toList_sort m = + List.sortOn fst (MonoidMap.toList m) === MonoidMap.toList m + & cover 2 + (MonoidMap.nonNull m) + "MonoidMap.nonNull m" + +prop_fromListWith_get + :: Test k v => Fun (v, v) v -> [(k, v)] -> k -> Property +prop_fromListWith_get (applyFun2 -> f) kvs k = + MonoidMap.get k (MonoidMap.fromListWith f kvs) + === + maybe mempty + (F.foldl1 f) + (NE.nonEmpty (snd <$> filter ((== k) . fst) kvs)) + & cover 2 + (matchingKeyCount == 0) + "matchingKeyCount == 0" + & cover 2 + (matchingKeyCount == 1) + "matchingKeyCount == 1" + & cover 2 + (matchingKeyCount == 2) + "matchingKeyCount == 2" + & cover 2 + (matchingKeyCount >= 3) + "matchingKeyCount >= 3" + where + matchingKeyCount = + length $ filter ((== k) . fst) kvs + +-------------------------------------------------------------------------------- +-- Conversion to and from ordinary maps +-------------------------------------------------------------------------------- + +prop_fromMap_get + :: Test k v => Map k v -> k -> Property +prop_fromMap_get m k = + MonoidMap.get k (MonoidMap.fromMap m) === Map.findWithDefault mempty k m + & cover 2 + (MonoidMap.get k (MonoidMap.fromMap m) /= mempty) + "MonoidMap.get k (MonoidMap.fromMap m) /= mempty" + & cover 0.1 + (MonoidMap.get k (MonoidMap.fromMap m) == mempty && Map.member k m) + "MonoidMap.get k (MonoidMap.fromMap m) == mempty && Map.member k m" + +prop_fromMap_toMap + :: Test k v => Map k v -> Property +prop_fromMap_toMap o = + MonoidMap.toMap m === Map.filter (/= mempty) o + & cover 2 + (MonoidMap.nonNull m && nonNullCount m /= Map.size o) + "MonoidMap.nonNull m && nonNullCount m /= Map.size o" + & cover 2 + (MonoidMap.nonNull m && nonNullCount m == Map.size o) + "MonoidMap.nonNull m && nonNullCount m == Map.size o" + where + m = MonoidMap.fromMap o + +prop_fromMapWith_fromMap + :: Test k v => Map k v -> Property +prop_fromMapWith_fromMap m = + MonoidMap.fromMapWith id m === MonoidMap.fromMap m + & cover 2 + (MonoidMap.nonNull (MonoidMap.fromMap m)) + "MonoidMap.nonNull (MonoidMap.fromMap m)" + +prop_fromMapWith_get + :: Test k v => Fun v v -> Map k v -> k -> Property +prop_fromMapWith_get (applyFun -> f) m k = + MonoidMap.get k (MonoidMap.fromMapWith f m) + === maybe mempty f (Map.lookup k m) + & cover 2 + (MonoidMap.nonNullKey k (MonoidMap.fromMapWith f m)) + "MonoidMap.nonNullKey k (MonoidMap.fromMapWith f m)" + & cover 0.01 + (MonoidMap.nullKey k (MonoidMap.fromMapWith f m) && Map.member k m) + "MonoidMap.nullKey k (MonoidMap.fromMapWith f m) && Map.member k m" + +prop_toMap_fromMap + :: Test k v => MonoidMap k v -> Property +prop_toMap_fromMap m = + MonoidMap.fromMap (MonoidMap.toMap m) === m + +-------------------------------------------------------------------------------- +-- Conversion from sets +-------------------------------------------------------------------------------- + +prop_fromSet_get + :: Test k v => Fun k v -> Set k -> k -> Property +prop_fromSet_get (applyFun -> f) ks k = + MonoidMap.get k (MonoidMap.fromSet f ks) + === + (if Set.member k ks then f k else mempty) + & cover 0.2 + (Set.member k ks && Null.null (f k)) + "Set.member k ks && Null.null (f k)" + & cover 8.0 + (Set.member k ks && not (Null.null (f k))) + "Set.member k ks && not (Null.null (f k))" + & cover 0.2 + (not (Set.member k ks) && Null.null (f k)) + "not (Set.member k ks) && Null.null (f k)" + & cover 8.0 + (not (Set.member k ks) && not (Null.null (f k))) + "not (Set.member k ks) && not (Null.null (f k))" diff --git a/components/monoidmap-test/Data/MonoidMap/DistributivitySpec.hs b/components/monoidmap-test/Data/MonoidMap/DistributivitySpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/DistributivitySpec.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE RankNTypes #-} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.DistributivitySpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Data + ( typeRep ) +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.MonoidMap + ( MonoidMap, get ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (..) + , TestValue + , property + , testValueTypesGCDMonoid + , testValueTypesGroup + , testValueTypesLCMMonoid + , testValueTypesLeftGCDMonoid + , testValueTypesLeftReductive + , testValueTypesAll + , testValueTypesMonus + , testValueTypesOverlappingGCDMonoid + , testValueTypesReductive + , testValueTypesRightGCDMonoid + , testValueTypesRightReductive + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Property, cover, (===) ) + +import qualified Data.Group as Group + ( Group (..) ) +import qualified Data.Monoid.GCD as LeftGCDMonoid + ( LeftGCDMonoid (..) ) +import qualified Data.Monoid.GCD as RightGCDMonoid + ( RightGCDMonoid (..) ) +import qualified Data.Monoid.GCD as OverlappingGCDMonoid + ( OverlappingGCDMonoid (..) ) +import qualified Data.Monoid.GCD as GCDMonoid + ( GCDMonoid (..) ) +import qualified Data.Monoid.LCM as LCMMonoid + ( LCMMonoid (..) ) +import qualified Data.Monoid.Monus as Monus + ( Monus (..) ) +import qualified Data.Semigroup as Semigroup + ( Semigroup (..) ) +import qualified Data.Semigroup.Cancellative as LeftReductive + ( LeftReductive (..) ) +import qualified Data.Semigroup.Cancellative as RightReductive + ( RightReductive (..) ) +import qualified Data.Semigroup.Cancellative as Reductive + ( Reductive (..) ) + +spec :: Spec +spec = do + specDistributiveGet + specDistributiveGetMaybe + +specDistributiveGet :: Spec +specDistributiveGet = do + specForAll + testValueTypesAll + "Semigroup.<>" + (Semigroup.<>) + (Semigroup.<>) + specForAll + testValueTypesLeftGCDMonoid + "LeftGCDMonoid.commonPrefix" + (LeftGCDMonoid.commonPrefix) + (LeftGCDMonoid.commonPrefix) + specForAll + testValueTypesRightGCDMonoid + "RightGCDMonoid.commonSuffix" + (RightGCDMonoid.commonSuffix) + (RightGCDMonoid.commonSuffix) + specForAll + testValueTypesOverlappingGCDMonoid + "OverlappingGCDMonoid.overlap" + (OverlappingGCDMonoid.overlap) + (OverlappingGCDMonoid.overlap) + specForAll + testValueTypesGCDMonoid + "GCDMonoid.gcd" + (GCDMonoid.gcd) + (GCDMonoid.gcd) + specForAll + testValueTypesLCMMonoid + "LCMMonoid.lcm" + (LCMMonoid.lcm) + (LCMMonoid.lcm) + specForAll + testValueTypesGroup + "Group.minus" + (Group.~~) + (Group.~~) + specForAll + testValueTypesMonus + "Monus.monus" + (Monus.<\>) + (Monus.<\>) + where + specForAll + :: [TestValueType c] + -> String + -> (forall k v m. (Test k v, c v, m ~ MonoidMap k v) => (m -> m -> m)) + -> (forall v. (TestValue v, c v) => (v -> v -> v)) + -> Spec + specForAll testValueTypes funName f g = + describe description $ forM_ testValueTypes $ specFor f g + where + description = "Distributivity of 'get' with '" <> funName <> "'" + + specFor + :: (forall k v m. (Test k v, c v, m ~ MonoidMap k v) => (m -> m -> m)) + -> (forall v. (TestValue v, c v) => (v -> v -> v)) + -> TestValueType c + -> Spec + specFor f g (TestValueType (_ :: Proxy v)) = + it description $ property $ propDistributiveGet @Key @v f g + where + description = show $ typeRep $ Proxy @(MonoidMap Key v) + +specDistributiveGetMaybe :: Spec +specDistributiveGetMaybe = do + specForAll + testValueTypesLeftReductive + "LeftReductive.stripPrefix" + (LeftReductive.stripPrefix) + (LeftReductive.stripPrefix) + specForAll + testValueTypesRightReductive + "RightReductive.stripSuffix" + (RightReductive.stripSuffix) + (RightReductive.stripSuffix) + specForAll + testValueTypesReductive + "Reductive.minusMaybe" + (Reductive.) + (Reductive.) + where + specForAll + :: [TestValueType c] + -> String + -> (forall k v m. (Test k v, c v, m ~ MonoidMap k v) + => (m -> m -> Maybe m)) + -> (forall v. (TestValue v, c v) + => (v -> v -> Maybe v)) + -> Spec + specForAll testValueTypes funName f g = + describe description $ forM_ testValueTypes $ specFor f g + where + description = "Distributivity of 'get' with '" <> funName <> "'" + + specFor + :: (forall k v m. (Test k v, c v, m ~ MonoidMap k v) + => (m -> m -> Maybe m)) + -> (forall v. (TestValue v, c v) + => (v -> v -> Maybe v)) + -> TestValueType c + -> Spec + specFor f g (TestValueType (_ :: Proxy v)) = + it description $ property $ propDistributiveGetMaybe @Key @v f g + where + description = show $ typeRep $ Proxy @(MonoidMap Key v) + +propDistributiveGet + :: Test k v + => (MonoidMap k v -> MonoidMap k v -> MonoidMap k v) + -> (v -> v -> v) + -> k + -> MonoidMap k v + -> MonoidMap k v + -> Property +propDistributiveGet f g k m1 m2 = + get k (f m1 m2) === g (get k m1) (get k m2) + & cover 2 + (get k (f m1 m2) == mempty) + "get k (f m1 m2) == mempty" + & cover 2 + (get k (f m1 m2) /= mempty) + "get k (f m1 m2) /= mempty" + & cover 2 + (get k m1 == mempty && get k m2 == mempty) + "get k m1 == mempty && get k m2 == mempty" + & cover 2 + (get k m1 == mempty && get k m2 /= mempty) + "get k m1 == mempty && get k m2 /= mempty" + & cover 2 + (get k m1 /= mempty && get k m2 == mempty) + "get k m1 /= mempty && get k m2 == mempty" + & cover 2 + (get k m1 /= mempty && get k m2 /= mempty) + "get k m1 /= mempty && get k m2 /= mempty" + +propDistributiveGetMaybe + :: Test k v + => (MonoidMap k v -> MonoidMap k v -> Maybe (MonoidMap k v)) + -> (v -> v -> Maybe v) + -> k + -> MonoidMap k v + -> MonoidMap k v + -> Property +propDistributiveGetMaybe f g k m1 m2 = property $ + all (\m -> g (get k m1) (get k m2) == Just (get k m)) (f m1 m2) + & cover 2 + (isJust (f m1 m2) && g (get k m1) (get k m2) == Just mempty) + "isJust (f m1 m2) && g (get k m1) (get k m2) == Just mempty" + & cover 2 + (isJust (f m1 m2) && g (get k m1) (get k m2) /= Just mempty) + "isJust (f m1 m2) && g (get k m1) (get k m2) /= Just mempty" diff --git a/components/monoidmap-test/Data/MonoidMap/ExampleSpec.hs b/components/monoidmap-test/Data/MonoidMap/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/ExampleSpec.hs @@ -0,0 +1,1738 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.ExampleSpec + where + +import Prelude hiding + ( gcd, lcm ) + +import Data.Function + ( (&) ) +import Data.Group + ( Group (..) ) +import Data.Monoid + ( Product (..), Sum (..) ) +import Data.Monoid.GCD + ( GCDMonoid (..), LeftGCDMonoid (..), RightGCDMonoid (..) ) +import Data.Monoid.LCM + ( LCMMonoid (..) ) +import Data.Monoid.Monus + ( OverlappingGCDMonoid (..), (<\>) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Ratio + ( (%) ) +import Data.Semigroup.Cancellative + ( LeftReductive (..), RightReductive (..) ) +import Data.Set + ( Set ) +import Numeric.Natural + ( Natural ) +import Test.Common + () +import Test.Hspec + ( Spec, describe ) +import Test.Hspec.Unit + ( UnitTestData1 + , UnitTestData2 + , unitTestData1 + , unitTestData2 + , unitTestSpec + ) + +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Examples" $ do + + describe "Conversion" $ do + + exampleSpec_fromList_String + exampleSpec_toList_String + + describe "Comparison" $ do + + exampleSpec_isSubmapOf_Sum_Natural + exampleSpec_disjoint_Product_Natural + exampleSpec_disjoint_Sum_Natural + exampleSpec_disjoint_Set_Natural + + describe "Intersection" $ do + + exampleSpec_intersectionWith_min_Sum_Natural + + describe "Union" $ do + + exampleSpec_unionWith_max_Sum_Natural + + describe "Semigroup" $ do + + exampleSpec_Semigroup_mappend_String + exampleSpec_Semigroup_mappend_Sum_Natural + + describe "Group" $ do + + exampleSpec_Group_invert_Product_Rational + exampleSpec_Group_invert_Sum_Integer + exampleSpec_Group_pow_Product_Rational + exampleSpec_Group_pow_Sum_Integer + exampleSpec_Group_subtract_Product_Rational + exampleSpec_Group_subtract_Sum_Integer + + describe "Reductive" $ do + + exampleSpec_Reductive_isPrefixOf_String + exampleSpec_Reductive_isPrefixOf_Sum_Natural + exampleSpec_Reductive_isSuffixOf_String + exampleSpec_Reductive_isSuffixOf_Sum_Natural + exampleSpec_Reductive_stripPrefix_String + exampleSpec_Reductive_stripPrefix_Sum_Natural + exampleSpec_Reductive_stripSuffix_String + exampleSpec_Reductive_stripSuffix_Sum_Natural + + describe "LeftGCDMonoid" $ do + + exampleSpec_LeftGCDMonoid_commonPrefix_String + exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural + exampleSpec_LeftGCDMonoid_stripCommonPrefix_String + exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural + + describe "RightGCDMonoid" $ do + + exampleSpec_RightGCDMonoid_commonSuffix_String + exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural + exampleSpec_RightGCDMonoid_stripCommonSuffix_String + exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural + + describe "OverlappingGCDMonoid" $ do + + exampleSpec_OverlappingGCDMonoid_overlap_String + exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural + exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String + exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural + exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String + exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural + + describe "GCDMonoid" $ do + + exampleSpec_GCDMonoid_gcd_Product_Natural + exampleSpec_GCDMonoid_gcd_Sum_Natural + exampleSpec_GCDMonoid_gcd_Set_Natural + + describe "LCMMonoid" $ do + + exampleSpec_LCMMonoid_lcm_Product_Natural + exampleSpec_LCMMonoid_lcm_Sum_Natural + exampleSpec_LCMMonoid_lcm_Set_Natural + + describe "Monus" $ do + + exampleSpec_Monus_monus_Set_Natural + exampleSpec_Monus_monus_Sum_Natural + +-------------------------------------------------------------------------------- +-- Conversion +-------------------------------------------------------------------------------- + +exampleSpec_fromList_String :: Spec +exampleSpec_fromList_String = unitTestSpec + "MonoidMap.fromList (String)" + "MonoidMap.fromList" + (MonoidMap.fromList) + (exampleData_fromList_String) + +exampleData_fromList_String :: UnitTestData1 + [(Int, String)] + (MonoidMap Int String) +exampleData_fromList_String = unitTestData1 + [ ( [(1, "a"), (2, "x"), (1, "b"), (2, "y"), (1, "c"), (2, "z")] + , [(1, "abc"), (2, "xyz")] + ) + ] + +exampleSpec_toList_String :: Spec +exampleSpec_toList_String = unitTestSpec + "MonoidMap.toList (String)" + "MonoidMap.toList" + (MonoidMap.toList) + (exampleData_toList_String) + +exampleData_toList_String :: UnitTestData1 + (MonoidMap Int String) + [(Int, String)] +exampleData_toList_String = unitTestData1 + [ ( [(3, "z"), (2, "y"), (1, "x")] + , [(1, "x"), (2, "y"), (3, "z")] + ) + ] + +-------------------------------------------------------------------------------- +-- Comparison +-------------------------------------------------------------------------------- + +exampleSpec_isSubmapOf_Sum_Natural :: Spec +exampleSpec_isSubmapOf_Sum_Natural = unitTestSpec + "MonoidMap.isSubmapOf (Sum Natural)" + "MonoidMap.isSubmapOf" + (MonoidMap.isSubmapOf) + (exampleData_isSubmapOf_Sum_Natural) + +exampleData_isSubmapOf_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (Bool) +exampleData_isSubmapOf_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3] + , m [4, 4, 4, 4] + , True + ) + , ( m [0, 1, 2, 3] + , m [0, 4, 4, 4] + , True + ) + , ( m [0, 1, 2, 3] + , m [0, 1, 4, 4] + , True + ) + , ( m [0, 1, 2, 3] + , m [0, 1, 2, 4] + , True + ) + , ( m [0, 1, 2, 3] + , m [0, 1, 2, 3] + , True + ) + , ( m [0, 1, 2, 3] + , m [0, 0, 2, 3] + , False + ) + , ( m [0, 1, 2, 3] + , m [0, 1, 1, 3] + , False + ) + , ( m [0, 1, 2, 3] + , m [0, 1, 2, 2] + , False + ) + , ( m [0, 1, 2, 3] + , m [0, 0, 0, 0] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_disjoint_Product_Natural :: Spec +exampleSpec_disjoint_Product_Natural = unitTestSpec + "MonoidMap.disjoint (Product Natural)" + "MonoidMap.disjoint" + (MonoidMap.disjoint) + (exampleData_disjoint_Product_Natural) + +exampleData_disjoint_Product_Natural :: UnitTestData2 + (MonoidMap LatinChar (Product Natural)) + (MonoidMap LatinChar (Product Natural)) + (Bool) +exampleData_disjoint_Product_Natural = unitTestData2 + [ ( m [] + , m [] + , True + ) + , ( m [2, 3, 5, 7] + , m [3, 5, 7, 2] + , True + ) + , ( m [2 * 3, 5 * 7] + , m [5 * 7, 2 * 3] + , True + ) + , ( m [2 * 3 , 3 * 5 ] + , m [ 3 * 5, 5 * 7] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_disjoint_Sum_Natural :: Spec +exampleSpec_disjoint_Sum_Natural = unitTestSpec + "MonoidMap.disjoint (Sum Natural)" + "MonoidMap.disjoint" + (MonoidMap.disjoint) + (exampleData_disjoint_Sum_Natural) + +exampleData_disjoint_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (Bool) +exampleData_disjoint_Sum_Natural = unitTestData2 + [ ( m [] + , m [] + , True + ) + , ( m [0, 1, 0, 1] + , m [1, 0, 1, 0] + , True + ) + , ( m [0, 8, 0, 8] + , m [8, 0, 8, 0] + , True + ) + , ( m [0, 8, 0, 8] + , m [8, 0, 8, 1] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_disjoint_Set_Natural :: Spec +exampleSpec_disjoint_Set_Natural = unitTestSpec + "MonoidMap.disjoint (Set Natural)" + "MonoidMap.disjoint" + (MonoidMap.disjoint) + (exampleData_disjoint_Set_Natural) + +exampleData_disjoint_Set_Natural :: UnitTestData2 + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) + (Bool) +exampleData_disjoint_Set_Natural = unitTestData2 + [ ( m [] + , m [] + , True + ) + , ( m [[1], [2], [3], [4]] + , m [[5], [6], [7], [8]] + , True + ) + , ( m [[1, 2], [3, 4]] + , m [[5, 6], [7, 8]] + , True + ) + , ( m [[1, 2 ], [3, 4 ]] + , m [[ 2, 3], [ 4, 5]] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList + +-------------------------------------------------------------------------------- +-- Intersection +-------------------------------------------------------------------------------- + +exampleSpec_intersectionWith_min_Sum_Natural :: Spec +exampleSpec_intersectionWith_min_Sum_Natural = unitTestSpec + "MonoidMap.intersectionWith (Sum Natural)" + "MonoidMap.intersectionWith" + (MonoidMap.intersectionWith min) + (exampleData_intersectionWith_min_Sum_Natural) + +exampleData_intersectionWith_min_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_intersectionWith_min_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7] + , m [7, 6, 5, 4, 3, 2, 1, 0] + , m [0, 1, 2, 3, 3, 2, 1, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- Union +-------------------------------------------------------------------------------- + +exampleSpec_unionWith_max_Sum_Natural :: Spec +exampleSpec_unionWith_max_Sum_Natural = unitTestSpec + "MonoidMap.unionWith (Sum Natural)" + "MonoidMap.unionWith" + (MonoidMap.unionWith max) + (exampleData_unionWith_max_Sum_Natural) + +exampleData_unionWith_max_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_unionWith_max_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7] + , m [7, 6, 5, 4, 3, 2, 1, 0] + , m [7, 6, 5, 4, 4, 5, 6, 7] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- Semigroup +-------------------------------------------------------------------------------- + +exampleSpec_Semigroup_mappend_String :: Spec +exampleSpec_Semigroup_mappend_String = unitTestSpec + "Semigroup.mappend (String)" + "mappend" + (mappend) + (exampleData_Semigroup_concat_String) + +exampleData_Semigroup_concat_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_Semigroup_concat_String = unitTestData2 + [ ( m ["abc", "ij" , "p" , "" ] + , m [ "", "k", "qr", "xyz"] + , m ["abc", "ijk", "pqr", "xyz"] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Semigroup_mappend_Sum_Natural :: Spec +exampleSpec_Semigroup_mappend_Sum_Natural = unitTestSpec + "Semigroup.mappend (Sum Natural)" + "mappend" + (mappend) + (exampleData_Semigroup_concat_Sum_Natural) + +exampleData_Semigroup_concat_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_Semigroup_concat_Sum_Natural = unitTestData2 + [ ( m [4, 2, 1, 0] + , m [0, 1, 2, 4] + , m [4, 3, 3, 4] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- Group +-------------------------------------------------------------------------------- + +exampleSpec_Group_invert_Product_Rational :: Spec +exampleSpec_Group_invert_Product_Rational = unitTestSpec + "Group.invert (Product Rational)" + "invert" + (invert) + (exampleData_Group_invert_Product_Rational) + +exampleData_Group_invert_Product_Rational :: UnitTestData1 + (MonoidMap LatinChar (Product Rational)) + (MonoidMap LatinChar (Product Rational)) +exampleData_Group_invert_Product_Rational = unitTestData1 + [ ( m [ 2, 4, 8, 16] + , m [1%2, 1%4, 1%8, 1%16] + ) + , ( m [1%2, 1%4, 1%8, 1%16] + , m [ 2, 4, 8, 16] + ) + , ( m [ 2, 1%4, 8, 16] + , m [1%2, 4, 1%8, 1%16] + ) + , ( m [1%2, 4, 1%8, 1%16] + , m [ 2, 1%4, 8, 16] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Product + +exampleSpec_Group_invert_Sum_Integer :: Spec +exampleSpec_Group_invert_Sum_Integer = unitTestSpec + "Group.invert (Sum Integer)" + "invert" + (invert) + (exampleData_Group_invert_Sum_Integer) + +exampleData_Group_invert_Sum_Integer :: UnitTestData1 + (MonoidMap LatinChar (Sum Integer)) + (MonoidMap LatinChar (Sum Integer)) +exampleData_Group_invert_Sum_Integer = unitTestData1 + [ ( m [ 1, 2, 3, 4] + , m [-1, -2, -3, -4] + ) + , ( m [-1, -2, -3, -4] + , m [ 1, 2, 3, 4] + ) + , ( m [ 1, -2, 3, -4] + , m [-1, 2, -3, 4] + ) + , ( m [-1, 2, -3, 4] + , m [ 1, -2, 3, -4] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Sum + +exampleSpec_Group_pow_Product_Rational :: Spec +exampleSpec_Group_pow_Product_Rational = unitTestSpec + "Group.pow (Product Rational)" + "pow" + (pow) + (exampleData_Group_pow_Product_Rational) + +exampleData_Group_pow_Product_Rational :: UnitTestData2 + (MonoidMap LatinChar (Product Rational)) + (Integer) + (MonoidMap LatinChar (Product Rational)) +exampleData_Group_pow_Product_Rational = unitTestData2 + [ ( m [ 2, -4, 8, -16], (-1) + , m [1%2, -1%4, 1%8, -1%16] + ) + , ( m [ 2, -4, 8, -16], 0 + , m [ 1, 1, 1, 1] + ) + , ( m [ 2, -4, 8, -16], 1 + , m [ 2, -4, 8, -16] + ) + , ( m [ 2, -4, 8, -16], 2 + , m [ 4, 16, 64, 256] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Product + +exampleSpec_Group_pow_Sum_Integer :: Spec +exampleSpec_Group_pow_Sum_Integer = unitTestSpec + "Group.pow (Sum Integer)" + "pow" + (pow) + (exampleData_Group_pow_Sum_Integer) + +exampleData_Group_pow_Sum_Integer :: UnitTestData2 + (MonoidMap LatinChar (Sum Integer)) + (Integer) + (MonoidMap LatinChar (Sum Integer)) +exampleData_Group_pow_Sum_Integer = unitTestData2 + [ ( m [ 1, -2, 3, -4], (-1) + , m [-1, 2, -3, 4] + ) + , ( m [ 1, -2, 3, -4], 0 + , m [ 0, 0, 0, 0] + ) + , ( m [ 1, -2, 3, -4], 1 + , m [ 1, -2, 3, -4] + ) + , ( m [ 1, -2, 3, -4], 2 + , m [ 2, -4, 6, -8] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Sum + +exampleSpec_Group_subtract_Product_Rational :: Spec +exampleSpec_Group_subtract_Product_Rational = unitTestSpec + "Group.(~~) (Product Rational)" + "(~~)" + (~~) + (exampleData_Group_subtract_Product_Rational) + +exampleData_Group_subtract_Product_Rational :: UnitTestData2 + (MonoidMap LatinChar (Product Rational)) + (MonoidMap LatinChar (Product Rational)) + (MonoidMap LatinChar (Product Rational)) +exampleData_Group_subtract_Product_Rational = unitTestData2 + [ ( m [ 1, 1, 1, 1] + , m [ 1, 2, 4, 8] + , m [ 1, 1%2, 1%4, 1%8] + ) + , ( m [-1, -1, -1, -1] + , m [ 1, 2, 4, 8] + , m [-1, -1%2, -1%4, -1%8] + ) + , ( m [ 1, 1, 1, 1] + , m [-1, -2, -4, -8] + , m [-1, -1%2, -1%4, -1%8] + ) + , ( m [-1, -1, -1, -1] + , m [-1, -2, -4, -8] + , m [ 1, 1%2, 1%4, 1%8] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Product + +exampleSpec_Group_subtract_Sum_Integer :: Spec +exampleSpec_Group_subtract_Sum_Integer = unitTestSpec + "Group.(~~) (Sum Integer)" + "(~~)" + (~~) + (exampleData_Group_subtract_Sum_Integer) + +exampleData_Group_subtract_Sum_Integer :: UnitTestData2 + (MonoidMap LatinChar (Sum Integer)) + (MonoidMap LatinChar (Sum Integer)) + (MonoidMap LatinChar (Sum Integer)) +exampleData_Group_subtract_Sum_Integer = unitTestData2 + [ ( m [ 1, 2, 3, 4] + , m [ 1, 2, 3, 4] + , m [ 0, 0, 0, 0] + ) + , ( m [ 0, 0, 0, 0] + , m [ 1, 2, 3, 4] + , m [-1, -2, -3, -4] + ) + , ( m [ 1, 2, 3, 4] + , m [-1, -2, -3, -4] + , m [ 2, 4, 6, 8] + ) + , ( m [-1, -2, -3, -4] + , m [-1, -2, -3, -4] + , m [ 0, 0, 0, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Sum + +-------------------------------------------------------------------------------- +-- Reductive +-------------------------------------------------------------------------------- + +exampleSpec_Reductive_isPrefixOf_String :: Spec +exampleSpec_Reductive_isPrefixOf_String = unitTestSpec + "Reductive.isPrefixOf (String)" + "isPrefixOf" + (isPrefixOf) + (exampleData_Reductive_isPrefixOf_String) + +exampleData_Reductive_isPrefixOf_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (Bool) +exampleData_Reductive_isPrefixOf_String = unitTestData2 + [ ( m ["A" , "B" , "C" ] + , m ["A123", "B123", "C123"] + , True + ) + , ( m ["A123", "B123", "C123"] + , m ["A" , "B" , "C" ] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Reductive_isSuffixOf_String :: Spec +exampleSpec_Reductive_isSuffixOf_String = unitTestSpec + "Reductive.isSuffixOf (String)" + "isSuffixOf" + (isSuffixOf) + (exampleData_Reductive_isSuffixOf_String) + +exampleData_Reductive_isSuffixOf_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (Bool) +exampleData_Reductive_isSuffixOf_String = unitTestData2 + [ ( m [ "A", "B", "C"] + , m ["123A", "123B", "123C"] + , True + ) + , ( m ["123A", "123B", "123C"] + , m [ "A", "B", "C"] + , False + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Reductive_isPrefixOf_Sum_Natural :: Spec +exampleSpec_Reductive_isPrefixOf_Sum_Natural = unitTestSpec + "Reductive.isPrefixOf (Sum Natural)" + "isPrefixOf" + (isPrefixOf) + (exampleData_Reductive_Sum_Natural) + +exampleSpec_Reductive_isSuffixOf_Sum_Natural :: Spec +exampleSpec_Reductive_isSuffixOf_Sum_Natural = unitTestSpec + "Reductive.isSuffixOf (Sum Natural)" + "isSuffixOf" + (isSuffixOf) + (exampleData_Reductive_Sum_Natural) + +exampleData_Reductive_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (Bool) +exampleData_Reductive_Sum_Natural = unitTestData2 + [ ( m [1, 1], m [1, 1], True ) + , ( m [1, 1], m [1, 2], True ) + , ( m [1, 1], m [2, 1], True ) + , ( m [1, 1], m [2, 2], True ) + , ( m [1, 2], m [1, 1], False) + , ( m [1, 2], m [1, 2], True ) + , ( m [1, 2], m [2, 1], False) + , ( m [1, 2], m [2, 2], True ) + , ( m [2, 1], m [1, 1], False) + , ( m [2, 1], m [1, 2], False) + , ( m [2, 1], m [2, 1], True ) + , ( m [2, 1], m [2, 2], True ) + , ( m [2, 2], m [1, 1], False) + , ( m [2, 2], m [1, 2], False) + , ( m [2, 2], m [2, 1], False) + , ( m [2, 2], m [2, 2], True ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Sum + +exampleSpec_Reductive_stripPrefix_String :: Spec +exampleSpec_Reductive_stripPrefix_String = unitTestSpec + "Reductive.stripPrefix (String)" + "stripPrefix" + (stripPrefix) + (exampleData_Reductive_stripPrefix_String) + +exampleData_Reductive_stripPrefix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (Maybe (MonoidMap LatinChar String)) +exampleData_Reductive_stripPrefix_String = unitTestData2 + [ ( m ["" , "" , "" ] + , m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] & Just + ) + , ( m ["a" , "p" , "x" ] + , m ["abc", "pqr", "xyz"] + , m [ "bc", "qr", "yz"] & Just + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + , m [ "", "", ""] & Just + ) + , ( m ["?" , "p" , "x" ] + , m ["abc", "pqr", "xyz"] + , Nothing + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Reductive_stripPrefix_Sum_Natural :: Spec +exampleSpec_Reductive_stripPrefix_Sum_Natural = unitTestSpec + "Reductive.stripPrefix (Sum Natural)" + "stripPrefix" + (stripPrefix) + (exampleData_Reductive_stripPrefix_Sum_Natural) + +exampleData_Reductive_stripPrefix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (Maybe (MonoidMap LatinChar (Sum Natural))) +exampleData_Reductive_stripPrefix_Sum_Natural = unitTestData2 + [ ( m [0, 0, 0] + , m [2, 4, 8] + , m [2, 4, 8] & Just + ) + , ( m [1, 2, 4] + , m [2, 4, 8] + , m [1, 2, 4] & Just + ) + , ( m [2, 4, 8] + , m [2, 4, 8] + , m [0, 0, 0] & Just + ) + , ( m [3, 4, 8] + , m [2, 4, 8] + , Nothing + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Reductive_stripSuffix_String :: Spec +exampleSpec_Reductive_stripSuffix_String = unitTestSpec + "Reductive.stripSuffix (String)" + "stripSuffix" + (stripSuffix) + (exampleData_Reductive_stripSuffix_String) + +exampleData_Reductive_stripSuffix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (Maybe (MonoidMap LatinChar String)) +exampleData_Reductive_stripSuffix_String = unitTestData2 + [ ( m [ "", "", ""] + , m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] & Just + ) + , ( m [ "c", "r", "z"] + , m ["abc", "pqr", "xyz"] + , m ["ab" , "pq" , "xy" ] & Just + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + , m ["" , "" , "" ] & Just + ) + , ( m [ "?", "r", "z"] + , m ["abc", "pqr", "xyz"] + , Nothing + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_Reductive_stripSuffix_Sum_Natural :: Spec +exampleSpec_Reductive_stripSuffix_Sum_Natural = unitTestSpec + "Reductive.stripSuffix (Sum Natural)" + "stripSuffix" + (stripSuffix) + (exampleData_Reductive_stripSuffix_Sum_Natural) + +exampleData_Reductive_stripSuffix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (Maybe (MonoidMap LatinChar (Sum Natural))) +exampleData_Reductive_stripSuffix_Sum_Natural = unitTestData2 + [ ( m [0, 0, 0] + , m [2, 4, 8] + , m [2, 4, 8] & Just + ) + , ( m [1, 2, 4] + , m [2, 4, 8] + , m [1, 2, 4] & Just + ) + , ( m [2, 4, 8] + , m [2, 4, 8] + , m [0, 0, 0] & Just + ) + , ( m [3, 4, 8] + , m [2, 4, 8] + , Nothing + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- LeftGCDMonoid +-------------------------------------------------------------------------------- + +exampleSpec_LeftGCDMonoid_commonPrefix_String :: Spec +exampleSpec_LeftGCDMonoid_commonPrefix_String = unitTestSpec + "LeftGCDMonoid.commonPrefix (String)" + "commonPrefix" + (commonPrefix) + (exampleData_LeftGCDMonoid_commonPrefix_String) + +exampleData_LeftGCDMonoid_commonPrefix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_LeftGCDMonoid_commonPrefix_String = unitTestData2 + [ ( m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + , m ["" , "" , "" ] + ) + , ( m ["a--", "p--", "x--"] + , m ["abc", "pqr", "xyz"] + , m ["a" , "p" , "x" ] + ) + , ( m ["ab-", "pq-", "xy-"] + , m ["abc", "pqr", "xyz"] + , m ["ab" , "pq" , "xy" ] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["ab-", "pq-", "xy-"] + , m ["ab" , "pq" , "xy" ] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["a--", "p--", "x--"] + , m ["a" , "p" , "x" ] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + , m ["" , "" , "" ] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural :: Spec +exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural = unitTestSpec + "LeftGCDMonoid.commonPrefix (Sum Natural)" + "commonPrefix" + (commonPrefix) + (exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural) + +exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural = unitTestData2 + [ ( m [0, 0, 0] + , m [1, 2, 3] + , m [0, 0, 0] + ) + , ( m [1, 1, 1] + , m [1, 2, 3] + , m [1, 1, 1] + ) + , ( m [2, 2, 2] + , m [1, 2, 3] + , m [1, 2, 2] + ) + , ( m [3, 3, 3] + , m [1, 2, 3] + , m [1, 2, 3] + ) + , ( m [4, 4, 4] + , m [1, 2, 3] + , m [1, 2, 3] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_LeftGCDMonoid_stripCommonPrefix_String :: Spec +exampleSpec_LeftGCDMonoid_stripCommonPrefix_String = unitTestSpec + "LeftGCDMonoid.stripCommonPrefix (String)" + "stripCommonPrefix" + (stripCommonPrefix) + (exampleData_LeftGCDMonoid_stripCommonPrefix_String) + +exampleData_LeftGCDMonoid_stripCommonPrefix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + ( MonoidMap LatinChar String + , MonoidMap LatinChar String + , MonoidMap LatinChar String + ) +exampleData_LeftGCDMonoid_stripCommonPrefix_String = unitTestData2 + [ ( m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + + , ( m ["" , "" , "" ] + , m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + ) + ) + , ( m ["a--", "p--", "x--"] + , m ["abc", "pqr", "xyz"] + + , ( m ["a" , "p" , "x" ] + , m [ "--", "--", "--"] + , m [ "bc", "qr", "yz"] + ) + ) + , ( m ["ab-", "pq-", "xy-"] + , m ["abc", "pqr", "xyz"] + + , ( m ["ab" , "pq" , "xy" ] + , m [ "-", "-", "-"] + , m [ "c", "r", "z"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + + , ( m ["abc", "pqr", "xyz"] + , m [ "", "", ""] + , m [ "", "", ""] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["ab-", "pq-", "xy-"] + + , ( m ["ab" , "pq" , "xy" ] + , m [ "c", "r", "z"] + , m [ "-", "-", "-"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["a--", "p--", "x--"] + , ( m ["a" , "p" , "x" ] + , m [ "bc", "qr", "yz"] + , m [ "--", "--", "--"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + , ( m ["" , "" , "" ] + , m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + ) + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural :: Spec +exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural = unitTestSpec + "LeftGCDMonoid.stripCommonPrefix (Sum Natural)" + "stripCommonPrefix" + (stripCommonPrefix) + (exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural) + +exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + ( MonoidMap LatinChar (Sum Natural) + , MonoidMap LatinChar (Sum Natural) + , MonoidMap LatinChar (Sum Natural) + ) +exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4] + , m [4, 3, 2, 1, 0] + + , ( m [0, 1, 2, 1, 0] + , m [0, 0, 0, 2, 4] + , m [4, 2, 0, 0, 0] + ) + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- RightGCDMonoid +-------------------------------------------------------------------------------- + +exampleSpec_RightGCDMonoid_commonSuffix_String :: Spec +exampleSpec_RightGCDMonoid_commonSuffix_String = unitTestSpec + "RightGCDMonoid.commonSuffix (String)" + "commonSuffix" + (commonSuffix) + (exampleData_RightGCDMonoid_commonSuffix_String) + +exampleData_RightGCDMonoid_commonSuffix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_RightGCDMonoid_commonSuffix_String = unitTestData2 + [ ( m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + , m [ "" , "", ""] + ) + , ( m ["--c", "--r", "--z"] + , m ["abc", "pqr", "xyz"] + , m [ "c", "r", "z"] + ) + , ( m ["-bc", "-qr", "-yz"] + , m ["abc", "pqr", "xyz"] + , m [ "bc", "qr", "yz"] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["-bc", "-qr", "-yz"] + , m [ "bc", "qr", "yz"] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["--c", "--r", "--z"] + , m [ "c", "r", "z"] + ) + , ( m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + , m [ "", "", ""] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural :: Spec +exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural = unitTestSpec + "RightGCDMonoid.commonSuffix (Sum Natural)" + "commonSuffix" + (commonSuffix) + (exampleData_RightGCDMonoid_commonSuffix_Sum_Natural) + +exampleData_RightGCDMonoid_commonSuffix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_RightGCDMonoid_commonSuffix_Sum_Natural = unitTestData2 + [ ( m [0, 0, 0] + , m [1, 2, 3] + , m [0, 0, 0] + ) + , ( m [1, 1, 1] + , m [1, 2, 3] + , m [1, 1, 1] + ) + , ( m [2, 2, 2] + , m [1, 2, 3] + , m [1, 2, 2] + ) + , ( m [3, 3, 3] + , m [1, 2, 3] + , m [1, 2, 3] + ) + , ( m [4, 4, 4] + , m [1, 2, 3] + , m [1, 2, 3] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_RightGCDMonoid_stripCommonSuffix_String :: Spec +exampleSpec_RightGCDMonoid_stripCommonSuffix_String = unitTestSpec + "RightGCDMonoid.stripCommonSuffix (String)" + "stripCommonSuffix" + (stripCommonSuffix) + (exampleData_RightGCDMonoid_stripCommonSuffix_String) + +exampleData_RightGCDMonoid_stripCommonSuffix_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + ( MonoidMap LatinChar String + , MonoidMap LatinChar String + , MonoidMap LatinChar String + ) +exampleData_RightGCDMonoid_stripCommonSuffix_String = unitTestData2 + [ ( m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + + , ( m ["---", "---", "---"] + , m ["abc", "pqr", "xyz"] + , m [ "", "", ""] + ) + ) + , ( m ["--c", "--r", "--z"] + , m ["abc", "pqr", "xyz"] + + , ( m ["--" , "--" , "--" ] + , m ["ab" , "pq" , "xy" ] + , m [ "c", "r", "z"] + ) + ) + , ( m ["--c", "--r", "--z"] + , m ["abc", "pqr", "xyz"] + + , ( m ["--" , "--" , "--" ] + , m ["ab" , "pq" , "xy" ] + , m [ "c", "r", "z"] + ) + ) + , ( m ["-bc", "-qr", "-yz"] + , m ["abc", "pqr", "xyz"] + + , ( m ["-" , "-" , "-" ] + , m ["a" , "p" , "x" ] + , m [ "bc", "qr", "yz"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["abc", "pqr", "xyz"] + + , ( m ["" , "" , "" ] + , m ["" , "" , "" ] + , m ["abc", "pqr", "xyz"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["-bc", "-qr", "-yz"] + + , ( m ["a" , "p" , "x" ] + , m ["-" , "-" , "-" ] + , m [ "bc", "qr", "yz"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["--c", "--r", "--z"] + + , ( m ["ab" , "pq" , "xy" ] + , m ["--" , "--" , "--" ] + , m [ "c", "r", "z"] + ) + ) + , ( m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + + , ( m ["abc", "pqr", "xyz"] + , m ["---", "---", "---"] + , m [ "", "", ""] + ) + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural :: Spec +exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural = unitTestSpec + "RightGCDMonoid.stripCommonSuffix (Sum Natural)" + "stripCommonSuffix" + (stripCommonSuffix) + (exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural) + +exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + ( MonoidMap LatinChar (Sum Natural) + , MonoidMap LatinChar (Sum Natural) + , MonoidMap LatinChar (Sum Natural) + ) +exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4] + , m [4, 3, 2, 1, 0] + + , ( m [0, 0, 0, 2, 4] + , m [4, 2, 0, 0, 0] + , m [0, 1, 2, 1, 0] + ) + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- OverlappingGCDMonoid +-------------------------------------------------------------------------------- + +exampleSpec_OverlappingGCDMonoid_overlap_String :: Spec +exampleSpec_OverlappingGCDMonoid_overlap_String = unitTestSpec + "OverlappingGCDMonoid.overlap (String)" + "overlap" + (overlap) + (exampleData_OverlappingGCDMonoid_overlap_String) + +exampleData_OverlappingGCDMonoid_overlap_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_OverlappingGCDMonoid_overlap_String = unitTestData2 + [ ( m ["abcd" , "0123" ] + , m [ "efgh", "4567"] + , m [ "" , "" ] + ) + , ( m ["abcde" , "01234" ] + , m [ "defgh", "34567"] + , m [ "de" , "34" ] + ) + , ( m ["abcdef" , "012345" ] + , m [ "cdefgh", "234567"] + , m [ "cdef" , "2345" ] + ) + , ( m ["abcdefg" , "0123456" ] + , m [ "bcdefgh", "1234567"] + , m [ "bcdefg" , "123456" ] + ) + , ( m ["abcdefgh", "01234567"] + , m ["abcdefgh", "01234567"] + , m ["abcdefgh", "01234567"] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural :: Spec +exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural = unitTestSpec + "OverlappingGCDMonoid.overlap (Sum Natural)" + "overlap" + (overlap) + (exampleData_OverlappingGCDMonoid_overlap_Sum_Natural) + +exampleData_OverlappingGCDMonoid_overlap_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_OverlappingGCDMonoid_overlap_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String :: Spec +exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String = unitTestSpec + "OverlappingGCDMonoid.stripPrefixOverlap (String)" + "stripPrefixOverlap" + (stripPrefixOverlap) + (exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String) + +exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String = unitTestData2 + [ ( m ["abcd" , "0123" ] + , m [ "efgh", "4567"] + , m [ "efgh", "4567"] + ) + , ( m ["abcde" , "01234" ] + , m [ "defgh", "34567"] + , m [ "fgh", "567"] + ) + , ( m ["abcdef" , "012345" ] + , m [ "cdefgh", "234567"] + , m [ "gh", "67"] + ) + , ( m ["abcdefg" , "0123456" ] + , m [ "bcdefgh", "1234567"] + , m [ "h", "7"] + ) + , ( m ["abcdefgh", "01234567"] + , m ["abcdefgh", "01234567"] + , m [ "", ""] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String :: Spec +exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String = unitTestSpec + "OverlappingGCDMonoid.stripSuffixOverlap (String)" + "stripSuffixOverlap" + (stripSuffixOverlap) + (exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String) + +exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String :: UnitTestData2 + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) + (MonoidMap LatinChar String) +exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String = unitTestData2 + [ ( m [ "efgh", "4567"] + , m ["abcd" , "0123" ] + , m ["abcd" , "0123" ] + ) + , ( m [ "defgh", "34567"] + , m ["abcde" , "01234" ] + , m ["abc" , "012" ] + ) + , ( m [ "cdefgh", "234567"] + , m ["abcdef" , "012345" ] + , m ["ab" , "01" ] + ) + , ( m [ "bcdefgh", "1234567"] + , m ["abcdefg" , "0123456" ] + , m ["a" , "0" ] + ) + , ( m ["abcdefgh", "01234567"] + , m ["abcdefgh", "01234567"] + , m ["" , "" ] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural :: Spec +exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural = unitTestSpec + "OverlappingGCDMonoid.stripPrefixOverlap (Sum Natural)" + "stripPrefixOverlap" + (stripPrefixOverlap) + (exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural) + +exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural + :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [9, 7, 5, 3, 1, 0, 0, 0, 0, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural :: Spec +exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural = unitTestSpec + "OverlappingGCDMonoid.stripSuffixOverlap (Sum Natural)" + "stripSuffixOverlap" + (stripSuffixOverlap) + (exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural) + +exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural + :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [9, 7, 5, 3, 1, 0, 0, 0, 0, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- GCDMonoid +-------------------------------------------------------------------------------- + +exampleSpec_GCDMonoid_gcd_Product_Natural :: Spec +exampleSpec_GCDMonoid_gcd_Product_Natural = unitTestSpec + "GCDMonoid.gcd (Product Natural)" + "gcd" + (gcd) + (exampleData_GCDMonoid_gcd_Product_Natural) + +exampleData_GCDMonoid_gcd_Product_Natural :: UnitTestData2 + (MonoidMap LatinChar (Product Natural)) + (MonoidMap LatinChar (Product Natural)) + (MonoidMap LatinChar (Product Natural)) +exampleData_GCDMonoid_gcd_Product_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [1, 1, 1, 1, 1, 1, 1, 1, 1, 1] + , m [1, 1, 1, 1, 1, 1, 1, 1, 1, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [2, 2, 2, 2, 2, 2, 2, 2, 2, 2] + , m [2, 1, 2, 1, 2, 1, 2, 1, 2, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [3, 3, 3, 3, 3, 3, 3, 3, 3, 3] + , m [3, 1, 1, 3, 1, 1, 3, 1, 1, 3] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [4, 4, 4, 4, 4, 4, 4, 4, 4, 4] + , m [4, 1, 2, 1, 4, 1, 2, 1, 4, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [5, 5, 5, 5, 5, 5, 5, 5, 5, 5] + , m [5, 1, 1, 1, 1, 5, 1, 1, 1, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [6, 6, 6, 6, 6, 6, 6, 6, 6, 6] + , m [6, 1, 2, 3, 2, 1, 6, 1, 2, 3] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [7, 7, 7, 7, 7, 7, 7, 7, 7, 7] + , m [7, 1, 1, 1, 1, 1, 1, 7, 1, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [8, 8, 8, 8, 8, 8, 8, 8, 8, 8] + , m [8, 1, 2, 1, 4, 1, 2, 1, 8, 1] + ) + , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 9, 9, 9, 9, 9, 9, 9, 9, 9] + , m [9, 1, 1, 3, 1, 1, 3, 1, 1, 9] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_GCDMonoid_gcd_Sum_Natural :: Spec +exampleSpec_GCDMonoid_gcd_Sum_Natural = unitTestSpec + "GCDMonoid.gcd (Sum Natural)" + "gcd" + (gcd) + (exampleData_GCDMonoid_gcd_Sum_Natural) + +exampleData_GCDMonoid_gcd_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_GCDMonoid_gcd_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] + ) + , ( m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_GCDMonoid_gcd_Set_Natural :: Spec +exampleSpec_GCDMonoid_gcd_Set_Natural = unitTestSpec + "GCDMonoid.gcd (Set Natural)" + "gcd" + (gcd) + (exampleData_GCDMonoid_gcd_Set_Natural) + +exampleData_GCDMonoid_gcd_Set_Natural :: UnitTestData2 + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) +exampleData_GCDMonoid_gcd_Set_Natural = unitTestData2 + [ ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ ], [ ]] + , m [[ ], [ ]] + ) + , ( m [[ ], [ ]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ ], [ ]] + ) + , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + ) + , ( m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + ) + , ( m [[0, 1, 2 ], [4, 5, 6 ]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[ 1, 2 ], [ 5, 6 ]] + ) + , ( m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2 ], [4, 5, 6 ]] + , m [[ 1, 2 ], [ 5, 6 ]] + ) + , ( m [[0, 1 ], [4, 5 ]] + , m [[ 2, 3], [ 6, 7]] + , m [[ ], [ ]] + ) + , ( m [[ 2, 3], [ 6, 7]] + , m [[0, 1 ], [4, 5 ]] + , m [[ ], [ ]] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList + +-------------------------------------------------------------------------------- +-- LCMMonoid +-------------------------------------------------------------------------------- + +exampleSpec_LCMMonoid_lcm_Product_Natural :: Spec +exampleSpec_LCMMonoid_lcm_Product_Natural = unitTestSpec + "LCMMonoid.lcm (Product Natural)" + "lcm" + (lcm) + (exampleData_LCMMonoid_lcm_Product_Natural) + +exampleData_LCMMonoid_lcm_Product_Natural :: UnitTestData2 + (MonoidMap LatinChar (Product Natural)) + (MonoidMap LatinChar (Product Natural)) + (MonoidMap LatinChar (Product Natural)) +exampleData_LCMMonoid_lcm_Product_Natural = unitTestData2 + [ ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + , m [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1] + , m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2] + , m [ 0, 2, 2, 6, 4, 10, 6, 14, 8, 18] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3] + , m [ 0, 3, 6, 3, 12, 15, 6, 21, 24, 9] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4] + , m [ 0, 4, 4, 12, 4, 20, 12, 28, 8, 36] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5] + , m [ 0, 5, 10, 15, 20, 5, 30, 35, 40, 45] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 6, 6, 6, 6, 6, 6, 6, 6, 6, 6] + , m [ 0, 6, 6, 6, 12, 30, 6, 42, 24, 18] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7] + , m [ 0, 7, 14, 21, 28, 35, 42, 7, 56, 63] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8] + , m [ 0, 8, 8, 24, 8, 40, 24, 56, 8, 72] + ) + , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9] + , m [ 0, 9, 18, 9, 36, 45, 18, 63, 72, 9] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_LCMMonoid_lcm_Sum_Natural :: Spec +exampleSpec_LCMMonoid_lcm_Sum_Natural = unitTestSpec + "LCMMonoid.lcm (Sum Natural)" + "lcm" + (lcm) + (exampleData_LCMMonoid_lcm_Sum_Natural) + +exampleData_LCMMonoid_lcm_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_LCMMonoid_lcm_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [9, 8, 7, 6, 5, 5, 6, 7, 8, 9] + ) + , ( m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] + , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + , m [9, 8, 7, 6, 5, 5, 6, 7, 8, 9] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +exampleSpec_LCMMonoid_lcm_Set_Natural :: Spec +exampleSpec_LCMMonoid_lcm_Set_Natural = unitTestSpec + "LCMMonoid.lcm (Set Natural)" + "lcm" + (lcm) + (exampleData_LCMMonoid_lcm_Set_Natural) + +exampleData_LCMMonoid_lcm_Set_Natural :: UnitTestData2 + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) +exampleData_LCMMonoid_lcm_Set_Natural = unitTestData2 + [ ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ ], [ ]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[ ], [ ]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[0, 1, 2 ], [4, 5, 6 ]] + , m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[ 1, 2, 3], [ 5, 6, 7]] + , m [[0, 1, 2 ], [4, 5, 6 ]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[0, 1 ], [4, 5 ]] + , m [[ 2, 3], [ 6, 7]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + , ( m [[ 2, 3], [ 6, 7]] + , m [[0, 1 ], [4, 5 ]] + , m [[0, 1, 2, 3], [4, 5, 6, 7]] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList + +-------------------------------------------------------------------------------- +-- Monus +-------------------------------------------------------------------------------- + +exampleSpec_Monus_monus_Set_Natural :: Spec +exampleSpec_Monus_monus_Set_Natural = unitTestSpec + "Monus.monus (Set Natural)" + "<\\>" + (<\>) + (exampleData_Monus_monus_Set_Natural) + +exampleData_Monus_monus_Set_Natural :: UnitTestData2 + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) + (MonoidMap LatinChar (Set Natural)) +exampleData_Monus_monus_Set_Natural = unitTestData2 + [ ( m [[0, 1, 2], [3, 4, 5]] + , m [[ ], [ ]] + , m [[0, 1, 2], [3, 4, 5]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[0 ], [3 ]] + , m [[ 1, 2], [ 4, 5]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[ 1 ], [ 4 ]] + , m [[0, 2], [3, 5]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[ 2], [ 5]] + , m [[0, 1 ], [3, 4 ]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[0, 1, 2], [3, 4, 5]] + , m [[ ], [ ]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[3, 4, 5], [0, 1, 2]] + , m [[0, 1, 2], [3, 4, 5]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[2, 3, 4], [1, 2, 3]] + , m [[0, 1 ], [ 4, 5]] + ) + , ( m [[0, 1, 2], [3, 4, 5]] + , m [[1, 2, 3], [2, 3, 4]] + , m [[0 ], [ 5]] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList + +exampleSpec_Monus_monus_Sum_Natural :: Spec +exampleSpec_Monus_monus_Sum_Natural = unitTestSpec + "Monus.monus (Sum Natural)" + "<\\>" + (<\>) + (exampleData_Monus_monus_Sum_Natural) + +exampleData_Monus_monus_Sum_Natural :: UnitTestData2 + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) + (MonoidMap LatinChar (Sum Natural)) +exampleData_Monus_monus_Sum_Natural = unitTestData2 + [ ( m [0, 1, 2, 3] + , m [0, 0, 0, 0] + , m [0, 1, 2, 3] + ) + , ( m [0, 1, 2, 3] + , m [1, 1, 1, 1] + , m [0, 0, 1, 2] + ) + , ( m [0, 1, 2, 3] + , m [2, 2, 2, 2] + , m [0, 0, 0, 1] + ) + , ( m [0, 1, 2, 3] + , m [3, 3, 3, 3] + , m [0, 0, 0, 0] + ) + , ( m [0, 1, 2, 3] + , m [4, 4, 4, 4] + , m [0, 0, 0, 0] + ) + ] + where + m = MonoidMap.fromList . zip [A ..] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +data LatinChar + = A | B | C | D | E | F | G | H | I | J | K | L | M + | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + deriving (Bounded, Enum, Eq, Ord, Show) diff --git a/components/monoidmap-test/Data/MonoidMap/FilterSpec.hs b/components/monoidmap-test/Data/MonoidMap/FilterSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/FilterSpec.hs @@ -0,0 +1,163 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.FilterSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.MonoidMap + ( MonoidMap, nonNullCount ) +import Data.Proxy + ( Proxy (..) ) +import GHC.Exts + ( IsList (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) + +import qualified Data.List as List +import qualified Data.MonoidMap as MonoidMap + +spec :: Spec +spec = describe "Filtering" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_filter_get" $ + prop_filter_get + @k @v & property + it "prop_filter_asList" $ + prop_filter_asList + @k @v & property + it "prop_filterKeys_get" $ + prop_filterKeys_get + @k @v & property + it "prop_filterKeys_asList" $ + prop_filterKeys_asList + @k @v & property + it "prop_filterWithKey_get" $ + prop_filterWithKey_get + @k @v & property + it "prop_filterWithKey_asList" $ + prop_filterWithKey_asList + @k @v & property + +prop_filter_get + :: Test k v => Fun v Bool -> k -> MonoidMap k v -> Property +prop_filter_get (applyFun -> f) k m = + MonoidMap.get k (MonoidMap.filter f m) + === + (MonoidMap.get k m & \v -> if f v then v else mempty) + & cover 2 + (MonoidMap.nullKey k m && f (MonoidMap.get k m)) + "MonoidMap.nullKey k m && f (MonoidMap.get k m)" + & cover 2 + (MonoidMap.nullKey k m && not (f (MonoidMap.get k m))) + "MonoidMap.nullKey k m && not (f (MonoidMap.get k m))" + & cover 2 + (MonoidMap.nonNullKey k m && f (MonoidMap.get k m)) + "MonoidMap.nonNullKey k m && f (MonoidMap.get k m)" + & cover 2 + (MonoidMap.nonNullKey k m && not (f (MonoidMap.get k m))) + "MonoidMap.nonNullKey k m && not (f (MonoidMap.get k m))" + +prop_filter_asList + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +prop_filter_asList (applyFun -> f) m = + n === fromList (List.filter (f . snd) (toList m)) + & cover 2 + (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" + & cover 2 + (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" + where + n = MonoidMap.filter f m + +prop_filterKeys_get + :: Test k v => Fun k Bool -> k -> MonoidMap k v -> Property +prop_filterKeys_get (applyFun -> f) k m = + MonoidMap.get k (MonoidMap.filterKeys f m) + === + (if f k then MonoidMap.get k m else mempty) + & cover 2 + (MonoidMap.nullKey k m && f k) + "MonoidMap.nullKey k m && f k" + & cover 2 + (MonoidMap.nullKey k m && not (f k)) + "MonoidMap.nullKey k m && not (f k)" + & cover 2 + (MonoidMap.nonNullKey k m && f k) + "MonoidMap.nonNullKey k m && f k" + & cover 2 + (MonoidMap.nonNullKey k m && not (f k)) + "MonoidMap.nonNullKey k m && not (f k)" + +prop_filterKeys_asList + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +prop_filterKeys_asList (applyFun -> f) m = + n === MonoidMap.fromList (List.filter (f . fst) (toList m)) + & cover 2 + (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" + & cover 2 + (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" + where + n = MonoidMap.filterKeys f m + +prop_filterWithKey_get + :: Test k v => Fun (k, v) Bool -> k -> MonoidMap k v -> Property +prop_filterWithKey_get (applyFun2 -> f) k m = + MonoidMap.get k (MonoidMap.filterWithKey f m) + === + (MonoidMap.get k m & \v -> if f k v then v else mempty) + & cover 2 + (MonoidMap.nullKey k m && f k (MonoidMap.get k m)) + "MonoidMap.nullKey k m && f k (MonoidMap.get k m)" + & cover 2 + (MonoidMap.nullKey k m && not (f k (MonoidMap.get k m))) + "MonoidMap.nullKey k m && not (f k (MonoidMap.get k m))" + & cover 2 + (MonoidMap.nonNullKey k m && f k (MonoidMap.get k m)) + "MonoidMap.nonNullKey k m && f k (MonoidMap.get k m)" + & cover 2 + (MonoidMap.nonNullKey k m && not (f k (MonoidMap.get k m))) + "MonoidMap.nonNullKey k m && not (f k (MonoidMap.get k m))" + +prop_filterWithKey_asList + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +prop_filterWithKey_asList (applyFun2 -> f) m = + n === MonoidMap.fromList (List.filter (uncurry f) (toList m)) + & cover 2 + (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" + & cover 2 + (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) + "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" + where + n = MonoidMap.filterWithKey f m diff --git a/components/monoidmap-test/Data/MonoidMap/FoldSpec.hs b/components/monoidmap-test/Data/MonoidMap/FoldSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/FoldSpec.hs @@ -0,0 +1,194 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.FoldSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun2, applyFun3, (===) ) + +import qualified Data.Map.Strict as Map +import qualified Data.MonoidMap as MonoidMap + +spec :: Spec +spec = describe "Folding" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + describe "Lazy" $ do + + it "prop_equivalence_foldl" $ + prop_equivalence_foldl + @k @v & property + it "prop_equivalence_foldr" $ + prop_equivalence_foldr + @k @v & property + it "prop_equivalence_foldlWithKey" $ + prop_equivalence_foldlWithKey + @k @v & property + it "prop_equivalence_foldrWithKey" $ + prop_equivalence_foldrWithKey + @k @v & property + it "prop_equivalence_foldMapWithKey" $ + prop_equivalence_foldMapWithKey + @k @v & property + + describe "Strict" $ do + + it "prop_equivalence_foldl'" $ + prop_equivalence_foldl' + @k @v & property + it "prop_equivalence_foldr'" $ + prop_equivalence_foldr' + @k @v & property + it "prop_equivalence_foldlWithKey'" $ + prop_equivalence_foldlWithKey' + @k @v & property + it "prop_equivalence_foldrWithKey'" $ + prop_equivalence_foldrWithKey' + @k @v & property + it "prop_equivalence_foldMapWithKey'" $ + prop_equivalence_foldMapWithKey' + @k @v & property + +-------------------------------------------------------------------------------- +-- Lazy folding +-------------------------------------------------------------------------------- + +prop_equivalence_foldl + :: Test k v + => r ~ v + => Fun (r, v) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldl (applyFun2 -> f) r m = + MonoidMap.foldl f r m + === Map.foldl f r (MonoidMap.toMap m) + +prop_equivalence_foldr + :: Test k v + => r ~ v + => Fun (v, r) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldr (applyFun2 -> f) r m = + MonoidMap.foldr f r m + === Map.foldr f r (MonoidMap.toMap m) + +prop_equivalence_foldlWithKey + :: Test k v + => r ~ v + => Fun (r, k, v) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldlWithKey (applyFun3 -> f) r m = + MonoidMap.foldlWithKey f r m + === Map.foldlWithKey f r (MonoidMap.toMap m) + +prop_equivalence_foldrWithKey + :: Test k v + => r ~ v + => Fun (k, v, r) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldrWithKey (applyFun3 -> f) r m = + MonoidMap.foldrWithKey f r m + === Map.foldrWithKey f r (MonoidMap.toMap m) + +prop_equivalence_foldMapWithKey + :: Test k v + => r ~ v + => Fun (k, v) r + -> MonoidMap k v + -> Property +prop_equivalence_foldMapWithKey (applyFun2 -> f) m = + MonoidMap.foldMapWithKey f m + === Map.foldMapWithKey f (MonoidMap.toMap m) + +-------------------------------------------------------------------------------- +-- Strict folding +-------------------------------------------------------------------------------- + +prop_equivalence_foldl' + :: Test k v + => r ~ v + => Fun (r, v) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldl' (applyFun2 -> f) r m = + MonoidMap.foldl' f r m === + MonoidMap.foldl f r m + +prop_equivalence_foldr' + :: Test k v + => r ~ v + => Fun (v, r) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldr' (applyFun2 -> f) r m = + MonoidMap.foldr' f r m === + MonoidMap.foldr f r m + +prop_equivalence_foldlWithKey' + :: Test k v + => r ~ v + => Fun (r, k, v) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldlWithKey' (applyFun3 -> f) r m = + MonoidMap.foldlWithKey' f r m === + MonoidMap.foldlWithKey f r m + +prop_equivalence_foldrWithKey' + :: Test k v + => r ~ v + => Fun (k, v, r) r + -> r + -> MonoidMap k v + -> Property +prop_equivalence_foldrWithKey' (applyFun3 -> f) r m = + MonoidMap.foldrWithKey' f r m === + MonoidMap.foldrWithKey f r m + +prop_equivalence_foldMapWithKey' + :: Test k v + => r ~ v + => Fun (k, v) r + -> MonoidMap k v + -> Property +prop_equivalence_foldMapWithKey' (applyFun2 -> f) m = + MonoidMap.foldMapWithKey' f m === + MonoidMap.foldMapWithKey f m diff --git a/components/monoidmap-test/Data/MonoidMap/IntersectionSpec.hs b/components/monoidmap-test/Data/MonoidMap/IntersectionSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/IntersectionSpec.hs @@ -0,0 +1,193 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.IntersectionSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Functor.Identity + ( Identity (..) ) +import Data.Monoid.Cancellative + ( GCDMonoid ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesGCDMonoid + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun2, conjoin, cover, expectFailure, (===) ) + +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Intersection" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specMonoidNull + (Proxy @Key) p + forM_ testValueTypesGCDMonoid $ + \(TestValueType p) -> specGCDMonoid + (Proxy @Key) p + +specMonoidNull :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specMonoidNull = makeSpec $ do + it "prop_intersectionWith_get" $ + prop_intersectionWith_get + @k @v & property + it "prop_intersectionWith_get_total" $ + prop_intersectionWith_get_total + @k @v & property + it "prop_intersectionWith_get_total_failure" $ + prop_intersectionWith_get_total_failure + @k @v & property + it "prop_intersectionWith_intersectionWithA" $ + prop_intersectionWith_intersectionWithA + @k @v & property + +specGCDMonoid + :: forall k v. (Test k v, GCDMonoid v) => Proxy k -> Proxy v -> Spec +specGCDMonoid = makeSpec $ do + it "prop_intersection_isSubmapOf" $ + prop_intersection_isSubmapOf + @k @v & property + +prop_intersection_isSubmapOf + :: (Test k v, GCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_intersection_isSubmapOf m1 m2 = conjoin + [ intersection_m1_m2 `MonoidMap.isSubmapOf` m1 + , intersection_m1_m2 `MonoidMap.isSubmapOf` m2 + ] + & cover 2 + (m1 /= m2 && MonoidMap.nonNull (intersection_m1_m2)) + "m1 /= m2 && MonoidMap.nonNull (intersection_m1_m2)" + where + intersection_m1_m2 = MonoidMap.intersection m1 m2 + +prop_intersectionWith_get + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_intersectionWith_get (applyFun2 -> f) m1 m2 k = + (MonoidMap.get k result + === + if keyWithinIntersection + then f (MonoidMap.get k m1) (MonoidMap.get k m2) + else mempty) + & cover 2 + (keyWithinIntersection) + "keyWithinIntersection" + & cover 2 + (not keyWithinIntersection) + "not keyWithinIntersection" + & cover 2 + (MonoidMap.null result) + "MonoidMap.null result" + & cover 2 + (MonoidMap.nonNull result) + "MonoidMap.nonNull result" + & cover 2 + (MonoidMap.nullKey k result) + "MonoidMap.nullKey k result" + & cover 2 + (MonoidMap.nonNullKey k result) + "MonoidMap.nonNullKey k result" + where + keyWithinIntersection = + k `Set.member` Set.intersection + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + result = + MonoidMap.intersectionWith f m1 m2 + +prop_intersectionWith_get_total + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_intersectionWith_get_total (applyFun2 -> f0) m1 m2 k = + (MonoidMap.get k result + === + f (MonoidMap.get k m1) (MonoidMap.get k m2)) + & cover 2 + (keyWithinIntersection) + "keyWithinIntersection" + & cover 2 + (not keyWithinIntersection) + "not keyWithinIntersection" + & cover 2 + (MonoidMap.null result) + "MonoidMap.null result" + & cover 2 + (MonoidMap.nonNull result) + "MonoidMap.nonNull result" + & cover 2 + (MonoidMap.nullKey k result) + "MonoidMap.nullKey k result" + & cover 2 + (MonoidMap.nonNullKey k result) + "MonoidMap.nonNullKey k result" + where + result = + MonoidMap.intersectionWith f m1 m2 + keyWithinIntersection = + k `Set.member` Set.intersection + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + f v1 v2 + | Null.null v1 = mempty + | Null.null v2 = mempty + | otherwise = f0 v1 v2 + +prop_intersectionWith_get_total_failure + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_intersectionWith_get_total_failure (applyFun2 -> f) m1 m2 k = + expectFailure $ + MonoidMap.get k (MonoidMap.intersectionWith f m1 m2) + === + f (MonoidMap.get k m1) (MonoidMap.get k m2) + +prop_intersectionWith_intersectionWithA + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> Property +prop_intersectionWith_intersectionWithA (applyFun2 -> f) m1 m2 = + runIdentity (MonoidMap.intersectionWithA ((fmap . fmap) Identity f) m1 m2) + === (MonoidMap.intersectionWith f m1 m2) diff --git a/components/monoidmap-test/Data/MonoidMap/MapSpec.hs b/components/monoidmap-test/Data/MonoidMap/MapSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/MapSpec.hs @@ -0,0 +1,300 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.MapSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Bifunctor + ( first, second ) +import Data.Function + ( (&) ) +import Data.Monoid.Null + ( MonoidNull ) +import Data.MonoidMap + ( MonoidMap, nonNullCount ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun, applyFun2, cover, expectFailure, (===) ) + +import qualified Data.Foldable as F +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Mapping" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_map_asList" $ + prop_map_asList + @k @v & property + it "prop_map_composition" $ + prop_map_composition + @k @v & property + it "prop_map_composition_failure" $ + prop_map_composition_failure + @k @v & property + it "prop_map_get" $ + prop_map_get + @k @v & property + it "prop_map_get_total" $ + prop_map_get_total + @k @v & property + it "prop_map_get_total_failure" $ + prop_map_get_total_failure + @k @v & property + it "prop_mapKeys_asList" $ + prop_mapKeys_asList + @k @v & property + it "prop_mapKeys_get" $ + prop_mapKeys_get + @k @v & property + it "prop_mapKeysWith_asList" $ + prop_mapKeysWith_asList + @k @v & property + it "prop_mapWithKey_asList" $ + prop_mapWithKey_asList + @k @v & property + it "prop_mapWithKey_get" $ + prop_mapWithKey_get + @k @v & property + it "prop_mapWithKey_get_total" $ + prop_mapWithKey_get_total + @k @v & property + it "prop_mapWithKey_get_total_failure" $ + prop_mapWithKey_get_total_failure + @k @v & property + +-------------------------------------------------------------------------------- +-- Mapping +-------------------------------------------------------------------------------- + +prop_map_asList + :: Test k v + => Fun v v + -> MonoidMap k v + -> Property +prop_map_asList (applyFun -> f) m = + n === (MonoidMap.fromList . fmap (second f) . MonoidMap.toList $ m) + & cover 2 + (0 < nonNullCount n && nonNullCount n < nonNullCount m) + "0 < nonNullCount n && nonNullCount n < nonNullCount m" + where + n = MonoidMap.map f m + +prop_map_composition + :: forall k v. Test k v + => Fun v v + -> Fun v v + -> MonoidMap k v + -> Property +prop_map_composition (applyFun -> f0) (applyFun -> g0) m = + MonoidMap.map (f . g) m === MonoidMap.map f (MonoidMap.map g m) + & cover 2 + (MonoidMap.nonNull m) + "MonoidMap.nonNull m" + where + f = toNullPreservingFn f0 + g = g0 + +prop_map_composition_failure + :: forall k v. Test k v + => Fun v v + -> Fun v v + -> MonoidMap k v + -> Property +prop_map_composition_failure (applyFun -> f) (applyFun -> g) m = + expectFailure $ + MonoidMap.map (f . g) m === MonoidMap.map f (MonoidMap.map g m) + & cover 1 + (MonoidMap.map (f . g) m /= MonoidMap.map f (MonoidMap.map g m)) + "MonoidMap.map (f . g) m /= MonoidMap.map f (MonoidMap.map g m)" + +prop_map_get + :: Test k v + => Fun v v + -> k + -> MonoidMap k v + -> Property +prop_map_get (applyFun -> f) k m = + MonoidMap.get k (MonoidMap.map f m) + === + (if MonoidMap.nullKey k m then mempty else f (MonoidMap.get k m)) + & cover 2 + (MonoidMap.nullKey k m) + "MonoidMap.nullKey k m" + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + +prop_map_get_total + :: forall k v. Test k v + => Fun v v + -> k + -> MonoidMap k v + -> Property +prop_map_get_total (applyFun -> f0) k m = + MonoidMap.get k (MonoidMap.map f m) === f (MonoidMap.get k m) + & cover 2 + (MonoidMap.nullKey k m) + "MonoidMap.nullKey k m" + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + where + f = toNullPreservingFn f0 + +prop_map_get_total_failure + :: Test k v + => Fun v v + -> k + -> MonoidMap k v + -> Property +prop_map_get_total_failure (applyFun -> f) k m = + expectFailure $ + MonoidMap.get k (MonoidMap.map f m) === f (MonoidMap.get k m) + +prop_mapKeys_asList + :: Test k v + => Fun k k + -> MonoidMap k v + -> Property +prop_mapKeys_asList (applyFun -> f) m = + n === (MonoidMap.fromList . fmap (first f) . MonoidMap.toList $ m) + & cover 2 + (0 < nonNullCount n && nonNullCount n < nonNullCount m) + "0 < nonNullCount n && nonNullCount n < nonNullCount m" + where + n = MonoidMap.mapKeys f m + +prop_mapKeys_get + :: Test k v + => Fun k k + -> k + -> MonoidMap k v + -> Property +prop_mapKeys_get (applyFun -> f) k m = + MonoidMap.get k (MonoidMap.mapKeys f m) + === + F.foldMap + (`MonoidMap.get` m) + (Set.filter ((==) k . f) (MonoidMap.nonNullKeys m)) + & cover 2 + (MonoidMap.nullKey k (MonoidMap.mapKeys f m)) + "MonoidMap.nullKey k (MonoidMap.mapKeys f m)" + & cover 2 + (MonoidMap.nonNullKey k (MonoidMap.mapKeys f m)) + "MonoidMap.nonNullKey k (MonoidMap.mapKeys f m)" + +prop_mapKeysWith_asList + :: Test k v + => Fun (v, v) v + -> Fun k k + -> MonoidMap k v + -> Property +prop_mapKeysWith_asList (applyFun2 -> c) (applyFun -> f) m = + n === (MonoidMap.fromListWith c . fmap (first f) . MonoidMap.toList $ m) + & cover 2 + (0 < nonNullCount n && nonNullCount n < nonNullCount m) + "0 < nonNullCount n && nonNullCount n < nonNullCount m" + where + n = MonoidMap.mapKeysWith c f m + +prop_mapWithKey_asList + :: Test k v + => Fun (k, v) v + -> MonoidMap k v + -> Property +prop_mapWithKey_asList (applyFun2 -> f) m = + n === + ( MonoidMap.fromList + . fmap (\(k, v) -> (k, (f k v))) + . MonoidMap.toList + $ m + ) + & cover 2 + (0 < nonNullCount n && nonNullCount n < nonNullCount m) + "0 < nonNullCount n && nonNullCount n < nonNullCount m" + where + n = MonoidMap.mapWithKey f m + +prop_mapWithKey_get + :: Test k v + => Fun (k, v) v + -> k + -> MonoidMap k v + -> Property +prop_mapWithKey_get (applyFun2 -> f) k m = + MonoidMap.get k (MonoidMap.mapWithKey f m) + === + (if MonoidMap.nullKey k m then mempty else f k (MonoidMap.get k m)) + & cover 2 + (MonoidMap.nullKey k m) + "MonoidMap.nullKey k m" + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + +prop_mapWithKey_get_total + :: forall k v. Test k v + => Fun (k, v) v + -> k + -> MonoidMap k v + -> Property +prop_mapWithKey_get_total (applyFun2 -> f0) k m = + MonoidMap.get k (MonoidMap.mapWithKey f m) === f k (MonoidMap.get k m) + & cover 2 + (MonoidMap.nullKey k m) + "MonoidMap.nullKey k m" + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + where + f = toNullPreservingFn . f0 + +prop_mapWithKey_get_total_failure + :: Test k v + => Fun (k, v) v + -> k + -> MonoidMap k v + -> Property +prop_mapWithKey_get_total_failure (applyFun2 -> f) k m = + expectFailure $ + MonoidMap.get k (MonoidMap.mapWithKey f m) === f k (MonoidMap.get k m) + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Creates a function that never maps null values to non-null values. +-- +toNullPreservingFn :: MonoidNull v => (v -> v) -> (v -> v) +toNullPreservingFn f v + | Null.null v = v + | otherwise = f v diff --git a/components/monoidmap-test/Data/MonoidMap/MembershipSpec.hs b/components/monoidmap-test/Data/MonoidMap/MembershipSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/MembershipSpec.hs @@ -0,0 +1,106 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.MembershipSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Property, cover, (===) ) + +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Membership" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_nullify_get" $ + prop_nullify_get + @k @v & property + it "prop_nullify_nonNullKey" $ + prop_nullify_nonNullKey + @k @v & property + it "prop_nullify_nonNullKeys" $ + prop_nullify_nonNullKeys + @k @v & property + it "prop_nonNullKeys_get" $ + prop_nonNullKeys_get + @k @v & property + +prop_nullify_get + :: Test k v => MonoidMap k v -> k -> Property +prop_nullify_get m k = + MonoidMap.get k (MonoidMap.nullify k m) === mempty + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +prop_nullify_nonNullKey + :: Test k v => MonoidMap k v -> k -> Property +prop_nullify_nonNullKey m k = + MonoidMap.nonNullKey k (MonoidMap.nullify k m) === False + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +prop_nullify_nonNullKeys + :: Test k v => MonoidMap k v -> k -> Property +prop_nullify_nonNullKeys m k = + Set.member k (MonoidMap.nonNullKeys (MonoidMap.nullify k m)) === False + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + & cover 2 + (not (MonoidMap.nonNullKey k m)) + "not (MonoidMap.nonNullKey k m)" + +prop_nonNullKeys_get + :: Test k v => MonoidMap k v -> Property +prop_nonNullKeys_get m = + fmap + (\k -> (k, MonoidMap.get k m)) + (Set.toList (MonoidMap.nonNullKeys m)) + === MonoidMap.toList m + & cover 2 + (MonoidMap.null m) + "MonoidMap.null m" + & cover 2 + (not (MonoidMap.null m)) + "not (MonoidMap.null m)" diff --git a/components/monoidmap-test/Data/MonoidMap/PartitionSpec.hs b/components/monoidmap-test/Data/MonoidMap/PartitionSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/PartitionSpec.hs @@ -0,0 +1,173 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.PartitionSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) + +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Partitioning" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_partition_filter" $ + prop_partition_filter + @k @v & property + it "prop_partition_append" $ + prop_partition_append + @k @v & property + it "prop_partition_disjoint" $ + prop_partition_disjoint + @k @v & property + it "prop_partitionKeys_filterKeys" $ + prop_partitionKeys_filterKeys + @k @v & property + it "prop_partitionKeys_append" $ + prop_partitionKeys_append + @k @v & property + it "prop_partitionKeys_disjoint" $ + prop_partitionKeys_disjoint + @k @v & property + it "prop_partitionWithKey_filterWithKey" $ + prop_partitionWithKey_filterWithKey + @k @v & property + it "prop_partitionWithKey_append" $ + prop_partitionWithKey_append + @k @v & property + it "prop_partitionWithKey_disjoint" $ + prop_partitionWithKey_disjoint + @k @v & property + +prop_partition_filter + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +prop_partition_filter (applyFun -> f) m = + MonoidMap.partition f m === (m1, m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + m1 = MonoidMap.filter f m + m2 = MonoidMap.filter (not . f) m + +prop_partition_append + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +prop_partition_append (applyFun -> f) m = + m1 <> m2 === m + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partition f m + +prop_partition_disjoint + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +prop_partition_disjoint (applyFun -> f) m = + Set.disjoint + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partition f m + +prop_partitionKeys_filterKeys + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +prop_partitionKeys_filterKeys (applyFun -> f) m = + MonoidMap.partitionKeys f m === (m1, m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + m1 = MonoidMap.filterKeys f m + m2 = MonoidMap.filterKeys (not . f) m + +prop_partitionKeys_append + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +prop_partitionKeys_append (applyFun -> f) m = + m1 <> m2 === m + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partitionKeys f m + +prop_partitionKeys_disjoint + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +prop_partitionKeys_disjoint (applyFun -> f) m = + Set.disjoint + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partitionKeys f m + +prop_partitionWithKey_filterWithKey + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +prop_partitionWithKey_filterWithKey (applyFun2 -> f) m = + MonoidMap.partitionWithKey f m === (m1, m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + m1 = MonoidMap.filterWithKey f m + m2 = MonoidMap.filterWithKey ((fmap . fmap) not f) m + +prop_partitionWithKey_append + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +prop_partitionWithKey_append (applyFun2 -> f) m = + m1 <> m2 === m + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partitionWithKey f m + +prop_partitionWithKey_disjoint + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +prop_partitionWithKey_disjoint (applyFun2 -> f) m = + Set.disjoint + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + & cover 2 + (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) + "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" + where + (m1, m2) = MonoidMap.partitionWithKey f m diff --git a/components/monoidmap-test/Data/MonoidMap/PrefixSpec.hs b/components/monoidmap-test/Data/MonoidMap/PrefixSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/PrefixSpec.hs @@ -0,0 +1,80 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.PrefixSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Data.Semigroup.Cancellative + ( LeftReductive (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesLeftReductive + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Property, cover, (===) ) + +import qualified Test.QuickCheck as QC + +spec :: Spec +spec = describe "Prefixes" $ do + + forM_ testValueTypesLeftReductive $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor + :: forall k v. (Test k v, LeftReductive v) => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + it "prop_stripPrefix_isJust" $ + prop_stripPrefix_isJust + @k @v & property + it "prop_stripPrefix_mappend" $ + prop_stripPrefix_mappend + @k @v & property + +prop_stripPrefix_isJust + :: (Test k v, LeftReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_stripPrefix_isJust m1 m2 = + isJust (stripPrefix m1 m2) === m1 `isPrefixOf` m2 + & cover 1 + (m1 `isPrefixOf` m2) + "m1 `isPrefixOf` m2" + +prop_stripPrefix_mappend + :: (Test k v, LeftReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_stripPrefix_mappend m1 m2 = QC.property $ + all + (\r -> m1 <> r == m2) + (stripPrefix m1 m2) + & cover 1 + (isJust (stripPrefix m1 m2)) + "isJust (stripPrefix m1 m2)" diff --git a/components/monoidmap-test/Data/MonoidMap/SingletonSpec.hs b/components/monoidmap-test/Data/MonoidMap/SingletonSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/SingletonSpec.hs @@ -0,0 +1,148 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.SingletonSpec + ( spec + ) where + +import Prelude + +import Data.Function + ( (&) ) +import Data.MonoidMap + ( nonNullCount ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Property, cover, (===) ) + +import Control.Monad + ( forM_ ) +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Singletons" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_singleton_get" $ + prop_singleton_get + @k @v & property + it "prop_singleton_nonNullKey" $ + prop_singleton_nonNullKey + @k @v & property + it "prop_singleton_nonNullKeys" $ + prop_singleton_nonNullKeys + @k @v & property + it "prop_singleton_null" $ + prop_singleton_null + @k @v & property + it "prop_singleton_nullify" $ + prop_singleton_nullify + @k @v & property + it "prop_singleton_nonNullCount" $ + prop_singleton_nonNullCount + @k @v & property + it "prop_singleton_toList" $ + prop_singleton_toList + @k @v & property + +prop_singleton_get + :: Test k v => k -> v -> Property +prop_singleton_get k v = + MonoidMap.get k (MonoidMap.singleton k v) === v + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_nonNullKey + :: Test k v => k -> v -> Property +prop_singleton_nonNullKey k v = + MonoidMap.nonNullKey k (MonoidMap.singleton k v) === (v /= mempty) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_nonNullKeys + :: Test k v => k -> v -> Property +prop_singleton_nonNullKeys k v = + MonoidMap.nonNullKeys (MonoidMap.singleton k v) === + (if v == mempty then Set.empty else Set.singleton k) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_null + :: Test k v => k -> v -> Property +prop_singleton_null k v = + MonoidMap.null (MonoidMap.singleton k v) === (v == mempty) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_nullify + :: Test k v => k -> v -> Property +prop_singleton_nullify k v = + MonoidMap.nullify k (MonoidMap.singleton k v) === mempty + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_nonNullCount + :: Test k v => k -> v -> Property +prop_singleton_nonNullCount k v = + nonNullCount (MonoidMap.singleton k v) === + (if v == mempty then 0 else 1) + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" + +prop_singleton_toList + :: Test k v => k -> v -> Property +prop_singleton_toList k v = + MonoidMap.toList (MonoidMap.singleton k v) === + [(k, v) | v /= mempty] + & cover 2 + (v == mempty) + "v == mempty" + & cover 2 + (v /= mempty) + "v /= mempty" diff --git a/components/monoidmap-test/Data/MonoidMap/SliceSpec.hs b/components/monoidmap-test/Data/MonoidMap/SliceSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/SliceSpec.hs @@ -0,0 +1,139 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.SliceSpec + ( spec + , Slice (..) + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Bifunctor + ( Bifunctor (bimap) ) +import Data.Function + ( (&) ) +import Data.Monoid.Null + ( MonoidNull ) +import Data.MonoidMap + ( MonoidMap, nonNullCount ) +import Data.Proxy + ( Proxy (..) ) +import GHC.Exts + ( IsList (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..), Gen, Property, choose, cover, oneof, (===) ) + +import qualified Data.MonoidMap as MonoidMap + +spec :: Spec +spec = describe "Slicing" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + + it "prop_take_toList_fromList" $ + prop_take_toList_fromList + @k @v & property + it "prop_drop_toList_fromList" $ + prop_drop_toList_fromList + @k @v & property + it "prop_splitAt_toList_fromList" $ + prop_splitAt_toList_fromList + @k @v & property + +data Slice k v = Slice Int (MonoidMap k v) + deriving (Eq, Show) + +instance (Arbitrary k, Arbitrary v, MonoidNull v, Ord k) => + Arbitrary (Slice k v) + where + arbitrary = do + m <- genMap + i <- genIndex m + pure $ Slice i m + where + genMap :: Gen (MonoidMap k v) + genMap = arbitrary + + genIndex :: MonoidMap k v -> Gen Int + genIndex m = oneof + [ choose (negate (length m), -1) + , pure 0 + , choose (1, length m - 1) + , pure (length m) + , choose (length m + 1, 2 * length m) + ] + +prop_take_toList_fromList + :: Test k v => Slice k v -> Property +prop_take_toList_fromList (Slice i m) = + MonoidMap.take i m + === (fromList . Prelude.take i . toList) m + & cover 2 + (i == 0 && 0 < nonNullCount m) + "i == 0 && 0 < nonNullCount m" + & cover 2 + (0 < i && i < nonNullCount m) + "0 < i && i < nonNullCount m" + & cover 2 + (0 < nonNullCount m && nonNullCount m == i) + "0 < nonNullCount m && nonNullCount m == i" + & cover 2 + (0 < nonNullCount m && nonNullCount m < i) + "0 < nonNullCount m && nonNullCount m < i" + +prop_drop_toList_fromList + :: Test k v => Slice k v -> Property +prop_drop_toList_fromList (Slice i m) = + MonoidMap.drop i m + === (fromList . Prelude.drop i . toList) m + & cover 2 + (i == 0 && 0 < nonNullCount m) + "i == 0 && 0 < nonNullCount m" + & cover 2 + (0 < i && i < nonNullCount m) + "0 < i && i < nonNullCount m" + & cover 2 + (0 < nonNullCount m && nonNullCount m == i) + "0 < nonNullCount m && nonNullCount m == i" + & cover 2 + (0 < nonNullCount m && nonNullCount m < i) + "0 < nonNullCount m && nonNullCount m < i" + +prop_splitAt_toList_fromList + :: Test k v => Slice k v -> Property +prop_splitAt_toList_fromList (Slice i m) = + MonoidMap.splitAt i m + === (bimap fromList fromList . Prelude.splitAt i . toList) m + & cover 2 + (i == 0 && 0 < nonNullCount m) + "i == 0 && 0 < nonNullCount m" + & cover 2 + (0 < i && i < nonNullCount m) + "0 < i && i < nonNullCount m" + & cover 2 + (0 < nonNullCount m && nonNullCount m == i) + "0 < nonNullCount m && nonNullCount m == i" + & cover 2 + (0 < nonNullCount m && nonNullCount m < i) + "0 < nonNullCount m && nonNullCount m < i" diff --git a/components/monoidmap-test/Data/MonoidMap/SuffixSpec.hs b/components/monoidmap-test/Data/MonoidMap/SuffixSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/SuffixSpec.hs @@ -0,0 +1,80 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.SuffixSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Data.Semigroup.Cancellative + ( RightReductive (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesRightReductive + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Property, cover, (===) ) + +import qualified Test.QuickCheck as QC + +spec :: Spec +spec = describe "Suffixes" $ do + + forM_ testValueTypesRightReductive $ + \(TestValueType p) -> specFor (Proxy @Key) p + +specFor + :: forall k v. (Test k v, RightReductive v) => Proxy k -> Proxy v -> Spec +specFor = makeSpec $ do + it "prop_stripSuffix_isJust" $ + prop_stripSuffix_isJust + @k @v & property + it "prop_stripSuffix_mappend" $ + prop_stripSuffix_mappend + @k @v & property + +prop_stripSuffix_isJust + :: (Test k v, RightReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_stripSuffix_isJust m1 m2 = + isJust (stripSuffix m1 m2) === m1 `isSuffixOf` m2 + & cover 1 + (m1 `isSuffixOf` m2) + "m1 `isSuffixOf` m2" + +prop_stripSuffix_mappend + :: (Test k v, RightReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_stripSuffix_mappend m1 m2 = QC.property $ + all + (\r -> r <> m1 == m2) + (stripSuffix m1 m2) + & cover 1 + (isJust (stripSuffix m1 m2)) + "isJust (stripSuffix m1 m2)" diff --git a/components/monoidmap-test/Data/MonoidMap/TraversalSpec.hs b/components/monoidmap-test/Data/MonoidMap/TraversalSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/TraversalSpec.hs @@ -0,0 +1,191 @@ +{-# 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 + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesAll + ) +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_ testValueTypesAll $ + \(TestValueType 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/components/monoidmap-test/Data/MonoidMap/UnionSpec.hs b/components/monoidmap-test/Data/MonoidMap/UnionSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/UnionSpec.hs @@ -0,0 +1,192 @@ +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.UnionSpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Function + ( (&) ) +import Data.Functor.Identity + ( Identity (..) ) +import Data.Monoid.LCM + ( LCMMonoid ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (..) ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesLCMMonoid + , testValueTypesAll + ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Fun (..), Property, applyFun2, conjoin, cover, expectFailure, (===) ) + +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Union" $ do + + forM_ testValueTypesAll $ + \(TestValueType p) -> specMonoidNull + (Proxy @Key) p + forM_ testValueTypesLCMMonoid $ + \(TestValueType p) -> specLCMMonoid + (Proxy @Key) p + +specMonoidNull :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specMonoidNull = makeSpec $ do + it "prop_unionWith_get" $ + prop_unionWith_get + @k @v & property + it "prop_unionWith_get_total" $ + prop_unionWith_get_total + @k @v & property + it "prop_unionWith_get_total_failure" $ + prop_unionWith_get_total_failure + @k @v & property + it "prop_unionWith_unionWithA" $ + prop_unionWith_unionWithA + @k @v & property + +specLCMMonoid + :: forall k v. (Test k v, LCMMonoid v) => Proxy k -> Proxy v -> Spec +specLCMMonoid = makeSpec $ do + it "prop_union_isSubmapOf" $ + prop_union_isSubmapOf + @k @v & property + +prop_union_isSubmapOf + :: (Test k v, LCMMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +prop_union_isSubmapOf m1 m2 = conjoin + [ m1 `MonoidMap.isSubmapOf` union_m1_m2 + , m2 `MonoidMap.isSubmapOf` union_m1_m2 + ] + & cover 2 + (m1 /= m2 && MonoidMap.nonNull (union_m1_m2)) + "m1 /= m2 && MonoidMap.nonNull (union_m1_m2)" + where + union_m1_m2 = MonoidMap.union m1 m2 + +prop_unionWith_get + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_unionWith_get (applyFun2 -> f) m1 m2 k = + (MonoidMap.get k result + === + if keyWithinUnion + then f (MonoidMap.get k m1) (MonoidMap.get k m2) + else mempty) + & cover 2 + (keyWithinUnion) + "keyWithinUnion" + & cover 2 + (not keyWithinUnion) + "not keyWithinUnion" + & cover 2 + (MonoidMap.null result) + "MonoidMap.null result" + & cover 2 + (MonoidMap.nonNull result) + "MonoidMap.nonNull result)" + & cover 2 + (MonoidMap.nullKey k result) + "MonoidMap.nullKey k result" + & cover 2 + (MonoidMap.nonNullKey k result) + "MonoidMap.nonNullKey k result" + where + keyWithinUnion = + k `Set.member` Set.union + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + result = + MonoidMap.unionWith f m1 m2 + +prop_unionWith_get_total + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_unionWith_get_total (applyFun2 -> f0) m1 m2 k = + (MonoidMap.get k result + === + f (MonoidMap.get k m1) (MonoidMap.get k m2)) + & cover 2 + (keyWithinUnion) + "keyWithinUnion" + & cover 2 + (not keyWithinUnion) + "not keyWithinUnion" + & cover 2 + (MonoidMap.null result) + "MonoidMap.null result" + & cover 2 + (MonoidMap.nonNull result) + "MonoidMap.nonNull result)" + & cover 2 + (MonoidMap.nullKey k result) + "MonoidMap.nullKey k result" + & cover 2 + (MonoidMap.nonNullKey k result) + "MonoidMap.nonNullKey k result" + where + keyWithinUnion = + k `Set.member` Set.union + (MonoidMap.nonNullKeys m1) + (MonoidMap.nonNullKeys m2) + result = + MonoidMap.unionWith f m1 m2 + f v1 v2 + | Null.null v1 && Null.null v2 = mempty + | otherwise = f0 v1 v2 + +prop_unionWith_get_total_failure + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> k + -> Property +prop_unionWith_get_total_failure (applyFun2 -> f) m1 m2 k = + expectFailure $ + MonoidMap.get k (MonoidMap.unionWith f m1 m2) + === + f (MonoidMap.get k m1) (MonoidMap.get k m2) + +prop_unionWith_unionWithA + :: Test k v + => Fun (v, v) v + -> MonoidMap k v + -> MonoidMap k v + -> Property +prop_unionWith_unionWithA (applyFun2 -> f) m1 m2 = + runIdentity (MonoidMap.unionWithA ((fmap . fmap) Identity f) m1 m2) + === (MonoidMap.unionWith f m1 m2) diff --git a/components/monoidmap-test/Data/MonoidMap/ValiditySpec.hs b/components/monoidmap-test/Data/MonoidMap/ValiditySpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Data/MonoidMap/ValiditySpec.hs @@ -0,0 +1,734 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap.ValiditySpec + ( spec + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Data + ( Proxy (Proxy) ) +import Data.Function + ( (&) ) +import Data.Functor.Identity + ( Identity ) +import Data.Group + ( Group ) +import Data.Map.Strict + ( Map ) +import Data.Maybe + ( isJust ) +import Data.Monoid.Cancellative + ( GCDMonoid + , LeftGCDMonoid + , LeftReductive + , OverlappingGCDMonoid + , Reductive + , RightGCDMonoid + , RightReductive + ) +import Data.Monoid.LCM + ( LCMMonoid ) +import Data.Monoid.Monus + ( Monus ) +import Data.MonoidMap + ( MonoidMap ) +import Data.MonoidMap.SliceSpec + ( Slice (..) ) +import Data.Set + ( Set ) +import Test.Common + ( Key + , Test + , TestValueType (TestValueType) + , makeSpec + , property + , testValueTypesGCDMonoid + , testValueTypesGroup + , testValueTypesLCMMonoid + , testValueTypesLeftGCDMonoid + , testValueTypesLeftReductive + , testValueTypesAll + , testValueTypesMonus + , testValueTypesOverlappingGCDMonoid + , testValueTypesReductive + , testValueTypesRightGCDMonoid + , testValueTypesRightReductive + ) +import Test.Hspec + ( Spec, it ) +import Test.QuickCheck + ( Fun + , Property + , applyFun + , applyFun2 + , applyFun3 + , conjoin + , counterexample + , cover + ) + +import qualified Data.Foldable as F +import qualified Data.Map.Strict as Map +import qualified Data.Monoid.Null as Null +import qualified Data.MonoidMap as MonoidMap + +spec :: Spec +spec = do + specForAll + testValueTypesAll + specValidMonoidNull + specForAll + testValueTypesLeftReductive + specValidLeftReductive + specForAll + testValueTypesRightReductive + specValidRightReductive + specForAll + testValueTypesReductive + specValidReductive + specForAll + testValueTypesLeftGCDMonoid + specValidLeftGCDMonoid + specForAll + testValueTypesRightGCDMonoid + specValidRightGCDMonoid + specForAll + testValueTypesOverlappingGCDMonoid + specValidOverlappingGCDMonoid + specForAll + testValueTypesGCDMonoid + specValidGCDMonoid + specForAll + testValueTypesLCMMonoid + specValidLCMMonoid + specForAll + testValueTypesMonus + specValidMonus + specForAll + testValueTypesGroup + specValidGroup + where + specForAll + :: [TestValueType c] + -> (forall k v. (Test k v, c v) => Proxy k -> Proxy v -> Spec) + -> Spec + specForAll testValueTypes specFn = forM_ testValueTypes (specFor specFn) + + specFor + :: (forall k v. (Test k v, c v) => Proxy k -> Proxy v -> Spec) + -> TestValueType c + -> Spec + specFor specFn (TestValueType (v :: Proxy v)) = + specFn (Proxy @Key) v + +specValidMonoidNull + :: forall k v. Test k v => Proxy k -> Proxy v -> Spec +specValidMonoidNull = makeSpec $ do + it "propValid_fromList" $ + propValid_fromList + @k @v & property + it "propValid_fromListWith" $ + propValid_fromListWith + @k @v & property + it "propValid_fromMap" $ + propValid_fromMap + @k @v & property + it "propValid_fromSet" $ + propValid_fromSet + @k @v & property + it "propValid_singleton" $ + propValid_singleton + @k @v & property + it "propValid_set" $ + propValid_set + @k @v & property + it "propValid_adjust" $ + propValid_adjust + @k @v & property + it "propValid_nullify" $ + propValid_nullify + @k @v & property + it "propValid_take" $ + propValid_take + @k @v & property + it "propValid_drop" $ + propValid_drop + @k @v & property + it "propValid_splitAt" $ + propValid_splitAt + @k @v & property + it "propValid_filter" $ + propValid_filter + @k @v & property + it "propValid_filterKeys" $ + propValid_filterKeys + @k @v & property + it "propValid_filterWithKey" $ + propValid_filterWithKey + @k @v & property + it "propValid_partition" $ + propValid_partition + @k @v & property + it "propValid_partitionKeys" $ + propValid_partitionKeys + @k @v & property + it "propValid_partitionWithKey" $ + propValid_partitionWithKey + @k @v & property + it "propValid_map" $ + propValid_map + @k @v & property + it "propValid_mapKeys" $ + propValid_mapKeys + @k @v & property + it "propValid_mapKeysWith" $ + propValid_mapKeysWith + @k @v & property + it "propValid_mapWithKey" $ + propValid_mapWithKey + @k @v & property + it "propValid_mapAccumL" $ + propValid_mapAccumL + @k @v & property + it "propValid_mapAccumR" $ + propValid_mapAccumR + @k @v & property + it "propValid_mapAccumLWithKey" $ + propValid_mapAccumLWithKey + @k @v & property + it "propValid_mapAccumRWithKey" $ + propValid_mapAccumRWithKey + @k @v & property + it "propValid_traverse" $ + propValid_traverse + @k @v & property + it "propValid_traverseWithKey" $ + propValid_traverseWithKey + @k @v & property + it "propValid_intersectionWith" $ + propValid_intersectionWith + @k @v & property + it "propValid_unionWith" $ + propValid_unionWith + @k @v & property + it "propValid_append" $ + propValid_append + @k @v & property + +specValidLeftReductive + :: forall k v. (Test k v, LeftReductive v) + => Proxy k + -> Proxy v + -> Spec +specValidLeftReductive = makeSpec $ do + it "propValid_stripPrefix" $ + propValid_stripPrefix + @k @v & property + +specValidRightReductive + :: forall k v. (Test k v, RightReductive v) + => Proxy k + -> Proxy v + -> Spec +specValidRightReductive = makeSpec $ do + it "propValid_stripSuffix" $ + propValid_stripSuffix + @k @v & property + +specValidReductive + :: forall k v. (Test k v, Reductive v) + => Proxy k + -> Proxy v + -> Spec +specValidReductive = makeSpec $ do + it "propValid_minusMaybe" $ + propValid_minusMaybe + @k @v & property + +specValidLeftGCDMonoid + :: forall k v. (Test k v, LeftGCDMonoid v) + => Proxy k + -> Proxy v + -> Spec +specValidLeftGCDMonoid = makeSpec $ do + it "propValid_commonPrefix" $ + propValid_commonPrefix + @k @v & property + it "propValid_stripCommonPrefix" $ + propValid_stripCommonPrefix + @k @v & property + +specValidRightGCDMonoid + :: forall k v. (Test k v, RightGCDMonoid v) + => Proxy k + -> Proxy v + -> Spec +specValidRightGCDMonoid = makeSpec $ do + it "propValid_commonSuffix" $ + propValid_commonSuffix + @k @v & property + it "propValid_stripCommonSuffix" $ + propValid_stripCommonSuffix + @k @v & property + +specValidOverlappingGCDMonoid + :: forall k v. (Test k v, OverlappingGCDMonoid v) + => Proxy k + -> Proxy v + -> Spec +specValidOverlappingGCDMonoid = makeSpec $ do + it "propValid_overlap" $ + propValid_overlap + @k @v & property + it "propValid_stripPrefixOverlap" $ + propValid_stripPrefixOverlap + @k @v & property + it "propValid_stripSuffixOverlap" $ + propValid_stripSuffixOverlap + @k @v & property + it "propValid_stripOverlap" $ + propValid_stripOverlap + @k @v & property + +specValidGCDMonoid + :: forall k v. (Test k v, GCDMonoid v) + => Proxy k + -> Proxy v + -> Spec +specValidGCDMonoid = makeSpec $ do + it "propValid_intersection" $ + propValid_intersection + @k @v & property + +specValidLCMMonoid + :: forall k v. (Test k v, LCMMonoid v) + => Proxy k + -> Proxy v + -> Spec +specValidLCMMonoid = makeSpec $ do + it "propValid_union" $ + propValid_union + @k @v & property + +specValidMonus + :: forall k v. (Test k v, Monus v) + => Proxy k + -> Proxy v + -> Spec +specValidMonus = makeSpec $ do + it "propValid_monus" $ + propValid_monus + @k @v & property + +specValidGroup + :: forall k v. (Test k v, Group v) + => Proxy k + -> Proxy v + -> Spec +specValidGroup = makeSpec $ do + it "propValid_minus" $ + propValid_minus + @k @v & property + it "propValid_invert" $ + propValid_invert + @k @v & property + it "propValid_power" $ + propValid_power + @k @v & property + +propValid + :: Test k v => MonoidMap k v -> Property +propValid m = conjoin + [ counterexample + "propValid_nonNullKeys" + (propValid_nonNullKeys) + , counterexample + "propValid_toList" + (propValid_toList) + ] + & cover 2 + (not (Null.null m)) + "not (Null.null m)" + where + propValid_nonNullKeys = + all (\k -> MonoidMap.get k m /= mempty) (MonoidMap.nonNullKeys m) + propValid_toList = + all (\(_, v) -> v /= mempty) (MonoidMap.toList m) + +propValid_fromList + :: Test k v => [(k, v)] -> Property +propValid_fromList kvs = + propValid (MonoidMap.fromList kvs) + & cover 2 + (filter (Null.null . snd) kvs /= []) + "filter (Null.null . snd) kvs /= []" + +propValid_fromListWith + :: Test k v => Fun (v, v) v -> [(k, v)] -> Property +propValid_fromListWith (applyFun2 -> f) kvs = + propValid (MonoidMap.fromListWith f kvs) + & cover 2 + (filter (Null.null . snd) kvs /= []) + "filter (Null.null . snd) kvs /= []" + +propValid_fromMap + :: Test k v => Map k v -> Property +propValid_fromMap m = + propValid (MonoidMap.fromMap m) + & cover 2 + (Map.filter Null.null m /= mempty) + "Map.filter Null.null m /= mempty" + +propValid_fromSet + :: Test k v => Fun k v -> Set k -> Property +propValid_fromSet (applyFun -> f) ks = + propValid (MonoidMap.fromSet f ks) + & cover 2 + (Map.filter Null.null (Map.fromSet f ks) /= mempty) + "Map.filter Null.null (Map.fromSet f ks) /= mempty" + +propValid_singleton + :: Test k v => k -> v -> Property +propValid_singleton k v = + propValid (MonoidMap.singleton k v) + & cover 2 + (Null.null v) + "Null.null v" + +propValid_set + :: Test k v => k -> v -> MonoidMap k v -> Property +propValid_set k v m = + propValid (MonoidMap.set k v m) + & cover 2 + (Null.null v) + "Null.null v" + +propValid_adjust + :: Test k v => Fun v v -> k -> MonoidMap k v -> Property +propValid_adjust (applyFun -> f) k m = + propValid (MonoidMap.adjust f k m) + & cover 1 + (Null.null (f (MonoidMap.get k m))) + "Null.null (f (MonoidMap.get k m))" + +propValid_nullify + :: Test k v => k -> MonoidMap k v -> Property +propValid_nullify k m = + propValid (MonoidMap.nullify k m) + & cover 2 + (MonoidMap.nonNullKey k m) + "MonoidMap.nonNullKey k m" + +propValid_take + :: Test k v => Slice k v -> Property +propValid_take (Slice i m) = + propValid (MonoidMap.take i m) + +propValid_drop + :: Test k v => Slice k v -> Property +propValid_drop (Slice i m) = + propValid (MonoidMap.drop i m) + +propValid_splitAt + :: Test k v => Slice k v -> Property +propValid_splitAt (Slice i m) = + conjoin + [ counterexample "propValid m1" (propValid m1) + , counterexample "propValid m2" (propValid m2) + ] + where + (m1, m2) = MonoidMap.splitAt i m + +propValid_filter + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +propValid_filter (applyFun -> f) m = + propValid (MonoidMap.filter f m) + +propValid_filterKeys + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +propValid_filterKeys (applyFun -> f) m = + propValid (MonoidMap.filterKeys f m) + +propValid_filterWithKey + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +propValid_filterWithKey (applyFun2 -> f) m = + propValid (MonoidMap.filterWithKey f m) + +propValid_partition + :: Test k v => Fun v Bool -> MonoidMap k v -> Property +propValid_partition (applyFun -> f) m = + conjoin + [ counterexample "propValid m1" (propValid m1) + , counterexample "propValid m2" (propValid m2) + ] + where + (m1, m2) = MonoidMap.partition f m + +propValid_partitionKeys + :: Test k v => Fun k Bool -> MonoidMap k v -> Property +propValid_partitionKeys (applyFun -> f) m = + conjoin + [ counterexample "propValid m1" (propValid m1) + , counterexample "propValid m2" (propValid m2) + ] + where + (m1, m2) = MonoidMap.partitionKeys f m + +propValid_partitionWithKey + :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property +propValid_partitionWithKey (applyFun2 -> f) m = + conjoin + [ counterexample "propValid m1" (propValid m1) + , counterexample "propValid m2" (propValid m2) + ] + where + (m1, m2) = MonoidMap.partitionWithKey f m + +propValid_map + :: Test k v => Fun v v -> MonoidMap k v -> Property +propValid_map (applyFun -> f) m = + propValid (MonoidMap.map f m) + +propValid_mapKeys + :: Test k v => Fun k k -> MonoidMap k v -> Property +propValid_mapKeys (applyFun -> f) m = + propValid (MonoidMap.mapKeys f m) + +propValid_mapKeysWith + :: Test k v => Fun (v, v) v -> Fun k k -> MonoidMap k v -> Property +propValid_mapKeysWith (applyFun2 -> f) (applyFun -> g) m = + propValid (MonoidMap.mapKeysWith f g m) + +propValid_mapWithKey + :: Test k v => Fun (k, v) v -> MonoidMap k v -> Property +propValid_mapWithKey (applyFun2 -> f) m = + propValid (MonoidMap.mapWithKey f m) + +propValid_mapAccumL + :: forall k v s. s ~ Int + => Test k v + => Fun (s, v) (s, v) + -> s + -> MonoidMap k v + -> Property +propValid_mapAccumL (applyFun2 -> f) s m = + propValid $ snd $ MonoidMap.mapAccumL f s m + +propValid_mapAccumR + :: forall k v s. s ~ Int + => Test k v + => Fun (s, v) (s, v) + -> s + -> MonoidMap k v + -> Property +propValid_mapAccumR (applyFun2 -> f) s m = + propValid $ snd $ MonoidMap.mapAccumR f s m + +propValid_mapAccumLWithKey + :: forall k v s. s ~ Int + => Test k v + => Fun (s, k, v) (s, v) + -> s + -> MonoidMap k v + -> Property +propValid_mapAccumLWithKey (applyFun3 -> f) s m = + propValid $ snd $ MonoidMap.mapAccumLWithKey f s m + +propValid_mapAccumRWithKey + :: forall k v s. s ~ Int + => Test k v + => Fun (s, k, v) (s, v) + -> s + -> MonoidMap k v + -> Property +propValid_mapAccumRWithKey (applyFun3 -> f) s m = + propValid $ snd $ MonoidMap.mapAccumRWithKey f s m + +propValid_traverse + :: forall k v t. (Applicative t, Foldable t, Test k v) + => t ~ Identity + => Fun v (t v) + -> MonoidMap k v + -> Property +propValid_traverse (applyFun -> f) m + = conjoin + $ fmap propValid + $ F.toList @t + $ MonoidMap.traverse f m + +propValid_traverseWithKey + :: forall k v t. (Applicative t, Foldable t, Test k v) + => t ~ Identity + => Fun (k, v) (t v) + -> MonoidMap k v + -> Property +propValid_traverseWithKey (applyFun2 -> f) m + = conjoin + $ fmap propValid + $ F.toList @t + $ MonoidMap.traverseWithKey f m + +propValid_intersection + :: (Test k v, GCDMonoid v) => MonoidMap k v -> MonoidMap k v -> Property +propValid_intersection m1 m2 = + propValid (MonoidMap.intersection m1 m2) + +propValid_intersectionWith + :: Test k v => Fun (v, v) v -> MonoidMap k v -> MonoidMap k v -> Property +propValid_intersectionWith (applyFun2 -> f) m1 m2 = + propValid (MonoidMap.intersectionWith f m1 m2) + +propValid_union + :: (Test k v, LCMMonoid v) => MonoidMap k v -> MonoidMap k v -> Property +propValid_union m1 m2 = + propValid (MonoidMap.union m1 m2) + +propValid_unionWith + :: Test k v => Fun (v, v) v -> MonoidMap k v -> MonoidMap k v -> Property +propValid_unionWith (applyFun2 -> f) m1 m2 = + propValid (MonoidMap.unionWith f m1 m2) + +propValid_append + :: Test k v => MonoidMap k v -> MonoidMap k v -> Property +propValid_append m1 m2 = + propValid (MonoidMap.append m1 m2) + +propValid_minus + :: (Test k v, Group v) => MonoidMap k v -> MonoidMap k v -> Property +propValid_minus m1 m2 = + propValid (MonoidMap.minus m1 m2) + +propValid_minusMaybe + :: (Test k v, Reductive v) => MonoidMap k v -> MonoidMap k v -> Property +propValid_minusMaybe m1 m2 = + maybe (property True) propValid mr + & cover 2 (isJust mr) "isJust mr" + where + mr = MonoidMap.minusMaybe m1 m2 + +propValid_monus + :: (Test k v, Monus v) => MonoidMap k v -> MonoidMap k v -> Property +propValid_monus m1 m2 = + propValid (MonoidMap.monus m1 m2) + +propValid_invert + :: (Test k v, Group v) => MonoidMap k v -> Property +propValid_invert m = + propValid (MonoidMap.invert m) + +propValid_power + :: (Test k v, Group v) => MonoidMap k v -> Int -> Property +propValid_power m i = + propValid (MonoidMap.power m i) + +propValid_commonPrefix + :: (Test k v, LeftGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_commonPrefix m1 m2 = + propValid (MonoidMap.commonPrefix m1 m2) + +propValid_commonSuffix + :: (Test k v, RightGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_commonSuffix m1 m2 = + propValid (MonoidMap.commonSuffix m1 m2) + +propValid_stripPrefix + :: (Test k v, LeftReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripPrefix m1 m2 = + maybe (property True) propValid mr + & cover 2 (isJust mr) "isJust mr" + where + mr = MonoidMap.stripPrefix m1 m2 + +propValid_stripSuffix + :: (Test k v, RightReductive v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripSuffix m1 m2 = + maybe (property True) propValid mr + & cover 2 (isJust mr) "isJust mr" + where + mr = MonoidMap.stripSuffix m1 m2 + +propValid_stripCommonPrefix + :: (Test k v, LeftGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripCommonPrefix m1 m2 = + conjoin + [ counterexample "propValid r1" (propValid r1) + , counterexample "propValid r2" (propValid r2) + , counterexample "propValid r3" (propValid r3) + ] + where + (r1, r2, r3) = MonoidMap.stripCommonPrefix m1 m2 + +propValid_stripCommonSuffix + :: (Test k v, RightGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripCommonSuffix m1 m2 = + conjoin + [ counterexample "propValid r1" (propValid r1) + , counterexample "propValid r2" (propValid r2) + , counterexample "propValid r3" (propValid r3) + ] + where + (r1, r2, r3) = MonoidMap.stripCommonSuffix m1 m2 + +propValid_overlap + :: (Test k v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_overlap m1 m2 = + propValid (MonoidMap.overlap m1 m2) + +propValid_stripPrefixOverlap + :: (Test k v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripPrefixOverlap m1 m2 = + propValid (MonoidMap.stripPrefixOverlap m1 m2) + +propValid_stripSuffixOverlap + :: (Test k v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripSuffixOverlap m1 m2 = + propValid (MonoidMap.stripSuffixOverlap m1 m2) + +propValid_stripOverlap + :: (Test k v, OverlappingGCDMonoid v) + => MonoidMap k v + -> MonoidMap k v + -> Property +propValid_stripOverlap m1 m2 = + conjoin + [ counterexample "propValid r1" (propValid r1) + , counterexample "propValid r2" (propValid r2) + , counterexample "propValid r3" (propValid r3) + ] + where + (r1, r2, r3) = MonoidMap.stripOverlap m1 m2 diff --git a/components/monoidmap-test/Examples/MultiMapSpec.hs b/components/monoidmap-test/Examples/MultiMapSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Examples/MultiMapSpec.hs @@ -0,0 +1,730 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use any" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Examples.MultiMapSpec + where + +import Prelude + +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust, isNothing ) +import Data.Proxy + ( Proxy (..) ) +import Data.Set + ( Set ) +import Data.Typeable + ( Typeable, typeRep ) +import Examples.MultiMap.Class + ( MultiMap ) +import Examples.MultiMap.Instances.MultiMap1 + ( MultiMap1 ) +import Examples.MultiMap.Instances.MultiMap2 + ( MultiMap2 ) +import Examples.MultiMap.Instances.MultiMap3 + ( MultiMap3 ) +import Examples.MultiMap.Instances.MultiMap4 + ( MultiMap4 ) +import Test.Common + () +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , Property + , Testable + , checkCoverage + , counterexample + , cover + , (.||.) + , (===) + ) + +import qualified Data.Foldable as F +import qualified Data.Set as Set +import qualified Examples.MultiMap.Class as M +import qualified Test.QuickCheck as QC + +spec :: Spec +spec = do + + -- Uncomment the following line to see property test failures for an + -- unlawful implementation of 'MultiMap': + -- + -- specFor (Proxy @(MultiMap1 Int Int)) + + specFor (Proxy @(MultiMap2 Int Int)) + specFor (Proxy @(MultiMap3 Int Int)) + specFor (Proxy @(MultiMap4 Int Int)) + +type Test m k v = + ( Arbitrary k + , Arbitrary v + , MultiMap m k v + , Show (m k v) + , Show k + , Show v + , Typeable m + , Typeable k + , Typeable v + ) + +specFor :: forall m k v. Test m k v => Proxy (m k v) -> Spec +specFor multimapType = do + + let description = show (typeRep multimapType) + + let property :: Testable t => t -> Property + property = checkCoverage . QC.property + + describe description $ do + + describe "Validity properties" $ do + + it "prop_fromList_valid" $ + prop_fromList_valid + @m @k @v & property + it "prop_update_valid" $ + prop_update_valid + @m @k @v & property + it "prop_insert_valid" $ + prop_insert_valid + @m @k @v & property + it "prop_remove_valid" $ + prop_remove_valid + @m @k @v & property + it "prop_union_valid" $ + prop_union_valid + @m @k @v & property + it "prop_intersection_valid" $ + prop_intersection_valid + @m @k @v & property + + describe "General properties" $ do + + it "prop_fromList_filter" $ + prop_fromList_filter + @m @k @v & property + it "prop_toList_filter" $ + prop_toList_filter + @m @k @v & property + it "prop_empty_fromList" $ + prop_empty_fromList + @m @k @v & property + it "prop_lookup_filter_fold" $ + prop_lookup_filter_fold + @m @k @v & property + it "prop_null_lookup" $ + prop_null_lookup + @m @k @v & property + it "prop_nonNull_lookup" $ + prop_nonNull_lookup + @m @k @v & property + it "prop_nonNullKey_lookup" $ + prop_nonNullKey_lookup + @m @k @v & property + it "prop_nonNullKeys_nonNullKey" $ + prop_nonNullKeys_nonNullKey + @m @k @v & property + it "prop_nonNullCount_nonNullKeys" $ + prop_nonNullCount_nonNullKeys + @m @k @v & property + it "prop_isSubmapOf_lookup" $ + prop_isSubmapOf_lookup + @m @k @v & property + it "prop_update_lookup" $ + prop_update_lookup + @m @k @v & property + it "prop_insert_lookup" $ + prop_insert_lookup + @m @k @v & property + it "prop_remove_lookup" $ + prop_remove_lookup + @m @k @v & property + it "prop_union_idempotence" $ + prop_union_idempotence + @m @k @v & property + it "prop_union_identity_left" $ + prop_union_identity_left + @m @k @v & property + it "prop_union_identity_right" $ + prop_union_identity_right + @m @k @v & property + it "prop_union_commutativity" $ + prop_union_commutativity + @m @k @v & property + it "prop_union_associativity" $ + prop_union_associativity + @m @k @v & property + it "prop_union_containment_left" $ + prop_union_containment_left + @m @k @v & property + it "prop_union_containment_right" $ + prop_union_containment_right + @m @k @v & property + it "prop_union_distributivity" $ + prop_union_distributivity + @m @k @v & property + it "prop_intersection_idempotence" $ + prop_intersection_idempotence + @m @k @v & property + it "prop_intersection_identity_left" $ + prop_intersection_identity_left + @m @k @v & property + it "prop_intersection_identity_right" $ + prop_intersection_identity_right + @m @k @v & property + it "prop_intersection_commutativity" $ + prop_intersection_commutativity + @m @k @v & property + it "prop_intersection_associativity" $ + prop_intersection_associativity + @m @k @v & property + it "prop_intersection_containment_left" $ + prop_intersection_containment_left + @m @k @v & property + it "prop_intersection_containment_right" $ + prop_intersection_containment_right + @m @k @v & property + it "prop_intersection_distributivity" $ + prop_intersection_distributivity + @m @k @v & property + +-------------------------------------------------------------------------------- +-- Validity properties +-------------------------------------------------------------------------------- + +-- A multimap is valid if (and only if): +-- +-- - all keys included in 'nonNullKeys' are associated with non-empty sets. +-- - all keys included in 'toList' are associated with non-empty sets. + +prop_valid + :: Test m k v => m k v -> Property +prop_valid m = QC.conjoin + [ counterexample + "prop_valid_nonNullKeys" + (prop_valid_nonNullKeys) + , counterexample + "prop_valid_toList" + (prop_valid_toList) + ] + & cover 1 + (M.null m) + "M.null m" + & cover 1 + (M.nonNull m) + "M.nonNull m" + where + prop_valid_nonNullKeys = + all (\k -> M.lookup k m /= Set.empty) (M.nonNullKeys m) + prop_valid_toList = + all (\(_, v) -> v /= Set.empty) (M.toList m) + +-------------------------------------------------------------------------------- +-- Validity of operations that produce multimaps +-------------------------------------------------------------------------------- + +prop_fromList_valid + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_fromList_valid kvs = + prop_valid @m @k @v (M.fromList kvs) + +prop_update_valid + :: forall m k v. Test m k v + => k + -> Set v + -> [(k, Set v)] + -> Property +prop_update_valid k vs kvs = + prop_valid @m @k @v (M.update k vs (M.fromList kvs)) + +prop_insert_valid + :: forall m k v. Test m k v + => k + -> Set v + -> [(k, Set v)] + -> Property +prop_insert_valid k vs kvs = + prop_valid @m @k @v (M.insert k vs (M.fromList kvs)) + +prop_remove_valid + :: forall m k v. Test m k v + => k + -> Set v + -> [(k, Set v)] + -> Property +prop_remove_valid k vs kvs = + prop_valid @m @k @v (M.remove k vs (M.fromList kvs)) + +prop_union_valid + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_valid kvs1 kvs2 = + prop_valid @m @k @v (M.union (M.fromList kvs1) (M.fromList kvs2)) + +prop_intersection_valid + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_valid kvs1 kvs2 = + prop_valid @m @k @v (M.intersection (M.fromList kvs1) (M.fromList kvs2)) + +-------------------------------------------------------------------------------- +-- General properties +-------------------------------------------------------------------------------- + +prop_fromList_filter + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_fromList_filter kvs = + M.fromList @m @k @v kvs === M.fromList (filter ((/= Set.empty) . snd) kvs) + +prop_toList_filter + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_toList_filter kvs = + M.toList m === filter ((/= Set.empty) . snd) (M.toList m) + where + m :: m k v + m = M.fromList kvs + +prop_empty_fromList + :: forall m k v. Test m k v + => Property +prop_empty_fromList = + M.empty @m @k @v === M.fromList [] + +prop_lookup_filter_fold + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> Property +prop_lookup_filter_fold k kvs = + M.lookup k m === F.foldMap snd (filter ((== k) . fst) kvs) + & cover 10 + (isJust (lookup k kvs)) + "isJust (lookup k kvs)" + & cover 10 + (isNothing (lookup k kvs)) + "isNothing (lookup k kvs)" + where + m :: m k v + m = M.fromList kvs + +prop_null_lookup + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> Property +prop_null_lookup k kvs = + M.null m ==> M.lookup k m == Set.empty + & cover 2 + (M.lookup k m == Set.empty && M.null m) + "M.lookup k m == Set.empty && M.null m" + & cover 2 + (M.lookup k m == Set.empty && M.nonNull m) + "M.lookup k m == Set.empty && M.nonNull m" + & cover 2 + (M.lookup k m /= Set.empty && M.nonNull m) + "M.lookup k m /= Set.empty && M.nonNull m" + where + m :: m k v + m = M.fromList kvs + +prop_nonNull_lookup + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> Property +prop_nonNull_lookup k kvs = + M.lookup k m /= Set.empty ==> M.nonNull m + & cover 2 + (M.lookup k m == Set.empty && M.null m) + "M.lookup k m == Set.empty && M.null m" + & cover 2 + (M.lookup k m == Set.empty && M.nonNull m) + "M.lookup k m == Set.empty && M.nonNull m" + & cover 2 + (M.lookup k m /= Set.empty && M.nonNull m) + "M.lookup k m /= Set.empty && M.nonNull m" + where + m :: m k v + m = M.fromList kvs + +prop_nonNullKey_lookup + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> Property +prop_nonNullKey_lookup k kvs = + M.nonNullKey k m === (M.lookup k m /= Set.empty) + & cover 2 + (M.lookup k m == Set.empty && M.null m) + "M.lookup k m == Set.empty && M.null m" + & cover 2 + (M.lookup k m == Set.empty && M.nonNull m) + "M.lookup k m == Set.empty && M.nonNull m" + & cover 2 + (M.lookup k m /= Set.empty && M.nonNull m) + "M.lookup k m /= Set.empty && M.nonNull m" + where + m :: m k v + m = M.fromList kvs + +prop_nonNullKeys_nonNullKey + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_nonNullKeys_nonNullKey kvs = QC.property $ + all (`M.nonNullKey` m) (M.nonNullKeys m) + & cover 2 + (M.null m) + "M.null m" + & cover 2 + (M.nonNull m) + "M.nonNull m" + where + m :: m k v + m = M.fromList kvs + +prop_nonNullCount_nonNullKeys + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_nonNullCount_nonNullKeys kvs = + M.nonNullCount m === Set.size (M.nonNullKeys m) + & cover 1 + (M.nonNullCount m == 0) + "M.nonNullCount m == 0" + & cover 1 + (M.nonNullCount m == 1) + "M.nonNullCount m == 1" + & cover 1 + (M.nonNullCount m == 2) + "M.nonNullCount m == 2" + & cover 1 + (M.nonNullCount m >= 3) + "M.nonNullCount m >= 3" + where + m :: m k v + m = M.fromList kvs + +prop_isSubmapOf_lookup + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_isSubmapOf_lookup k kvs1 kvs2 = + m1 `M.isSubmapOf` m2 + ==> + M.lookup k m1 `Set.isSubsetOf` M.lookup k m2 + & cover 1 + (m1 `M.isSubmapOf` m2) + "m1 `M.isSubmapOf` m2" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_update_lookup + :: forall m k v. Test m k v + => k + -> k + -> Set v + -> [(k, Set v)] + -> Property +prop_update_lookup k1 k2 vs kvs = + M.lookup k1 (M.update k2 vs m) === (if k1 == k2 then vs else M.lookup k1 m) + & cover 1 + (k1 == k2) + "k1 == k2" + & cover 10 + (k1 /= k2) + "k1 /= k2" + where + m :: m k v + m = M.fromList kvs + +prop_insert_lookup + :: forall m k v. Test m k v + => k + -> k + -> Set v + -> [(k, Set v)] + -> Property +prop_insert_lookup k1 k2 vs kvs = + M.lookup k1 (M.insert k2 vs m) === + (if k1 == k2 then M.lookup k1 m `Set.union` vs else M.lookup k1 m) + & cover 1 + (k1 == k2) + "k1 == k2" + & cover 10 + (k1 /= k2) + "k1 /= k2" + where + m :: m k v + m = M.fromList kvs + +prop_remove_lookup + :: forall m k v. Test m k v + => k + -> k + -> Set v + -> [(k, Set v)] + -> Property +prop_remove_lookup k1 k2 vs kvs = + M.lookup k1 (M.remove k2 vs m) === + (if k1 == k2 then M.lookup k1 m `Set.difference` vs else M.lookup k1 m) + & cover 1 + (k1 == k2) + "k1 == k2" + & cover 10 + (k1 /= k2) + "k1 /= k2" + where + m :: m k v + m = M.fromList kvs + +prop_union_idempotence + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_union_idempotence kvs = + M.union m m === m + where + m :: m k v + m = M.fromList kvs + +prop_union_identity_left + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_union_identity_left kvs = + M.union m M.empty === m + where + m :: m k v + m = M.fromList kvs + +prop_union_identity_right + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_union_identity_right kvs = + M.union M.empty m === m + where + m :: m k v + m = M.fromList kvs + +prop_union_commutativity + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_commutativity kvs1 kvs2 = + M.union m1 m2 === M.union m2 m1 + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_union_associativity + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_associativity kvs1 kvs2 kvs3 = + M.union m1 (M.union m2 m3) + === M.union (M.union m1 m2) m3 + where + m1, m2, m3 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + m3 = M.fromList kvs3 + +prop_union_containment_left + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_containment_left kvs1 kvs2 = QC.property $ + m1 `M.isSubmapOf` M.union m1 m2 + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_union_containment_right + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_containment_right kvs1 kvs2 = QC.property $ + m2 `M.isSubmapOf` M.union m1 m2 + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_union_distributivity + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_union_distributivity k kvs1 kvs2 = + M.lookup k (M.union m1 m2) === Set.union (M.lookup k m1) (M.lookup k m2) + & cover 1 + (M.nonNullKey k (M.union m1 m2)) + "M.nonNullKey k (M.union m1 m2)" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_intersection_idempotence + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_intersection_idempotence kvs = + M.intersection m m === m + where + m :: m k v + m = M.fromList kvs + +prop_intersection_identity_left + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_intersection_identity_left kvs = + M.intersection m M.empty === M.empty + where + m :: m k v + m = M.fromList kvs + +prop_intersection_identity_right + :: forall m k v. Test m k v + => [(k, Set v)] + -> Property +prop_intersection_identity_right kvs = + M.intersection M.empty m === M.empty + where + m :: m k v + m = M.fromList kvs + +prop_intersection_commutativity + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_commutativity kvs1 kvs2 = + M.intersection m1 m2 === M.intersection m2 m1 + & cover 1 + (M.nonNull (M.intersection m1 m2)) + "M.nonNull (M.intersection m1 m2)" + & cover 1 + (M.nonNull (M.intersection m2 m1)) + "M.nonNull (M.intersection m2 m1)" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_intersection_associativity + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_associativity kvs1 kvs2 kvs3 = + M.intersection m1 (M.intersection m2 m3) + === M.intersection (M.intersection m1 m2) m3 + & cover 1 + (M.nonNull (M.intersection m1 (M.intersection m2 m3))) + "M.nonNull (M.intersection m1 (M.intersection m2 m3))" + & cover 1 + (M.nonNull (M.intersection (M.intersection m1 m2) m3)) + "M.nonNull (M.intersection (M.intersection m1 m2) m3)" + where + m1, m2, m3 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + m3 = M.fromList kvs3 + +prop_intersection_containment_left + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_containment_left kvs1 kvs2 = QC.property $ + M.intersection m1 m2 `M.isSubmapOf` m1 + & cover 1 + (M.nonNull (M.intersection m1 m2)) + "M.nonNull (M.intersection m1 m2)" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_intersection_containment_right + :: forall m k v. Test m k v + => [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_containment_right kvs1 kvs2 = QC.property $ + M.intersection m1 m2 `M.isSubmapOf` m2 + & cover 1 + (M.nonNull (M.intersection m1 m2)) + "M.nonNull (M.intersection m1 m2)" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +prop_intersection_distributivity + :: forall m k v. Test m k v + => k + -> [(k, Set v)] + -> [(k, Set v)] + -> Property +prop_intersection_distributivity k kvs1 kvs2 = + M.lookup k (M.intersection m1 m2) + === Set.intersection (M.lookup k m1) (M.lookup k m2) + & cover 1 + (M.nonNullKey k (M.intersection m1 m2)) + "M.nonNullKey k (M.intersection m1 m2)" + where + m1, m2 :: m k v + m1 = M.fromList kvs1 + m2 = M.fromList kvs2 + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +infixr 3 ==> +(==>) :: Bool -> Bool -> Property +a ==> b = not a .||. b + +_preventRedundantImportErrors :: () +_preventRedundantImportErrors = () + where + _multiMap1 :: MultiMap1 () () + _multiMap1 = M.empty diff --git a/components/monoidmap-test/Examples/RecoveredMapSpec.hs b/components/monoidmap-test/Examples/RecoveredMapSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Examples/RecoveredMapSpec.hs @@ -0,0 +1,584 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use any" #-} +{-# HLINT ignore "Use null" #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Examples.RecoveredMapSpec + where + +import Prelude + +import Data.Function + ( on, (&) ) +import Data.List + ( nubBy ) +import Data.Monoid + ( Sum (..) ) +import Data.Proxy + ( Proxy (..) ) +import Data.Semigroup + ( Semigroup (stimes) ) +import Data.Set + ( Set ) +import Data.Text + ( Text ) +import Data.Typeable + ( Typeable, typeRep ) +import Numeric.Natural + ( Natural ) +import Test.Common + () +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , CoArbitrary + , Fun + , Function + , NonNegative (..) + , Property + , Testable + , applyFun + , applyFun2 + , applyFun3 + , checkCoverage + , cover + , listOf + , shrinkMapBy + , (===) + ) +import Test.QuickCheck.Classes + ( eqLaws, functorLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) + +import qualified Data.Map.Strict as OMap +import qualified Data.Set as Set +import qualified Examples.RecoveredMap as RMap +import qualified Test.QuickCheck as QC + +spec :: Spec +spec = do + specFor (Proxy @Int) (Proxy @(Set Int)) + specFor (Proxy @Int) (Proxy @(Set Natural)) + specFor (Proxy @Int) (Proxy @(Sum Int)) + specFor (Proxy @Int) (Proxy @(Sum Natural)) + specFor (Proxy @Int) (Proxy @Text) + +specFor + :: forall k v. () => + ( Arbitrary k + , Arbitrary v + , CoArbitrary k + , CoArbitrary v + , Eq v + , Function k + , Function v + , Monoid v + , Ord k + , Show k + , Show v + , Typeable k + , Typeable v + ) + => Proxy k + -> Proxy v + -> Spec +specFor keyType valueType = do + + let description = mconcat + [ "RecoveredMap (" + , show (typeRep keyType) + , ") (" + , show (typeRep valueType) + , ")" + ] + + let property :: Testable t => t -> Property + property = checkCoverage . QC.property + + describe description $ do + + describe "Class laws" $ do + testLawsMany @(RMap.Map k v) + [ eqLaws + , monoidLaws + , semigroupLaws + , semigroupMonoidLaws + ] + testLawsMany @(RMap.Map k) + [ functorLaws + ] + + describe "Conversion to and from lists" $ do + it "prop_fromList_toList" $ + prop_fromList_toList + @k @v & property + + describe "Empty" $ do + it "prop_empty_keysSet" $ + prop_empty_keysSet + @k & property + it "prop_empty_lookup" $ + prop_empty_lookup + @k @v & property + it "prop_empty_show" $ + prop_empty_show + @k @v & property + it "prop_empty_toList" $ + prop_empty_toList + @k @v & property + + describe "Singleton" $ do + it "prop_singleton_keysSet" $ + prop_singleton_keysSet + @k @v & property + it "prop_singleton_lookup" $ + prop_singleton_lookup + @k @v & property + it "prop_singleton_show" $ + prop_singleton_show + @k @v & property + it "prop_singleton_toList" $ + prop_singleton_toList + @k @v & property + + describe "Append" $ do + it "prop_append_toList" $ + prop_append_toList + @k @v & property + + describe "Times" $ do + it "prop_stimes_toList" $ + prop_stimes_toList + @k @v & property + + describe "Delete" $ do + it "prop_delete_lookup" $ + prop_delete_lookup + @k @v & property + it "prop_delete_member" $ + prop_delete_member + @k @v & property + it "prop_delete_toList" $ + prop_delete_toList + @k @v & property + + describe "Insert" $ do + it "prop_insert_lookup" $ + prop_insert_lookup + @k @v & property + it "prop_insert_member" $ + prop_insert_member + @k @v & property + it "prop_insert_toList" $ + prop_insert_toList + @k @v & property + + describe "Map" $ do + it "prop_map" $ + prop_map + @k @v @v & property + it "prop_map_mempty" $ + prop_map_mempty + @k @v @v & property + it "prop_mapWithKey" $ + prop_mapWithKey + @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 +-------------------------------------------------------------------------------- + +prop_fromList_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => [(k, v)] + -> Property +prop_fromList_toList kvs = + (===) + (RMap.toList (RMap.fromList kvs)) + (OMap.toList (OMap.fromList kvs)) + & cover 10 + (length kvs > 1 && length (nubBy ((==) `on` fst) kvs) /= length kvs) + "length kvs > 1 && length (nubBy ((==) `on` fst) kvs) /= length kvs" + & cover 10 + (length kvs > 1 && length (nubBy ((==) `on` fst) kvs) == length kvs) + "length kvs > 1 && length (nubBy ((==) `on` fst) kvs) == length kvs" + +-------------------------------------------------------------------------------- +-- Empty +-------------------------------------------------------------------------------- + +prop_empty_keysSet + :: forall k. (Eq k, Show k) + => Property +prop_empty_keysSet = + (===) + (RMap.keysSet (RMap.empty @k)) + (OMap.keysSet (OMap.empty @k)) + +prop_empty_lookup + :: forall k v. (Ord k, Eq v, Show v) + => k + -> Property +prop_empty_lookup k = + (===) + (RMap.lookup k (RMap.empty @k @v)) + (OMap.lookup k (OMap.empty @k @v)) + +prop_empty_show + :: forall k v. (Show k, Show v) + => Property +prop_empty_show = + (===) + (show (RMap.empty @k @v)) + (show (OMap.empty @k @v)) + +prop_empty_toList + :: forall k v. (Eq k, Show k, Eq v, Show v) + => Property +prop_empty_toList = + (===) + (RMap.toList (RMap.empty @k @v)) + (OMap.toList (OMap.empty @k @v)) + +-------------------------------------------------------------------------------- +-- Singleton +-------------------------------------------------------------------------------- + +prop_singleton_keysSet + :: forall k v. (Ord k, Show k) + => k + -> v + -> Property +prop_singleton_keysSet k v = + (===) + (RMap.keysSet (RMap.singleton k v)) + (OMap.keysSet (OMap.singleton k v)) + +prop_singleton_lookup + :: forall k v. (Ord k, Eq v, Show v) + => k + -> v + -> Property +prop_singleton_lookup k v = + (===) + (RMap.lookup k (RMap.singleton k v)) + (OMap.lookup k (OMap.singleton k v)) + +prop_singleton_show + :: forall k v. (Ord k, Show k, Show v) + => k + -> v + -> Property +prop_singleton_show k v = + (===) + (show (RMap.singleton k v)) + (show (OMap.singleton k v)) + +prop_singleton_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => k + -> v + -> Property +prop_singleton_toList k v = + (===) + (RMap.toList (RMap.singleton k v)) + (OMap.toList (OMap.singleton k v)) + +-------------------------------------------------------------------------------- +-- Append +-------------------------------------------------------------------------------- + +prop_append_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => [(k, v)] + -> [(k, v)] + -> Property +prop_append_toList kvs1 kvs2 = + (===) + (RMap.toList (RMap.fromList kvs1 <> RMap.fromList kvs2)) + (OMap.toList (OMap.fromList kvs1 <> OMap.fromList kvs2)) + & cover 10 + (ks1 `Set.disjoint` ks2) + "ks1 `Set.disjoint` ks2" + & cover 10 + (not (ks1 `Set.disjoint` ks2)) + "not (ks1 `Set.disjoint` ks2)" + where + ks1 = Set.fromList (fst <$> kvs1) + ks2 = Set.fromList (fst <$> kvs2) + +-------------------------------------------------------------------------------- +-- Times +-------------------------------------------------------------------------------- + +prop_stimes_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => [(k, v)] + -> NonNegative Int + -> Property +prop_stimes_toList kvs (NonNegative n) = + (===) + (RMap.toList (stimes n (RMap.fromList kvs))) + (OMap.toList (stimes n (OMap.fromList kvs))) + & cover 1 + (n == 0) + "n == 0" + & cover 1 + (n == 1) + "n == 1" + & cover 10 + (n >= 2) + "n >= 2" + +-------------------------------------------------------------------------------- +-- Delete +-------------------------------------------------------------------------------- + +prop_delete_lookup + :: forall k v. (Ord k, Eq v, Show v) + => [(k, v)] + -> k + -> Property +prop_delete_lookup kvs k = + (===) + (RMap.lookup k (RMap.delete k (RMap.fromList kvs))) + (OMap.lookup k (OMap.delete k (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +prop_delete_member + :: forall k v. (Ord k, Eq v) + => [(k, v)] + -> k + -> Property +prop_delete_member kvs k = + (===) + (RMap.member k (RMap.delete k (RMap.fromList kvs))) + (OMap.member k (OMap.delete k (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +prop_delete_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => [(k, v)] + -> k + -> Property +prop_delete_toList kvs k = + (===) + (RMap.toList (RMap.delete k (RMap.fromList kvs))) + (OMap.toList (OMap.delete k (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +-------------------------------------------------------------------------------- +-- Insert +-------------------------------------------------------------------------------- + +prop_insert_lookup + :: forall k v. (Ord k, Eq v, Show v) + => [(k, v)] + -> k + -> v + -> Property +prop_insert_lookup kvs k v = + (===) + (RMap.lookup k (RMap.insert k v (RMap.fromList kvs))) + (OMap.lookup k (OMap.insert k v (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +prop_insert_member + :: forall k v. (Ord k, Eq v) + => [(k, v)] + -> k + -> v + -> Property +prop_insert_member kvs k v = + (===) + (RMap.member k (RMap.insert k v (RMap.fromList kvs))) + (OMap.member k (OMap.insert k v (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +prop_insert_toList + :: forall k v. (Ord k, Show k, Eq v, Show v) + => [(k, v)] + -> k + -> v + -> Property +prop_insert_toList kvs k v = + (===) + (RMap.toList (RMap.insert k v (RMap.fromList kvs))) + (OMap.toList (OMap.insert k v (OMap.fromList kvs))) + & cover 10 + (filter ((== k) . fst) kvs == []) + "filter ((== k) . fst) kvs == []" + & cover 10 + (filter ((== k) . fst) kvs /= []) + "filter ((== k) . fst) kvs /= []" + +-------------------------------------------------------------------------------- +-- Map +-------------------------------------------------------------------------------- + +prop_map + :: (Ord k, Show k, Eq v2, Show v2) + => [(k, v1)] + -> Fun v1 v2 + -> Property +prop_map kvs (applyFun -> f) = + (===) + (RMap.toList (RMap.map f (RMap.fromList kvs))) + (OMap.toList (OMap.map f (OMap.fromList kvs))) + +prop_map_mempty + :: forall k v1 v2. (Ord k, Show k, Eq v2, Monoid v2, Show v2) + => [(k, v1)] + -> Property +prop_map_mempty kvs = + (===) + (RMap.toList (RMap.map (const (mempty @v2)) (RMap.fromList kvs))) + (OMap.toList (OMap.map (const (mempty @v2)) (OMap.fromList kvs))) + +prop_mapWithKey + :: (Ord k, Show k, Eq v2, Show v2) + => [(k, v1)] + -> Fun (k, v1) v2 + -> Property +prop_mapWithKey kvs (applyFun2 -> f) = + (===) + (RMap.toList (RMap.mapWithKey f (RMap.fromList kvs))) + (OMap.toList (OMap.mapWithKey f (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 +-------------------------------------------------------------------------------- + +instance (Arbitrary k, Ord k, Arbitrary v) => + Arbitrary (RMap.Map k v) + where + arbitrary = RMap.fromList <$> listOf ((,) <$> arbitrary <*> arbitrary) + shrink = shrinkMapBy RMap.fromList RMap.toList shrink diff --git a/components/monoidmap-test/Spec.hs b/components/monoidmap-test/Spec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/components/monoidmap-test/SpecHook.hs b/components/monoidmap-test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/SpecHook.hs @@ -0,0 +1,6 @@ +module SpecHook where + +import Test.Hspec + +hook :: Spec -> Spec +hook = parallel diff --git a/components/monoidmap-test/Test/Combinators/NonZero.hs b/components/monoidmap-test/Test/Combinators/NonZero.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Test/Combinators/NonZero.hs @@ -0,0 +1,44 @@ +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Test.Combinators.NonZero + ( NonZero + , genNonZero + , getNonZero + , maybeNonZero + , shrinkNonZero + ) + where + +import Prelude + +import Data.Group + ( Group ) +import Data.Maybe + ( mapMaybe ) +import Data.Monoid.Null + ( MonoidNull ) +import Data.Semigroup.Cancellative + ( Commutative ) +import Test.QuickCheck + ( Gen, suchThatMap ) + +-- | A combinator for non-zero values. +newtype NonZero a = NonZero a + deriving newtype (Eq, Num, Read, Show) + deriving newtype (Semigroup, Commutative, Monoid, MonoidNull, Group) + +genNonZero :: (Eq a, Num a) => Gen a -> Gen (NonZero a) +genNonZero genA = suchThatMap genA maybeNonZero + +getNonZero :: NonZero a -> a +getNonZero (NonZero a) = a + +maybeNonZero :: (Eq a, Num a) => a -> Maybe (NonZero a) +maybeNonZero p + | p == 0 = Nothing + | otherwise = Just (NonZero p) + +shrinkNonZero :: (Eq a, Num a) => (a -> [a]) -> NonZero a -> [NonZero a] +shrinkNonZero shrinkA = mapMaybe maybeNonZero . shrinkA . getNonZero diff --git a/components/monoidmap-test/Test/Common.hs b/components/monoidmap-test/Test/Common.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Test/Common.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use null" -} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Test.Common + ( Key + , Test + , TestKey + , TestValueType (..) + , testValueTypesAll + , testValueTypesGroup + , testValueTypesMonus + , testValueTypesLeftReductive + , testValueTypesRightReductive + , testValueTypesReductive + , testValueTypesLeftGCDMonoid + , testValueTypesRightGCDMonoid + , testValueTypesOverlappingGCDMonoid + , testValueTypesGCDMonoid + , testValueTypesLCMMonoid + , TestValue + , makeSpec + , property + ) where + +import Prelude + +import Data.Group + ( Group ) +import Data.Kind + ( Constraint, Type ) +import Data.Monoid + ( Dual, Product, Sum ) +import Data.Monoid.GCD + ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) +import Data.Monoid.LCM + ( LCMMonoid ) +import Data.Monoid.Monus + ( Monus ) +import Data.Monoid.Null + ( MonoidNull ) +import Data.MonoidMap + ( MonoidMap ) +import Data.Proxy + ( Proxy (Proxy) ) +import Data.Semigroup.Cancellative + ( LeftReductive, Reductive, RightReductive ) +import Data.Set + ( Set ) +import Data.Text + ( Text ) +import Data.Typeable + ( Typeable, typeRep ) +import GHC.Exts + ( IsList (..) ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe ) +import Test.Key + ( Key2, Key4 ) +import Test.QuickCheck + ( Arbitrary (..) + , CoArbitrary (..) + , Function (..) + , Property + , Testable + , arbitrarySizedIntegral + , checkCoverage + , coarbitraryIntegral + , coarbitraryShow + , frequency + , functionIntegral + , functionMap + , functionShow + , listOf + , scale + , shrinkIntegral + , shrinkMapBy + ) + +import qualified Data.MonoidMap as MonoidMap +import qualified Data.Text as Text +import qualified Test.QuickCheck as QC + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance (Arbitrary k, Ord k, Arbitrary v, MonoidNull v) => + Arbitrary (MonoidMap k v) + where + arbitrary = + fromList <$> scale (`mod` 16) (listOf ((,) <$> arbitrary <*> arbitrary)) + shrink = + shrinkMapBy MonoidMap.fromMap MonoidMap.toMap shrink + +instance (CoArbitrary k, CoArbitrary v) => + CoArbitrary (MonoidMap k v) + where + coarbitrary = coarbitrary . MonoidMap.toMap + +instance (Function k, Function v, Ord k, MonoidNull v) => + Function (MonoidMap k v) + where + function = functionMap MonoidMap.toMap MonoidMap.fromMap + +instance Arbitrary Natural where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance CoArbitrary Natural where + coarbitrary = coarbitraryIntegral + +instance Function Natural where + function = functionIntegral + +instance Arbitrary Text where + arbitrary = Text.pack <$> listOf genChar + where + genChar = frequency + [ (64, pure 'a') + , (16, pure 'b') + , ( 4, pure 'c') + , ( 1, pure 'd') + ] + +instance CoArbitrary Text where + coarbitrary = coarbitraryShow + +instance Function Text where + function = functionShow + +-------------------------------------------------------------------------------- +-- Test keys +-------------------------------------------------------------------------------- + +type SmallKey = Key2 +type Key = Key4 + +-------------------------------------------------------------------------------- +-- Test constraints +-------------------------------------------------------------------------------- + +type Test k v = (TestKey k, TestValue v) + +type TestKey k = + ( Arbitrary k + , CoArbitrary k + , Function k + , Ord k + , Show k + , Typeable k + ) + +type TestValue v = + ( Arbitrary v + , CoArbitrary v + , Eq v + , Function v + , MonoidNull v + , Show v + , Typeable v + ) + +-------------------------------------------------------------------------------- +-- Test value types (for different type class constraints) +-------------------------------------------------------------------------------- + +data TestValueType (c :: Type -> Constraint) = + forall v. (TestValue v, c v) => TestValueType (Proxy v) + +testValueTypesAll :: [TestValueType MonoidNull] +testValueTypesAll = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Dual [Int])) + , TestValueType (Proxy @(Dual [Natural])) + , TestValueType (Proxy @(Product Int)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Int)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @[Int]) + , TestValueType (Proxy @[Natural]) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Int))) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesGroup :: [TestValueType Group] +testValueTypesGroup = + [ TestValueType (Proxy @(Sum Int)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Int))) + ] + +testValueTypesMonus :: [TestValueType Monus] +testValueTypesMonus = + [ TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesLeftReductive :: [TestValueType LeftReductive] +testValueTypesLeftReductive = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Dual [Int])) + , TestValueType (Proxy @(Dual [Natural])) + , TestValueType (Proxy @(Product Int)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Int)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @[Int]) + , TestValueType (Proxy @[Natural]) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesRightReductive :: [TestValueType RightReductive] +testValueTypesRightReductive = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Dual [Int])) + , TestValueType (Proxy @(Dual [Natural])) + , TestValueType (Proxy @(Product Int)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Int)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @[Int]) + , TestValueType (Proxy @[Natural]) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesReductive :: [TestValueType Reductive] +testValueTypesReductive = + [ TestValueType (Proxy @(Product Int)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Int)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesLeftGCDMonoid :: [TestValueType LeftGCDMonoid] +testValueTypesLeftGCDMonoid = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesRightGCDMonoid :: [TestValueType RightGCDMonoid] +testValueTypesRightGCDMonoid = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesOverlappingGCDMonoid :: [TestValueType OverlappingGCDMonoid] +testValueTypesOverlappingGCDMonoid = + [ TestValueType (Proxy @(Dual Text)) + , TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(Text)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesGCDMonoid :: [TestValueType GCDMonoid] +testValueTypesGCDMonoid = + [ TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +testValueTypesLCMMonoid :: [TestValueType LCMMonoid] +testValueTypesLCMMonoid = + [ TestValueType (Proxy @(Product Natural)) + , TestValueType (Proxy @(Set Int)) + , TestValueType (Proxy @(Set Natural)) + , TestValueType (Proxy @(Sum Natural)) + , TestValueType (Proxy @(MonoidMap SmallKey (Sum Natural))) + ] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +makeSpec :: forall k v. Test k v => Spec -> Proxy k -> Proxy v -> Spec +makeSpec spec _k _v = describe (show $ typeRep (Proxy @(MonoidMap k v))) spec + +property :: Testable t => t -> Property +property = checkCoverage . QC.property diff --git a/components/monoidmap-test/Test/Hspec/Unit.hs b/components/monoidmap-test/Test/Hspec/Unit.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Test/Hspec/Unit.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FunctionalDependencies #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Test.Hspec.Unit where + +import Prelude + +import Data.Functor + ( (<&>) ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( counterexample, property ) +import Text.Show.Pretty + ( ppShow ) + +import qualified Data.Foldable as F + +class IsUnitTestDatum d f r | d -> f, d -> r where + params :: d -> [String] + resultActual :: f -> d -> r + resultExpected :: d -> r + +data UnitTestDatum1 p1 r = UnitTestDatum1 p1 r +data UnitTestDatum2 p1 p2 r = UnitTestDatum2 p1 p2 r +data UnitTestDatum3 p1 p2 p3 r = UnitTestDatum3 p1 p2 p3 r +data UnitTestDatum4 p1 p2 p3 p4 r = UnitTestDatum4 p1 p2 p3 p4 r + +type UnitTestData1 p1 r = [UnitTestDatum1 p1 r] +type UnitTestData2 p1 p2 r = [UnitTestDatum2 p1 p2 r] +type UnitTestData3 p1 p2 p3 r = [UnitTestDatum3 p1 p2 p3 r] +type UnitTestData4 p1 p2 p3 p4 r = [UnitTestDatum4 p1 p2 p3 p4 r] + +unitTestDatum1 :: (p1, r) -> UnitTestDatum1 p1 r +unitTestDatum1 (p1, r) = UnitTestDatum1 p1 r +unitTestDatum2 :: (p1, p2, r) -> UnitTestDatum2 p1 p2 r +unitTestDatum2 (p1, p2, r) = UnitTestDatum2 p1 p2 r +unitTestDatum3 :: (p1, p2, p3, r) -> UnitTestDatum3 p1 p2 p3 r +unitTestDatum3 (p1, p2, p3, r) = UnitTestDatum3 p1 p2 p3 r +unitTestDatum4 :: (p1, p2, p3, p4, r) -> UnitTestDatum4 p1 p2 p3 p4 r +unitTestDatum4 (p1, p2, p3, p4, r) = UnitTestDatum4 p1 p2 p3 p4 r + +unitTestData1 :: [(p1, r)] -> UnitTestData1 p1 r +unitTestData1 = fmap unitTestDatum1 +unitTestData2 :: [(p1, p2, r)] -> UnitTestData2 p1 p2 r +unitTestData2 = fmap unitTestDatum2 +unitTestData3 :: [(p1, p2, p3, r)] -> UnitTestData3 p1 p2 p3 r +unitTestData3 = fmap unitTestDatum3 +unitTestData4 :: [(p1, p2, p3, p4, r)] -> UnitTestData4 p1 p2 p3 p4 r +unitTestData4 = fmap unitTestDatum4 + +instance Show p1 => + IsUnitTestDatum (UnitTestDatum1 p1 r) (p1 -> r) r + where + params (UnitTestDatum1 p1 _) = [show p1] + resultActual f (UnitTestDatum1 p1 _) = f p1 + resultExpected (UnitTestDatum1 _ r) = r + +instance (Show p1, Show p2) => + IsUnitTestDatum (UnitTestDatum2 p1 p2 r) (p1 -> p2 -> r) r + where + params (UnitTestDatum2 p1 p2 _) = [show p1, show p2] + resultActual f (UnitTestDatum2 p1 p2 _) = f p1 p2 + resultExpected (UnitTestDatum2 _ _ r) = r + +instance (Show p1, Show p2, Show p3) => + IsUnitTestDatum (UnitTestDatum3 p1 p2 p3 r) (p1 -> p2 -> p3 -> r) r + where + params (UnitTestDatum3 p1 p2 p3 _) = [show p1, show p2, show p3] + resultActual f (UnitTestDatum3 p1 p2 p3 _) = f p1 p2 p3 + resultExpected (UnitTestDatum3 _ _ _ r) = r + +instance (Show p1, Show p2, Show p3, Show p4) => + IsUnitTestDatum (UnitTestDatum4 p1 p2 p3 p4 r) (p1 -> p2 -> p3 -> p4 -> r) r + where + params (UnitTestDatum4 p1 p2 p3 p4 _) = [show p1, show p2, show p3, show p4] + resultActual f (UnitTestDatum4 p1 p2 p3 p4 _) = f p1 p2 p3 p4 + resultExpected (UnitTestDatum4 _ _ _ _ r) = r + +unitTestSpec + :: forall d f r. (IsUnitTestDatum d f r, Eq r, Show r) + => String + -> String + -> f + -> [d] + -> Spec +unitTestSpec specDescription functionName function = + describe specDescription . mapM_ unitTest + where + unitTest :: d -> Spec + unitTest d = it description + $ property + $ counterexample counterexampleText + $ resultExpected d == resultActual function d + where + counterexampleText = unlines + [ "" + , "expected" + , "/=" + , "actual" + , "" + , showWrap (resultExpected d) + , "/=" + , showWrap (resultActual function d) + ] + description = unwords + [ functionName + , unwords (params d <&> \s -> "(" <> s <> ")") + ] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +showWrap :: Show a => a -> String +showWrap x + | singleLineMaxLengthExceeded = + multiLine + | otherwise = + singleLine + where + multiLine = ppShow x + singleLine = show x + singleLineMaxLength = 80 + singleLineMaxLengthExceeded = F.length singleLine > singleLineMaxLength diff --git a/components/monoidmap-test/Test/Key.hs b/components/monoidmap-test/Test/Key.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Test/Key.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Quasi-unique keys. +-- +module Test.Key + ( Key1 + , Key2 + , Key4 + , Key8 + ) +where + +import Prelude + +import GHC.Generics + ( Generic + ) +import GHC.TypeLits + ( Nat + ) +import Test.QuickCheck + ( Arbitrary + , CoArbitrary + , Function + ) +import Test.QuickCheck.Quid + ( Latin (Latin) + , Quid + , Size (Size) + ) + +newtype Key (size :: Nat) = Key Quid + deriving stock (Eq, Generic, Ord) + deriving (Read, Show) via Latin Quid + deriving (Arbitrary) via Size size Quid + deriving (CoArbitrary) via Quid + deriving anyclass (Function) + +type Key1 = Key 1 +type Key2 = Key 2 +type Key4 = Key 4 +type Key8 = Key 8 diff --git a/components/monoidmap-test/Test/QuickCheck/Classes/Hspec.hs b/components/monoidmap-test/Test/QuickCheck/Classes/Hspec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-test/Test/QuickCheck/Classes/Hspec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE PolyKinds #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides testing functions to check that type class instances obey laws. +-- +module Test.QuickCheck.Classes.Hspec + ( testLaws + , testLawsMany + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Proxy + ( Proxy (..) ) +import Data.Typeable + ( Typeable, typeRep ) +import Test.Hspec + ( Spec, describe, it, parallel ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-- | Constructs a test to check that the given type class instance obeys the +-- given set of laws. +-- +-- Example usage: +-- +-- >>> testLaws @Natural ordLaws +-- >>> testLaws @(Map Int) functorLaws +-- +testLaws + :: forall a. Typeable a + => (Proxy a -> Laws) + -> Spec +testLaws getLaws = + parallel $ describe description $ + forM_ (lawsProperties laws) $ uncurry it + where + description = mconcat + [ "Testing " + , lawsTypeclass laws + , " laws for type " + , show (typeRep $ Proxy @a) + ] + laws = getLaws $ Proxy @a + +-- | Calls `testLaws` with multiple sets of laws. +-- +-- Example usage: +-- +-- >>> testLawsMany @Natural [eqLaws, ordLaws] +-- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws] +-- +testLawsMany + :: forall a. Typeable a + => [Proxy a -> Laws] + -> Spec +testLawsMany getLawsMany = + testLaws @a `mapM_` getLawsMany diff --git a/components/monoidmap/Data/MonoidMap.hs b/components/monoidmap/Data/MonoidMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap/Data/MonoidMap.hs @@ -0,0 +1,411 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | +-- Copyright: © 2022–2025 Jonathan Knowles +-- License: Apache-2.0 +-- +module Data.MonoidMap + ( + -- * Introduction + -- $_introduction + -- $_totality + -- $_encoding + -- $_monoidal_operations + + -- * Type + MonoidMap + + -- * General operations + + -- ** Construction + , empty + , fromList + , fromListWith + , fromMap + , fromMapWith + , fromSet + , singleton + + -- ** Deconstruction + , toList + , toMap + + -- ** Lookup + , get + + -- ** Modification + , set + , adjust + , nullify + + -- ** Membership + , null + , nullKey + , nonNull + , nonNullCount + , nonNullKey + , nonNullKeys + + -- ** Slicing + , take + , drop + , splitAt + + -- ** Filtering + , filter + , filterKeys + , filterWithKey + + -- ** Partitioning + , partition + , partitionKeys + , partitionWithKey + + -- ** Mapping + , map + , mapKeys + , mapKeysWith + , mapWithKey + + -- ** Folding + , foldl + , foldl' + , foldr + , foldr' + , foldlWithKey + , foldlWithKey' + , foldrWithKey + , foldrWithKey' + , foldMapWithKey + , foldMapWithKey' + + -- ** Traversal + , traverse + , traverseWithKey + , mapAccumL + , mapAccumLWithKey + , mapAccumR + , mapAccumRWithKey + + -- * Monoidal operations + + -- | See the section on [monoidal operations](#_monoidal_operations) within + -- the [introduction](#_introduction). + + -- ** Association + , append + + -- ** Subtraction + , minus + , minusMaybe + , monus + + -- ** Inversion + , invert + + -- ** Exponentiation + , power + + -- ** Comparison + , isSubmapOf + , isSubmapOfBy + , disjoint + , disjointBy + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithA + + -- ** Union + , union + , unionWith + , unionWithA + + -- ** Prefixes + , isPrefixOf + , stripPrefix + , commonPrefix + , stripCommonPrefix + + -- ** Suffixes + , isSuffixOf + , stripSuffix + , commonSuffix + , stripCommonSuffix + + -- ** Overlap + , overlap + , stripPrefixOverlap + , stripSuffixOverlap + , stripOverlap + ) + where + +import Data.MonoidMap.Internal + +-- Imports for module documentation: + +import Data.Eq + ( Eq (..) ) +import Data.Group + ( Group ((~~)) ) +import Data.Map.Strict + ( Map ) +import Data.Maybe + ( Maybe (Just, Nothing) ) +import Data.Monoid + ( Monoid (mempty) ) +import Data.Monoid.GCD + ( GCDMonoid ) +import Data.Monoid.LCM + ( LCMMonoid ) +import Data.Monoid.Monus + ( Monus ((<\>)) ) +import Data.Monoid.Null + ( MonoidNull ) +import Data.Ord + ( Ord ) +import Data.Semigroup + ( Semigroup ((<>)) ) + +import qualified Data.Map.Strict as SMap +import qualified Data.MonoidMap.Internal as MMap + +import qualified Data.Group as C +import qualified Data.Monoid.GCD as C +import qualified Data.Monoid.LCM as C +import qualified Data.Monoid.Null as C + +-------------------------------------------------------------------------------- +-- Introduction +-------------------------------------------------------------------------------- + +-- $_introduction +-- #_introduction# +-- +-- This module provides the 'MonoidMap' type, which: +-- +-- - models a [__total function__](#_totality) with +-- [__finite support__](https://wikipedia.org/wiki/Support_\(mathematics\)) +-- from keys to [__monoidal values__]("Data.Monoid"), with a default value +-- of 'mempty'. +-- +-- - encodes key-value mappings with a [__minimal encoding__](#_encoding) that +-- only includes values /not/ equal to 'mempty'. +-- +-- - provides a comprehensive set of +-- [__monoidal operations__](#_monoidal_operations) for transforming, +-- combining, and comparing maps. +-- +-- The documentation in this module serves as __reference guide__ to the +-- 'MonoidMap' type and its operations. +-- +-- See the +-- [@README@](https://github.com/jonathanknowles/monoidmap/blob/main/README.md) +-- file for: +-- +-- - a __deeper introduction__ to the design of the 'MonoidMap' type. +-- +-- - worked examples of using 'MonoidMap' to implement more specialised +-- monoidal data structures. +-- +-- - detailed comparisons between 'MonoidMap' and other map types. + +-------------------------------------------------------------------------------- +-- Totality +-------------------------------------------------------------------------------- + +-- $_totality +-- #_totality# +-- +-- = Relationship between keys and values +-- +-- A 'MonoidMap' of key type __@k@__ and value type __@v@__ associates /every/ +-- possible key of type __@k@__ with a value of type __@v@__: +-- +-- @ +-- 'get' :: ('Ord' k, 'Monoid' v) => k -> 'MonoidMap' k v -> v +-- @ +-- +-- The 'empty' map associates every key __@k@__ with a default value of +-- 'mempty': +-- +-- @ +-- ∀ k. 'get' k 'empty' '==' 'mempty' +-- @ +-- +-- == Comparison with standard 'Map' type +-- +-- The 'MonoidMap' type differs from the standard 'Map' type in how it relates +-- keys to values: +-- +-- +---------------------------+---------------------------------------------+ +-- | Type | Models a total function with finite support | +-- +===========================+=============================================+ +-- | @       'Map'@__@ k v @__ | from keys of type __@k@__ | +-- | | to values of type __@'Maybe' v@__. | +-- +---------------------------+---------------------------------------------+ +-- | @ 'MonoidMap'@__@ k v @__ | from keys of type __@k@__ | +-- | | to values of type __@v@__. | +-- +---------------------------+---------------------------------------------+ +-- +-- This difference can be illustrated by comparing the type signatures of +-- operations to query a key for its value, for both types: +-- +-- @ +-- 'Map'.'SMap.lookup' :: \ \ k -> 'Map' k v -> 'Maybe' v +-- 'MonoidMap'.'MMap.get' :: 'Monoid' v => k -> 'MonoidMap' k v -> \ \ v +-- @ +-- +-- Whereas a standard 'Map' has a default value of 'Nothing', a 'MonoidMap' has +-- a default value of 'mempty': +-- +-- @ +-- ∀ k. 'Map'.'SMap.lookup' k 'Map'.'SMap.empty' '==' 'Nothing' +-- ∀ k. 'MonoidMap'.'MMap.get' k 'MonoidMap'.'MMap.empty' '==' 'mempty' +-- @ +-- +-- In practice, the standard 'Map' type uses 'Maybe' to indicate the /presence/ +-- or /absence/ of a value for a particular key. This representation is +-- necessary because the 'Map' type imposes no constraints on value types. +-- +-- However, /monoidal/ types already have a natural way to represent null or +-- empty values: the 'mempty' constant, which represents the /neutral/ or +-- /identity/ element of a 'Monoid'. +-- +-- Consequently, using a standard 'Map' with a /monoidal/ value type gives rise +-- to two distinct representations for null or empty values: +-- +-- +-------------------------+--------------------------------------------+ +-- | @ | | +-- | 'Map'.'SMap.lookup' k m | Interpretation | +-- | @ | | +-- +=========================+============================================+ +-- | @ | 'Map' __@m@__ has /no/ entry | +-- | 'Nothing' | for key __@k@__. | +-- | @ | | +-- +-------------------------+--------------------------------------------+ +-- | @ | 'Map' __@m@__ has an entry | +-- | 'Just' 'mempty' | for key __@k@__, but the value is /empty/. | +-- | @ | | +-- +-------------------------+--------------------------------------------+ +-- +-- In constrast, the 'MonoidMap' type provides a single, /canonical/ +-- representation for null or empty values, according to the following +-- conceptual mapping: +-- +-- +------------------------------------+---+------------------------------+ +-- | @ | | @ | +-- | 'Map'.'SMap.lookup' k m | | 'MonoidMap'.'MMap.get' k m | +-- | @ | | @ | +-- +====================================+===+==============================+ +-- | @ | | @ | +-- | 'Nothing' | ⟼ | 'mempty' | +-- | @ | | @ | +-- +--------------+---------------------+---+------------------------------+ +-- | @ | @ | | @ | +-- | 'Just' __v__ | __v__ '==' 'mempty' | ⟼ | 'mempty' | +-- | @ | @ | | @ | +-- +--------------+---------------------+---+------------------------------+ +-- | @ | @ | | @ | +-- | 'Just' __v__ | __v__ '/=' 'mempty' | ⟼ | __v__ | +-- | @ | @ | | @ | +-- +--------------+---------------------+---+------------------------------+ + +-------------------------------------------------------------------------------- +-- Encoding +-------------------------------------------------------------------------------- + +-- $_encoding +-- #_encoding# +-- +-- = Encoding +-- +-- A 'MonoidMap' only encodes mappings from keys to values that are /not/ equal +-- to 'mempty'. +-- +-- The total function \(T\) modelled by a 'MonoidMap' is encoded as a +-- __support__ __map__ \(S\), where \(S\) is the finite subset of key-value +-- mappings in \(T\) for which values are not equal to 'mempty' (denoted by +-- \(\varnothing\)): +-- +-- \( \quad S = \{ (k, v) \in T \ | \ v \ne \varnothing \} \) +-- +-- == Automatic minimisation +-- +-- All 'MonoidMap' operations perform __automatic minimisation__ of the support +-- map, so that 'mempty' values do not appear in: +-- +-- - any encoding of a 'MonoidMap' +-- - any traversal of a 'MonoidMap' +-- +-- == Constraints on values +-- +-- 'MonoidMap' operations require the monoidal value type to be an instance of +-- 'MonoidNull'. +-- +-- Instances of 'MonoidNull' must provide a 'C.null' indicator function that +-- satisfies the following law: +-- +-- @ +-- ∀ v. 'MonoidNull'.'C.null' v '==' (v '==' 'mempty') +-- @ +-- +-- 'MonoidMap' operations use the 'C.null' indicator function to detect and +-- exclude 'mempty' values from the support map. +-- +-- Note that it is /not/ generally necessary for the value type to be an +-- instance of 'Eq'. + +-------------------------------------------------------------------------------- +-- Monoidal operations +-------------------------------------------------------------------------------- + +-- $_monoidal_operations +-- #_monoidal_operations# +-- +-- = Monoidal operations +-- +-- The 'MonoidMap' type provides a comprehensive set of __monoidal operations__ +-- for transforming, combining, and comparing maps. +-- +-- Instances for several __subclasses__ of 'Semigroup' and 'Monoid' are +-- provided, including classes from the following libraries: +-- +-- - [groups](https://hackage.haskell.org/package/groups) +-- - [monoid-subclasses](https://hackage.haskell.org/package/monoid-subclasses) +-- +-- At the root of this hierarchy of subclasses is the 'Semigroup' class, whose +-- instance for 'MonoidMap' is defined in terms of the /underlying value type/, +-- so that applying `(<>)` to a /pair of maps/ is equivalent to applying `(<>)` +-- to all /pairs of values/ for matching keys: +-- +-- @ +-- ∀ k. 'get' k (m1 '<>' m2) '==' 'get' k m1 '<>' 'get' k m2 +-- @ +-- +-- In general, operations for subclasses of 'Semigroup' and 'Monoid' are +-- defined /analogously/ to the 'Semigroup' instance, so that: +-- +-- - /unary/ operations on /individual maps/ are defined in terms of their +-- distributive application to all values. +-- +-- - /binary/ operations on /pairs of maps/ are defined in terms of their +-- distributive application to all /pairs of values/ for matching keys. +-- +-- Unary monoidal operations typically satisfy a property similar to: +-- +-- @ +-- ∀ k. 'get' k (f m) '==' f ('get' k m) +-- @ +-- +-- Binary monoidal operations typically satisfy a property similar to: +-- +-- @ +-- ∀ k. 'get' k (f m1 m2) '==' f ('get' k m1) ('get' k m2) +-- @ +-- +-- Defining monoidal operations in this way makes it possible to transform, +-- combine, and compare maps in ways that are consistent with the algebraic +-- properties of the underlying monoidal value type. 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.3.0 +version: 0.0.4.0 bug-reports: https://github.com/jonathanknowles/monoidmap/issues license: Apache-2.0 license-file: LICENSE @@ -40,10 +40,10 @@ build-depends:quickcheck-classes >= 0.6.5.0 && < 0.7 common dependency-quickcheck-groups build-depends:quickcheck-groups >= 0.0.0.0 && < 0.1 -common dependency-quickcheck-instances - build-depends:quickcheck-instances >= 0.3.28 && < 0.4 common dependency-quickcheck-monoid-subclasses build-depends:quickcheck-monoid-subclasses >= 0.3.0.0 && < 0.4 +common dependency-quickcheck-quid + build-depends:quickcheck-quid >= 0.0.1.7 && < 0.1 common dependency-tasty-bench build-depends:tasty-bench >= 0.3.2 && < 0.5 common dependency-tasty-hunit @@ -63,6 +63,7 @@ LambdaCase MultiParamTypeClasses NoImplicitPrelude + NumericUnderscores ScopedTypeVariables TupleSections TypeApplications @@ -81,16 +82,36 @@ , dependency-groups , dependency-monoid-subclasses , extensions + build-depends: + , monoidmap-internal hs-source-dirs: - src/public + components/monoidmap exposed-modules: Data.MonoidMap default-language: Haskell2010 + +benchmark monoidmap-benchmark + import: + , dependency-base + , dependency-containers + , dependency-deepseq + , dependency-tasty-bench + , dependency-tasty-hunit + , extensions build-depends: - , internal + , monoidmap + , monoidmap-examples + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + components/monoidmap-benchmark + main-is: + Main.hs -library examples +library monoidmap-examples import: , dependency-base , dependency-containers @@ -98,8 +119,12 @@ , dependency-monoid-subclasses , dependency-nonempty-containers , extensions + build-depends: + , monoidmap + visibility: + private hs-source-dirs: - src/examples + components/monoidmap-examples exposed-modules: Examples.MultiMap Examples.MultiMap.Class @@ -112,10 +137,8 @@ Examples.RecoveredMap default-language: Haskell2010 - build-depends: - , monoidmap -library internal +library monoidmap-internal import: , dependency-base , dependency-containers @@ -124,15 +147,17 @@ , dependency-monoid-subclasses , dependency-nothunks , extensions + visibility: + private hs-source-dirs: - src/internal + components/monoidmap-internal exposed-modules: Data.MonoidMap.Internal Data.MonoidMap.Unsafe default-language: Haskell2010 -test-suite test +test-suite monoidmap-test import: , dependency-base , dependency-containers @@ -143,16 +168,19 @@ , dependency-QuickCheck , dependency-quickcheck-classes , dependency-quickcheck-groups - , dependency-quickcheck-instances , dependency-quickcheck-monoid-subclasses + , dependency-quickcheck-quid , dependency-text , extensions + build-depends: + , monoidmap + , monoidmap-examples ghc-options: -threaded -with-rtsopts=-N main-is: Spec.hs hs-source-dirs: - src/test + components/monoidmap-test other-modules: SpecHook Data.MonoidMap.ClassSpec @@ -180,31 +208,10 @@ Test.Common Test.QuickCheck.Classes.Hspec Test.Hspec.Unit + Test.Key type: exitcode-stdio-1.0 default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover ==2.* - build-depends: - , examples - , monoidmap - -benchmark benchmark - import: - , dependency-base - , dependency-containers - , dependency-deepseq - , dependency-tasty-bench - , dependency-tasty-hunit - default-language: - Haskell2010 - type: - exitcode-stdio-1.0 - hs-source-dirs: - src/benchmark - main-is: - Main.hs - build-depends: - , examples - , monoidmap diff --git a/src/benchmark/Main.hs b/src/benchmark/Main.hs deleted file mode 100644 --- a/src/benchmark/Main.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# 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 - ( rnf ) -import Control.Exception - ( evaluate ) -import Data.Eq - ( Eq ) -import Data.Function - ( flip, ($) ) -import Data.Int - ( Int ) -import Data.List - ( foldl', zip ) -import Data.Maybe - ( Maybe, fromMaybe ) -import Data.Ord - ( Ord ) -import Data.Semigroup - ( Semigroup ((<>)), stimes ) -import Prelude - ( Integer, Num, (^), (+) ) -import System.IO - ( IO ) -import Test.Tasty.Bench - ( bench, bgroup, defaultMain, nf ) - -import qualified Data.Map.Strict as OMap -import qualified Examples.RecoveredMap as RMap - -main :: IO () -main = do - - let om_natural = fromList elems_natural :: OMap.Map Int Int - om_even = fromList elems_even :: OMap.Map Int Int - om_odd = fromList elems_odd :: OMap.Map Int Int - - rm_natural = fromList elems_natural :: RMap.Map Int Int - rm_even = fromList elems_even :: RMap.Map Int Int - rm_odd = fromList elems_odd :: RMap.Map Int Int - - evaluate $ rnf [om_natural, om_even, om_odd] - evaluate $ rnf [rm_natural, rm_even, rm_odd] - - defaultMain - [ bgroup "delete" - [ bgroup "absent" - [ bench "Data.Map.Strict" $ - nf (deleteMany evens) om_odd - , bench "RecoveredMap" $ - nf (deleteMany evens) rm_odd - ] - , bgroup "present" - [ bench "Data.Map.Strict" $ - nf (deleteMany evens) om_even - , bench "RecoveredMap" $ - nf (deleteMany evens) rm_even - ] - ] - , bgroup "insert" - [ bgroup "absent" - [ bench "Data.Map.Strict" $ - nf (insertMany elems_even) om_odd - , bench "RecoveredMap" $ - nf (insertMany elems_even) rm_odd - ] - , bgroup "present" - [ bench "Data.Map.Strict" $ - nf (insertMany elems_even) om_even - , bench "RecoveredMap" $ - nf (insertMany elems_even) rm_even - ] - ] - , bgroup "lookup" - [ bgroup "absent" - [ bench "Data.Map.Strict" $ - nf (lookupMany evens) om_odd - , bench "RecoveredMap" $ - nf (lookupMany evens) rm_odd - ] - , bgroup "present" - [ bench "Data.Map.Strict" $ - nf (lookupMany evens) om_even - , bench "RecoveredMap" $ - nf (lookupMany evens) rm_even - ] - ] - , bgroup "mappend" - [ bgroup "disjoint" - [ bench "Data.Map.Strict" $ - nf (<> om_even) om_odd - , bench "RecoveredMap" $ - nf (<> rm_even) rm_odd - ] - , bgroup "identical" - [ bench "Data.Map.Strict" $ - nf (<> om_even) om_even - , bench "RecoveredMap" $ - nf (<> rm_even) rm_even - ] - ] - , bgroup "stimes" - [ bench "Data.Map.Strict" $ - nf (stimes ten_power_24) om_natural - , 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 - bound = 2 ^ (16 :: Int) - - elems_natural :: [(Int, Int)] - elems_natural = zip naturals naturals - - elems_even :: [(Int, Int)] - elems_even = zip evens evens - - elems_odd :: [(Int, Int)] - elems_odd = zip odds odds - - naturals :: [Int] - naturals = [1 .. bound] - - evens :: [Int] - evens = [2, 4 .. bound] - - odds :: [Int] - odds = [1, 3 .. bound] - - ten_power_24 :: Integer - ten_power_24 = 1_000_000_000_000_000_000_000_000 - -class Ord k => Map m k v where - fromList :: [(k, v)] -> m k v - 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 - -insertMany :: (Map m k v, Num v) => [(k, v)] -> m k v -> m k v -insertMany xs m = foldl' (\m' (k, v) -> insert k v m') m xs - -lookupMany :: (Map m k v, Num v) => [k] -> m k v -> v -lookupMany xs m = foldl' (\n k -> fromMaybe n (lookup k m)) 0 xs diff --git a/src/examples/Examples/MultiMap.hs b/src/examples/Examples/MultiMap.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- Provides the 'MultiMap' class, which models a total relation from unique --- keys to sets of values. --- --- = Implementations --- --- The following example implementations are provided: --- --- +----------------+------------------------+---------+ --- | Implementation | Types used | Lawful? | --- +================+=============+==========+=========+ --- | 'MultiMap1' | 'Map' | 'Set' | 💥 No | --- +----------------+-------------+----------+---------+ --- | 'MultiMap2' | 'Map' | 'Set' | ✅ Yes | --- +----------------+-------------+----------+---------+ --- | 'MultiMap3' | 'Map' | 'NESet' | ✅ Yes | --- +----------------+-------------+----------+---------+ --- | 'MultiMap4' | 'MonoidMap' | 'Set' | ✅ Yes | --- +----------------+-------------+----------+---------+ --- -module Examples.MultiMap - ( MultiMap (..) - ) where - -import Data.Map.Strict - ( Map ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Set - ( Set ) -import Data.Set.NonEmpty - ( NESet ) -import Examples.MultiMap.Class - ( MultiMap (..) ) -import Examples.MultiMap.Instances.MultiMap1 - ( MultiMap1 ) -import Examples.MultiMap.Instances.MultiMap2 - ( MultiMap2 ) -import Examples.MultiMap.Instances.MultiMap3 - ( MultiMap3 ) -import Examples.MultiMap.Instances.MultiMap4 - ( MultiMap4 ) diff --git a/src/examples/Examples/MultiMap/Class.hs b/src/examples/Examples/MultiMap/Class.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap/Class.hs +++ /dev/null @@ -1,180 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- Provides the 'MultiMap' class, which models a total relation from unique --- keys to sets of values. --- -module Examples.MultiMap.Class where - -import Data.Set - ( Set ) -import Prelude hiding - ( lookup ) - --- | Models a total relation from unique keys to sets of values. --- -class (Eq (m k v), Ord k, Ord v) => MultiMap m k v where - - -- | Constructs a multimap from a list of key to value set mappings. - -- - -- Removing empty sets from the input list does not affect the result: - -- - -- > fromList ≡ fromList . filter ((/= Set.empty) . snd) - -- - fromList :: [(k, Set v)] -> m k v - - -- | Converts a multimap to a list of key to value-set mappings. - -- - -- Removing empty sets from the output list does not affect the result: - -- - -- > toList ≡ filter ((/= Set.empty) . snd) . toList - -- - -- The resulting list can be used to reconstruct the original multimap: - -- - -- > fromList . toList ≡ id - -- - toList :: m k v -> [(k, Set v)] - - -- | Constructs an empty multimap. - -- - -- > empty ≡ fromList [] - -- - empty :: m k v - - -- | Returns the set of values associated with a given key. - -- - -- > lookup k (fromList kvs) ≡ foldMap snd (filter ((== k) . fst) kvs) - -- - lookup :: k -> m k v -> Set v - - -- | Indicates whether or not a multimap is empty. - -- - -- > null m ≡ (∀ k. lookup k m == Set.empty) - -- - null :: m k v -> Bool - - -- | Indicates whether or not a multimap is non-empty. - -- - -- > nonNull m ≡ (∃ k. lookup k m /= Set.empty) - -- - nonNull :: m k v -> Bool - - -- | Returns 'True' iff. the given key is associated with a non-empty set. - -- - -- > nonNullKey k m ≡ (lookup k m /= Set.empty) - -- - nonNullKey :: k -> m k v -> Bool - - -- | Returns the set of keys that are associated with non-empty sets. - -- - -- > all (`nonNullKey` m) (nonNullKeys m) - -- - nonNullKeys :: m k v -> Set k - - -- | Indicates how many keys are associated with non-empty sets. - -- - -- > nonNullCount m ≡ Set.size (nonNullKeys m) - -- - nonNullCount :: m k v -> Int - - -- | Indicates whether or not the first map is a sub-map of the second. - -- - -- > m1 `isSubmapOf` m2 ≡ ∀ k. (lookup k m1 `Set.isSubsetOf` lookup k m2) - -- - isSubmapOf :: m k v -> m k v -> Bool - - -- | Updates the set of values associated with a given key. - -- - -- > lookup k1 (update k2 vs m) ≡ - -- > if k1 == k2 - -- > then vs - -- > else lookup k1 m - -- - update :: k -> Set v -> m k v -> m k v - - -- | Inserts values into the set of values associated with a given key. - -- - -- > lookup k1 (insert k2 vs m) ≡ - -- > if k1 == k2 - -- > then lookup k1 m `Set.union` vs - -- > else lookup k1 m - -- - insert :: k -> Set v -> m k v -> m k v - - -- | Removes values from the set of values associated with a given key. - -- - -- > lookup k1 (remove k2 vs m) ≡ - -- > if k1 == k2 - -- > then lookup k1 m `Set.difference` vs - -- > else lookup k1 m - -- - remove :: k -> Set v -> m k v -> m k v - - -- | Computes the union of two multimaps. - -- - -- Instances must satisfy the following properties: - -- - -- __/Idempotence/__ - -- - -- > union m m ≡ m - -- - -- __/Identity/__ - -- - -- > union empty m ≡ m - -- > union m empty ≡ m - -- - -- __/Commutativity/__ - -- - -- > union m1 m2 ≡ union m2 m1 - -- - -- __/Associativity/__ - -- - -- > union m1 (union m2 m3) ≡ - -- > union (union m1 m2) m3 - -- - -- __/Containment/__ - -- - -- > m1 `isSubmapOf` union m1 m2 - -- > m2 `isSubmapOf` union m1 m2 - -- - -- __/Distributivity/__ - -- - -- > lookup k (union m1 m2) ≡ Set.union (lookup k m1) - -- > (lookup k m2) - -- - union :: m k v -> m k v -> m k v - - -- | Computes the intersection of two multimaps. - -- - -- Instances must satisfy the following properties: - -- - -- __/Idempotence/__ - -- - -- > intersection m m ≡ m - -- - -- __/Identity/__ - -- - -- > intersection empty m ≡ empty - -- > intersection m empty ≡ empty - -- - -- __/Commutativity/__ - -- - -- > intersection m1 m2 ≡ intersection m2 m1 - -- - -- __/Associativity/__ - -- - -- > intersection m1 (intersection m2 m3) ≡ - -- > intersection (intersection m1 m2) m3 - -- - -- __/Containment/__ - -- - -- > intersection m1 m2 `isSubmapOf` m1 - -- > intersection m1 m2 `isSubmapOf` m2 - -- - -- __/Distributivity/__ - -- - -- > lookup k (intersection m1 m2) ≡ Set.intersection (lookup k m1) - -- > (lookup k m2) - -- - intersection :: m k v -> m k v -> m k v diff --git a/src/examples/Examples/MultiMap/Instances/MultiMap1.hs b/src/examples/Examples/MultiMap/Instances/MultiMap1.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap/Instances/MultiMap1.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- An __unlawful__ implementation of 'MultiMap', implemented in terms of 'Map' --- and 'Set'. --- --- This implementation has several subtle bugs. 💥 --- -module Examples.MultiMap.Instances.MultiMap1 where - -import Prelude - -import Data.Map.Strict - ( Map ) -import Data.Set - ( Set ) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Examples.MultiMap.Class as Class - -newtype MultiMap1 k v = MultiMap (Map k (Set v)) - deriving stock (Eq, Show) - -instance (Ord k, Ord v) => Class.MultiMap MultiMap1 k v where - - fromList = MultiMap . Map.fromList - - toList (MultiMap m) = Map.toList m - - empty = MultiMap Map.empty - - lookup k (MultiMap m) = Map.findWithDefault Set.empty k m - - null (MultiMap m) = Map.null m - - nonNull (MultiMap m) = not (Map.null m) - - nonNullKey k (MultiMap m) = Map.member k m - - nonNullKeys (MultiMap m) = Map.keysSet m - - nonNullCount (MultiMap m) = Map.size m - - isSubmapOf (MultiMap m1) (MultiMap m2) = - Map.isSubmapOfBy Set.isSubsetOf m1 m2 - - update k vs (MultiMap m) = MultiMap (Map.insert k vs m) - - insert k vs (MultiMap m) = MultiMap $ - Map.insert k (Map.findWithDefault Set.empty k m `Set.union` vs) m - - remove k vs (MultiMap m) = MultiMap $ - Map.insert k (Map.findWithDefault Set.empty k m `Set.difference` vs) m - - union (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.unionWith Set.union m1 m2 - - intersection (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.intersectionWith Set.intersection m1 m2 diff --git a/src/examples/Examples/MultiMap/Instances/MultiMap2.hs b/src/examples/Examples/MultiMap/Instances/MultiMap2.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap/Instances/MultiMap2.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and --- 'Set'. --- -module Examples.MultiMap.Instances.MultiMap2 where - -import Prelude - -import Data.Map.Strict - ( Map ) -import Data.Set - ( Set ) - -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Examples.MultiMap.Class as Class - -newtype MultiMap2 k v = MultiMap (Map k (Set v)) - deriving stock (Eq, Show) - -instance (Ord k, Ord v) => Class.MultiMap MultiMap2 k v where - - fromList = MultiMap . Map.fromListWith (<>) . filter ((/= mempty) . snd) - - toList (MultiMap m) = Map.toList m - - empty = MultiMap Map.empty - - lookup k (MultiMap m) = Map.findWithDefault Set.empty k m - - null (MultiMap m) = Map.null m - - nonNull (MultiMap m) = not (Map.null m) - - nonNullKey k (MultiMap m) = Map.member k m - - nonNullKeys (MultiMap m) = Map.keysSet m - - nonNullCount (MultiMap m) = Map.size m - - isSubmapOf (MultiMap m1) (MultiMap m2) = - Map.isSubmapOfBy Set.isSubsetOf m1 m2 - - update k vs (MultiMap m) - | Set.null vs = MultiMap (Map.delete k m) - | otherwise = MultiMap (Map.insert k vs m) - - insert k vs (MultiMap m) - | Set.null xs = MultiMap (Map.delete k m) - | otherwise = MultiMap (Map.insert k xs m) - where - xs = Map.findWithDefault Set.empty k m `Set.union` vs - - remove k vs (MultiMap m) - | Set.null xs = MultiMap (Map.delete k m) - | otherwise = MultiMap (Map.insert k xs m) - where - xs = Map.findWithDefault Set.empty k m `Set.difference` vs - - union (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.unionWith Set.union m1 m2 - - intersection (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.merge - Map.dropMissing - Map.dropMissing - (Map.zipWithMaybeMatched mergeValues) - m1 - m2 - where - mergeValues :: k -> Set v -> Set v -> Maybe (Set v) - mergeValues _k s1 s2 - | Set.null s3 = Nothing - | otherwise = Just s3 - where - s3 = Set.intersection s1 s2 diff --git a/src/examples/Examples/MultiMap/Instances/MultiMap3.hs b/src/examples/Examples/MultiMap/Instances/MultiMap3.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap/Instances/MultiMap3.hs +++ /dev/null @@ -1,85 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and --- 'NESet'. --- -module Examples.MultiMap.Instances.MultiMap3 where - -import Prelude - -import Data.Map.Strict - ( Map ) -import Data.Maybe - ( mapMaybe ) -import Data.Set.NonEmpty - ( NESet ) - -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Set.NonEmpty as NESet -import qualified Examples.MultiMap.Class as Class - -newtype MultiMap3 k v = MultiMap (Map k (NESet v)) - deriving stock (Eq, Show) - -instance (Ord k, Ord v) => Class.MultiMap MultiMap3 k v where - - fromList - = MultiMap - . Map.fromListWith (<>) - . mapMaybe (traverse NESet.nonEmptySet) - - toList (MultiMap m) = fmap NESet.toSet <$> Map.toList m - - empty = MultiMap Map.empty - - lookup k (MultiMap m) = maybe Set.empty NESet.toSet (Map.lookup k m) - - null (MultiMap m) = Map.null m - - nonNull (MultiMap m) = not (Map.null m) - - nonNullKey k (MultiMap m) = Map.member k m - - nonNullKeys (MultiMap m) = Map.keysSet m - - nonNullCount (MultiMap m) = Map.size m - - isSubmapOf (MultiMap m1) (MultiMap m2) = - Map.isSubmapOfBy NESet.isSubsetOf m1 m2 - - update k vs (MultiMap m) = - case NESet.nonEmptySet vs of - Nothing -> MultiMap (Map.delete k m) - Just ys -> MultiMap (Map.insert k ys m) - - insert k vs (MultiMap m) = - case NESet.nonEmptySet xs of - Nothing -> MultiMap (Map.delete k m) - Just ys -> MultiMap (Map.insert k ys m) - where - xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.union` vs - - remove k vs (MultiMap m) = - case NESet.nonEmptySet xs of - Nothing -> MultiMap (Map.delete k m) - Just ys -> MultiMap (Map.insert k ys m) - where - xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.difference` vs - - union (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.unionWith NESet.union m1 m2 - - intersection (MultiMap m1) (MultiMap m2) = MultiMap $ - Map.merge - Map.dropMissing - Map.dropMissing - (Map.zipWithMaybeMatched mergeValues) - m1 - m2 - where - mergeValues :: Ord v => k -> NESet v -> NESet v -> Maybe (NESet v) - mergeValues _k s1 s2 = NESet.nonEmptySet (NESet.intersection s1 s2) diff --git a/src/examples/Examples/MultiMap/Instances/MultiMap4.hs b/src/examples/Examples/MultiMap/Instances/MultiMap4.hs deleted file mode 100644 --- a/src/examples/Examples/MultiMap/Instances/MultiMap4.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- A __lawful__ implementation of 'MultiMap', implemented in terms of --- 'MonoidMap' and 'Set'. --- -module Examples.MultiMap.Instances.MultiMap4 where - -import Prelude - -import Data.MonoidMap - ( MonoidMap ) -import Data.Set - ( Set ) - -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set -import qualified Examples.MultiMap.Class as Class - -newtype MultiMap4 k v = MultiMap (MonoidMap k (Set v)) - deriving stock (Eq, Show) - -instance (Ord k, Ord v) => Class.MultiMap MultiMap4 k v where - - fromList = MultiMap . MonoidMap.fromListWith (<>) - - toList (MultiMap m) = MonoidMap.toList m - - empty = MultiMap MonoidMap.empty - - lookup k (MultiMap m) = MonoidMap.get k m - - null (MultiMap m) = MonoidMap.null m - - nonNull (MultiMap m) = MonoidMap.nonNull m - - nonNullKey k (MultiMap m) = MonoidMap.nonNullKey k m - - nonNullKeys (MultiMap m) = MonoidMap.nonNullKeys m - - nonNullCount (MultiMap m) = MonoidMap.nonNullCount m - - isSubmapOf (MultiMap m1) (MultiMap m2) = m1 `MonoidMap.isSubmapOf` m2 - - update k vs (MultiMap m) = - MultiMap (MonoidMap.set k vs m) - - insert k vs (MultiMap m) = - MultiMap (MonoidMap.adjust (`Set.union` vs) k m) - - remove k vs (MultiMap m) = - MultiMap (MonoidMap.adjust (`Set.difference` vs) k m) - - union (MultiMap m1) (MultiMap m2) = - MultiMap (MonoidMap.union m1 m2) - - intersection (MultiMap m1) (MultiMap m2) = - MultiMap (MonoidMap.intersection m1 m2) diff --git a/src/examples/Examples/MultiSet.hs b/src/examples/Examples/MultiSet.hs deleted file mode 100644 --- a/src/examples/Examples/MultiSet.hs +++ /dev/null @@ -1,156 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- A multiset type, implemented in terms of 'MonoidMap'. --- --- See: https://en.wikipedia.org/wiki/Multiset --- -module Examples.MultiSet - ( fromList - , toList - , null - , member - , multiplicity - , root - , cardinality - , dimension - , height - , isSubsetOf - , intersection - , union - , disjointUnion - , add - , subtract - , subtractMaybe - ) - where - -import Prelude hiding - ( null, subtract ) - -import Data.Function - ( on ) -import Data.Monoid - ( Sum (..) ) -import Data.Monoid.GCD - ( DistributiveGCDMonoid - , GCDMonoid - , LeftDistributiveGCDMonoid - , LeftGCDMonoid - , OverlappingGCDMonoid - , RightDistributiveGCDMonoid - , RightGCDMonoid - ) -import Data.Monoid.LCM - ( DistributiveLCMMonoid, LCMMonoid ) -import Data.Monoid.Monus - ( Monus ((<\>)) ) -import Data.Monoid.Null - ( MonoidNull, PositiveMonoid ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Semigroup.Cancellative - ( Cancellative - , Commutative - , LeftCancellative - , LeftReductive - , Reductive (()) - , RightCancellative - , RightReductive - ) -import Data.Set - ( Set ) -import Numeric.Natural - ( Natural ) -import Text.Read - ( Read (..) ) - -import qualified Data.Foldable as F -import qualified Data.MonoidMap as MonoidMap - -newtype MultiSet a = MultiSet - { unMultiSet :: MonoidMap a (Sum Natural) - } - deriving newtype - ( Eq - , Semigroup - , Commutative - , Monoid - , MonoidNull - , PositiveMonoid - , LeftReductive - , LeftCancellative - , LeftGCDMonoid - , LeftDistributiveGCDMonoid - , RightReductive - , RightCancellative - , RightGCDMonoid - , RightDistributiveGCDMonoid - , Reductive - , Cancellative - , GCDMonoid - , LCMMonoid - , DistributiveGCDMonoid - , DistributiveLCMMonoid - , OverlappingGCDMonoid - , Monus - ) - -instance (Ord a, Read a) => Read (MultiSet a) where - readPrec = fromList <$> readPrec - -instance Show a => Show (MultiSet a) where - show = show . toList - -fromList :: Ord a => [(a, Natural)] -> MultiSet a -fromList = MultiSet . MonoidMap.fromList . fmap (fmap Sum) - -toList :: MultiSet a -> [(a, Natural)] -toList = fmap (fmap getSum) . MonoidMap.toList . unMultiSet - -null :: MultiSet a -> Bool -null = MonoidMap.null . unMultiSet - -member :: Ord a => a -> MultiSet a -> Bool -member a = MonoidMap.nonNullKey a . unMultiSet - -multiplicity :: Ord a => a -> MultiSet a -> Natural -multiplicity a = getSum . MonoidMap.get a . unMultiSet - -root :: Ord a => MultiSet a -> Set a -root = MonoidMap.nonNullKeys . unMultiSet - -cardinality :: MultiSet a -> Natural -cardinality = getSum . F.fold . unMultiSet - -dimension :: MultiSet a -> Natural -dimension = fromIntegral . MonoidMap.nonNullCount . unMultiSet - -height :: Ord a => MultiSet a -> Natural -height s - | null s = 0 - | otherwise = getSum $ F.maximum $ unMultiSet s - -isSubsetOf :: Ord a => MultiSet a -> MultiSet a -> Bool -isSubsetOf = MonoidMap.isSubmapOf `on` unMultiSet - -intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -intersection (MultiSet s1) (MultiSet s2) = - MultiSet (MonoidMap.intersection s1 s2) - -union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -union (MultiSet s1) (MultiSet s2) = - MultiSet (MonoidMap.union s1 s2) - -disjointUnion :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -disjointUnion m1 m2 = (m1 <\> m2) <> (m2 <\> m1) - -add :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -add = (<>) - -subtract :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -subtract = (<\>) - -subtractMaybe :: Ord a => MultiSet a -> MultiSet a -> Maybe (MultiSet a) -subtractMaybe = () diff --git a/src/examples/Examples/NestedMonoidMap.hs b/src/examples/Examples/NestedMonoidMap.hs deleted file mode 100644 --- a/src/examples/Examples/NestedMonoidMap.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- A nested map with compound keys, implemented in terms of 'MonoidMap'. --- -module Examples.NestedMonoidMap - ( - -- * Type - NestedMonoidMap - - -- * Construction - , fromFlatList - , fromFlatMap - , fromNestedList - , fromNestedMap - - -- * Deconstruction - , toFlatList - , toFlatMap - , toNestedList - , toNestedMap - - -- * Basic operations - , get - , set - , adjust - , nullify - - -- * Membership - , nonNullCount - , nonNullKey - , nonNullKeys - - -- * Intersection - , intersection - , intersectionWith - - -- * Union - , union - , unionWith - - -- * Comparison - , isSubmapOf - , isSubmapOfBy - , disjoint - , disjointBy - ) - where - -import Prelude - -import Data.Map.Strict - ( Map ) -import Data.Monoid - ( Sum (..) ) -import Data.Monoid.GCD - ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) -import Data.Monoid.LCM - ( LCMMonoid ) -import Data.Monoid.Monus - ( Monus ) -import Data.Monoid.Null - ( MonoidNull, PositiveMonoid ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Semigroup.Cancellative - ( Cancellative - , Commutative - , LeftCancellative - , LeftReductive - , Reductive - , RightCancellative - , RightReductive - ) -import Data.Set - ( Set ) -import GHC.Exts - ( IsList (..) ) - -import qualified Data.Foldable as F -import qualified Data.Map.Strict as Map -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - --------------------------------------------------------------------------------- --- Type --------------------------------------------------------------------------------- - -newtype NestedMonoidMap k1 k2 v = - NestedMonoidMap (MonoidMap k1 (MonoidMap k2 v)) - deriving stock Eq - deriving newtype - ( Cancellative - , Commutative - , GCDMonoid - , LCMMonoid - , LeftCancellative - , LeftGCDMonoid - , LeftReductive - , Monoid - , MonoidNull - , Monus - , OverlappingGCDMonoid - , PositiveMonoid - , Reductive - , RightCancellative - , RightGCDMonoid - , RightReductive - , Semigroup - , Show - ) - --------------------------------------------------------------------------------- --- Construction --------------------------------------------------------------------------------- - -fromFlatList - :: (Ord k1, Ord k2, MonoidNull v) - => [((k1, k2), v)] - -> NestedMonoidMap k1 k2 v -fromFlatList = F.foldl' acc mempty - where - acc m ((k1, k2), v) = adjust (<> v) k1 k2 m - -fromFlatMap - :: (Ord k1, Ord k2, MonoidNull v) - => Map (k1, k2) v - -> NestedMonoidMap k1 k2 v -fromFlatMap = fromFlatList . Map.toList - -fromNestedList - :: (Ord k1, Ord k2, MonoidNull v) - => [(k1, [(k2, v)])] - -> NestedMonoidMap k1 k2 v -fromNestedList entries = - fromFlatList [((k1, k2), v) | (k1, n) <- entries, (k2, v) <- n] - -fromNestedMap - :: (Ord k2, MonoidNull v) - => Map k1 (Map k2 v) - -> NestedMonoidMap k1 k2 v -fromNestedMap = NestedMonoidMap . MonoidMap.fromMap . fmap MonoidMap.fromMap - --------------------------------------------------------------------------------- --- Deconstruction --------------------------------------------------------------------------------- - -toFlatList - :: (Ord k1, Ord k2, MonoidNull v) - => NestedMonoidMap k1 k2 v - -> [((k1, k2), v)] -toFlatList m = [((k1, k2), v) | (k1, n) <- toNestedList m, (k2, v) <- toList n] - -toFlatMap - :: (Ord k1, Ord k2, MonoidNull v) - => NestedMonoidMap k1 k2 v - -> Map (k1, k2) v -toFlatMap = Map.fromList . toFlatList - -toNestedList - :: (Ord k1, Ord k2, MonoidNull v) - => NestedMonoidMap k1 k2 v - -> [(k1, [(k2, v)])] -toNestedList (NestedMonoidMap m) = fmap toList <$> toList m - -toNestedMap - :: NestedMonoidMap k1 k2 v - -> Map k1 (Map k2 v) -toNestedMap (NestedMonoidMap m) = MonoidMap.toMap <$> MonoidMap.toMap m - --------------------------------------------------------------------------------- --- Basic operations --------------------------------------------------------------------------------- - -get :: (Ord k1, Ord k2, MonoidNull v) - => k1 - -> k2 - -> NestedMonoidMap k1 k2 v - -> v -get k1 k2 (NestedMonoidMap m) = MonoidMap.get k2 (MonoidMap.get k1 m) - -set :: (Ord k1, Ord k2, MonoidNull v) - => k1 - -> k2 - -> v - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -set k1 k2 v (NestedMonoidMap m) = - NestedMonoidMap $ MonoidMap.adjust (MonoidMap.set k2 v) k1 m - -adjust - :: (Ord k1, Ord k2, MonoidNull v) - => (v -> v) - -> k1 - -> k2 - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -adjust f k1 k2 (NestedMonoidMap m) = - NestedMonoidMap $ MonoidMap.adjust (MonoidMap.adjust f k2) k1 m - -nullify - :: (Ord k1, Ord k2, MonoidNull v) - => k1 - -> k2 - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -nullify k1 k2 (NestedMonoidMap m) = - NestedMonoidMap $ MonoidMap.adjust (MonoidMap.nullify k2) k1 m - --------------------------------------------------------------------------------- --- Membership --------------------------------------------------------------------------------- - -nonNullCount :: NestedMonoidMap k1 k2 v -> Int -nonNullCount (NestedMonoidMap m) = - getSum $ F.foldMap (Sum . MonoidMap.nonNullCount) m - -nonNullKey - :: (Ord k1, Ord k2, MonoidNull v) - => k1 - -> k2 - -> NestedMonoidMap k1 k2 v - -> Bool -nonNullKey k1 k2 (NestedMonoidMap m) = - MonoidMap.nonNullKey k2 (MonoidMap.get k1 m) - -nonNullKeys - :: (Ord k1, Ord k2, MonoidNull v) - => NestedMonoidMap k1 k2 v - -> Set (k1, k2) -nonNullKeys = Set.fromList . fmap fst . toFlatList - --------------------------------------------------------------------------------- --- Intersection --------------------------------------------------------------------------------- - -intersection - :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) - => NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -intersection (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ - MonoidMap.intersection m1 m2 - -intersectionWith - :: (Ord k1, Ord k2, MonoidNull v) - => (v -> v -> v) - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -intersectionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ - MonoidMap.intersectionWith (MonoidMap.intersectionWith f) m1 m2 - --------------------------------------------------------------------------------- --- Union --------------------------------------------------------------------------------- - -union - :: (Ord k1, Ord k2, MonoidNull v, LCMMonoid v) - => NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -union (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ - MonoidMap.union m1 m2 - -unionWith - :: (Ord k1, Ord k2, MonoidNull v) - => (v -> v -> v) - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v -unionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $ - MonoidMap.unionWith (MonoidMap.unionWith f) m1 m2 - --------------------------------------------------------------------------------- --- Comparison --------------------------------------------------------------------------------- - -isSubmapOf - :: (Ord k1, Ord k2, MonoidNull v, Reductive v) - => NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> Bool -isSubmapOf (NestedMonoidMap m1) (NestedMonoidMap m2) = - MonoidMap.isSubmapOf m1 m2 - -isSubmapOfBy - :: (Ord k1, Ord k2, MonoidNull v, Reductive v) - => (v -> v -> Bool) - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> Bool -isSubmapOfBy f (NestedMonoidMap m1) (NestedMonoidMap m2) = - MonoidMap.isSubmapOfBy (MonoidMap.isSubmapOfBy f) m1 m2 - -disjoint - :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) - => NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> Bool -disjoint (NestedMonoidMap m1) (NestedMonoidMap m2) = - MonoidMap.disjoint m1 m2 - -disjointBy - :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v) - => (v -> v -> Bool) - -> NestedMonoidMap k1 k2 v - -> NestedMonoidMap k1 k2 v - -> Bool -disjointBy f (NestedMonoidMap m1) (NestedMonoidMap m2) = - MonoidMap.disjointBy (MonoidMap.disjointBy f) m1 m2 diff --git a/src/examples/Examples/RecoveredMap.hs b/src/examples/Examples/RecoveredMap.hs deleted file mode 100644 --- a/src/examples/Examples/RecoveredMap.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- An ordinary left-biased map similar to 'Map', implemented in terms of --- 'MonoidMap'. --- -module Examples.RecoveredMap - ( Map - , empty - , singleton - , fromList - , toList - , delete - , insert - , keysSet - , lookup - , member - , map - , mapWithKey - , mapAccumL - , mapAccumLWithKey - , mapAccumR - , mapAccumRWithKey - ) - where - -import Prelude hiding - ( lookup, map ) - -import Control.DeepSeq - ( NFData ) -import Data.Coerce - ( coerce ) -import Data.Maybe - ( mapMaybe ) -import Data.Monoid - ( First (..) ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Semigroup - ( Semigroup (stimes), stimesIdempotentMonoid ) -import Data.Set - ( Set ) - -import qualified Data.MonoidMap as MonoidMap - -newtype Map k v = Map - -- 'First' is used to mimic the left-biased nature of 'Data.Map': - {unMap :: MonoidMap k (First v)} - deriving newtype (Eq, NFData, Monoid) - -instance Ord k => Semigroup (Map k v) where - (<>) = coerce @(MonoidMap k (First v) -> _ -> _) (<>) - stimes = stimesIdempotentMonoid - -instance (Show k, Show v) => Show (Map k v) where - show = ("fromList " <>) . show . toList - -instance Functor (Map k) where - fmap = map - -empty :: Map k v -empty = Map MonoidMap.empty - -singleton :: Ord k => k -> v -> Map k v -singleton k = Map . MonoidMap.singleton k . pure - -fromList :: Ord k => [(k, v)] -> Map k v -fromList = Map . MonoidMap.fromListWith (const id) . fmap (fmap pure) - -toList :: Map k v -> [(k, v)] -toList = mapMaybe (getFirst . sequenceA) . MonoidMap.toList . unMap - -delete :: Ord k => k -> Map k v -> Map k v -delete k = Map . MonoidMap.nullify k . unMap - -insert :: Ord k => k -> v -> Map k v -> Map k v -insert k v = Map . MonoidMap.set k (pure v) . unMap - -keysSet :: Map k v -> Set k -keysSet = MonoidMap.nonNullKeys . unMap - -lookup :: Ord k => k -> Map k v -> Maybe v -lookup k = getFirst . MonoidMap.get k . unMap - -member :: Ord k => k -> Map k v -> Bool -member k = MonoidMap.nonNullKey k . unMap - -map :: (v1 -> v2) -> Map k v1 -> Map k v2 -map f = Map . MonoidMap.map (fmap f) . unMap - -mapWithKey :: (k -> v1 -> v2) -> Map k v1 -> Map k v2 -mapWithKey f = Map . MonoidMap.mapWithKey (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 deleted file mode 100644 --- a/src/internal/Data/MonoidMap/Internal.hs +++ /dev/null @@ -1,3502 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{- HLINT ignore "Avoid lambda" -} -{- HLINT ignore "Avoid lambda using `infix`" -} -{- HLINT ignore "Redundant bracket" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- Provides /internal/ operations for the 'MonoidMap' type. --- -module Data.MonoidMap.Internal - ( - -- * Types - MonoidMap (..) - , NonNull (..) - - -- * General operations - - -- ** Construction - , empty - , fromList - , fromListWith - , fromMap - , fromSet - , singleton - - -- ** Deconstruction - , toList - , toMap - - -- ** Lookup - , get - - -- ** Modification - , set - , adjust - , nullify - - -- ** Membership - , null - , nullKey - , nonNull - , nonNullCount - , nonNullKey - , nonNullKeys - - -- ** Slicing - , take - , drop - , splitAt - - -- ** Filtering - , filter - , filterKeys - , filterWithKey - - -- ** Partitioning - , partition - , partitionKeys - , partitionWithKey - - -- ** Mapping - , map - , mapKeys - , mapKeysWith - , mapWithKey - - -- ** Folding - , foldl - , foldl' - , foldr - , foldr' - , foldlWithKey - , foldlWithKey' - , foldrWithKey - , foldrWithKey' - , foldMapWithKey - , foldMapWithKey' - - -- ** Traversal - , traverse - , traverseWithKey - , mapAccumL - , mapAccumLWithKey - , mapAccumR - , mapAccumRWithKey - - -- * Monoidal operations - - -- ** Association - , append - - -- ** Subtraction - , minus - , minusMaybe - , monus - - -- ** Inversion - , invert - - -- ** Exponentiation - , power - - -- ** Comparison - , isSubmapOf - , isSubmapOfBy - , disjoint - , disjointBy - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithA - - -- ** Union - , union - , unionWith - , unionWithA - - -- ** Prefixes - , isPrefixOf - , stripPrefix - , commonPrefix - , stripCommonPrefix - - -- ** Suffixes - , isSuffixOf - , stripSuffix - , commonSuffix - , stripCommonSuffix - - -- ** Overlap - , overlap - , stripPrefixOverlap - , stripSuffixOverlap - , stripOverlap - ) - where - -import Prelude hiding - ( drop - , filter - , foldl - , foldl' - , foldr - , lookup - , map - , null - , splitAt - , subtract - , take - , traverse - ) - -import Control.Applicative - ( Applicative (..) ) -import Control.DeepSeq - ( NFData ) -import Data.Bifoldable - ( Bifoldable ) -import Data.Coerce - ( coerce ) -import Data.Function - ( (&) ) -import Data.Functor.Classes - ( Eq1, Eq2, Show1, Show2 ) -import Data.Functor.Identity - ( Identity (..) ) -import Data.Group - ( Abelian, Group ) -import Data.Map.Strict - ( Map, lookup ) -import Data.Maybe - ( fromMaybe, isJust ) -import Data.Monoid.GCD - ( DistributiveGCDMonoid - , GCDMonoid - , LeftDistributiveGCDMonoid - , LeftGCDMonoid - , OverlappingGCDMonoid - , RightDistributiveGCDMonoid - , RightGCDMonoid - ) -import Data.Monoid.LCM - ( DistributiveLCMMonoid, LCMMonoid ) -import Data.Monoid.Monus - ( Monus (..) ) -import Data.Monoid.Null - ( MonoidNull, PositiveMonoid ) -import Data.Semigroup - ( stimes ) -import Data.Semigroup.Cancellative - ( Cancellative - , Commutative - , LeftCancellative - , LeftReductive - , Reductive (..) - , RightCancellative - , RightReductive - ) -import Data.Set - ( Set ) -import GHC.Exts - ( IsList (Item) ) -import NoThunks.Class - ( NoThunks ) -import Text.Read - ( Read (..) ) - -import qualified Data.Bifunctor as B -import qualified Data.Foldable as F -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Merge.Strict as Map -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 -import qualified Data.Monoid.LCM as C -import qualified Data.Monoid.Null as C -import qualified Data.Semigroup.Cancellative as C - --------------------------------------------------------------------------------- --- Type --------------------------------------------------------------------------------- - -newtype MonoidMap k v = MonoidMap (Map k (NonNull v)) - deriving (Eq, Show, NFData, NoThunks) - via Map k v - deriving (Eq1, Show1, Foldable) - via Map k - deriving (Eq2, Show2, Bifoldable) - via Map - --- Internal alias used when extra brevity is required. -type MM = MonoidMap - --------------------------------------------------------------------------------- --- Non-null values --------------------------------------------------------------------------------- - -newtype NonNull v = UnsafeNonNull {getNonNull :: v} - -maybeNonNull :: MonoidNull v => v -> Maybe (NonNull v) -maybeNonNull !v - | C.null v = Nothing - | otherwise = Just (UnsafeNonNull v) -{-# INLINE maybeNonNull #-} - -applyNonNull :: (v -> a) -> (NonNull v -> a) -applyNonNull = coerce -{-# INLINE applyNonNull #-} - -applyNonNull2 :: (v1 -> v2 -> a) -> (NonNull v1 -> NonNull v2 -> a) -applyNonNull2 = coerce -{-# INLINE applyNonNull2 #-} - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -instance (Ord k, MonoidNull v) => - IsList (MonoidMap k v) - where - type Item (MonoidMap k v) = (k, v) - fromList = fromList - toList = toList - -instance (Ord k, Read k, MonoidNull v, Read v) => - Read (MonoidMap k v) - where - readPrec = fromMap <$> readPrec - --------------------------------------------------------------------------------- --- Instances: Semigroup and subclasses --------------------------------------------------------------------------------- - -instance (Ord k, MonoidNull v) => - Semigroup (MonoidMap k v) - where - (<>) = append - stimes 0 = const mempty - stimes 1 = id - stimes n = map (stimes n) - -instance (Ord k, MonoidNull v, Commutative v) => - Commutative (MonoidMap k v) - -instance (Ord k, MonoidNull v, LeftReductive v) => - LeftReductive (MonoidMap k v) - where - isPrefixOf = isPrefixOf - stripPrefix = stripPrefix - -instance (Ord k, MonoidNull v, RightReductive v) => - RightReductive (MonoidMap k v) - where - isSuffixOf = isSuffixOf - stripSuffix = stripSuffix - -instance (Ord k, MonoidNull v, Reductive v) => - Reductive (MonoidMap k v) - where - () = minusMaybe - -instance (Ord k, MonoidNull v, LeftCancellative v) => - LeftCancellative (MonoidMap k v) - -instance (Ord k, MonoidNull v, RightCancellative v) => - RightCancellative (MonoidMap k v) - -instance (Ord k, MonoidNull v, Cancellative v) => - Cancellative (MonoidMap k v) - --------------------------------------------------------------------------------- --- Instances: Monoid and subclasses --------------------------------------------------------------------------------- - -instance (Ord k, MonoidNull v) => - Monoid (MonoidMap k v) - where - mempty = empty - -instance (Ord k, MonoidNull v) => - MonoidNull (MonoidMap k v) - where - null = null - -instance (Ord k, PositiveMonoid v) => - PositiveMonoid (MonoidMap k v) - -instance (Ord k, MonoidNull v, LeftGCDMonoid v) => - LeftGCDMonoid (MonoidMap k v) - where - commonPrefix = commonPrefix - -instance (Ord k, MonoidNull v, LeftDistributiveGCDMonoid v) => - LeftDistributiveGCDMonoid (MonoidMap k v) - -instance (Ord k, MonoidNull v, RightGCDMonoid v) => - RightGCDMonoid (MonoidMap k v) - where - commonSuffix = commonSuffix - -instance (Ord k, MonoidNull v, RightDistributiveGCDMonoid v) => - RightDistributiveGCDMonoid (MonoidMap k v) - -instance (Ord k, MonoidNull v, OverlappingGCDMonoid v) => - OverlappingGCDMonoid (MonoidMap k v) - where - overlap = overlap - stripPrefixOverlap = stripPrefixOverlap - stripSuffixOverlap = stripSuffixOverlap - stripOverlap = stripOverlap - -instance (Ord k, MonoidNull v, GCDMonoid v) => - GCDMonoid (MonoidMap k v) - where - gcd = intersection - -instance (Ord k, MonoidNull v, DistributiveGCDMonoid v) => - DistributiveGCDMonoid (MonoidMap k v) - -instance (Ord k, MonoidNull v, LCMMonoid v) => - LCMMonoid (MonoidMap k v) - where - lcm = union - -instance (Ord k, MonoidNull v, DistributiveLCMMonoid v) => - DistributiveLCMMonoid (MonoidMap k v) - -instance (Ord k, MonoidNull v, Monus v) => - Monus (MonoidMap k v) - where - (<\>) = monus - --------------------------------------------------------------------------------- --- Instances: Group and subclasses --------------------------------------------------------------------------------- - -instance (Ord k, MonoidNull v, Group v) => - Group (MonoidMap k v) - where - invert = invert - (~~) = minus - pow = power - -instance (Ord k, MonoidNull v, Abelian v) => - Abelian (MonoidMap k v) - --------------------------------------------------------------------------------- --- Construction --------------------------------------------------------------------------------- - --- | \(O(1)\). The empty 'MonoidMap'. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k 'empty' '==' 'mempty' --- @ --- --- Provides the definition of 'mempty' for the 'MonoidMap' instance of --- 'Monoid'. --- -empty :: MonoidMap k v -empty = MonoidMap Map.empty - --- | \(O(n \log n)\). Constructs a 'MonoidMap' from a list of key-value pairs. --- --- If the list contains more than one value for the same key, values are --- combined together in the order that they appear with the '(<>)' operator. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('fromList' kvs) '==' --- 'foldMap' 'snd' ('L.filter' (('==' k) . fst) kvs) --- @ --- --- Satisfies the following round-trip property: --- --- @ --- 'fromList' ('toList' m) '==' m --- @ --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> 'fromList' [(1,"a"), (2,"x"), (1,"b"), (2,"y"), (1,"c"), (2,"z")] --- 'fromList' [(1,"abc"), (2,"xyz")] --- @ --- -fromList :: (Ord k, MonoidNull v) => [(k, v)] -> MonoidMap k v -fromList = fromListWith (<>) - --- | \(O(n \log n)\). Constructs a 'MonoidMap' from a list of key-value pairs, --- with a combining function for values. --- --- If the list contains more than one value for the same key, values are --- combined together in the order that they appear with the given combining --- function. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('fromListWith' f kvs) '==' --- 'maybe' 'mempty' ('F.foldl1' f) --- ('NE.nonEmpty' ('snd' '<$>' 'L.filter' (('==' k) . fst) kvs)) --- @ --- -fromListWith - :: (Ord k, MonoidNull v) - => (v -> v -> v) - -- ^ Function with which to combine values for duplicate keys. - -> [(k, v)] - -> MonoidMap k v -fromListWith f = - -- The 'Map.fromListWith' function combines values for duplicate keys in - -- /reverse order/, so we must flip the provided combining function. - fromMap . Map.fromListWith (flip f) - --- | \(O(n)\). Constructs a 'MonoidMap' from an ordinary 'Map'. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('fromMap' m) '==' 'Map'.'Map.findWithDefault' 'mempty' 'k' m --- @ --- --- This function performs canonicalisation of 'C.null' values, and has a time --- complexity that is linear in the length of the list. --- -fromMap :: MonoidNull v => Map k v -> MonoidMap k v -fromMap = MonoidMap . Map.mapMaybe maybeNonNull - --- | \(O(n)\). Constructs a 'MonoidMap' from a 'Set' and a function from --- keys to values. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('fromSet' f ks) '==' --- if 'Set'.'Set.member' k ks --- then f k --- else 'mempty' --- @ --- --- This function performs canonicalisation of 'C.null' values, and has a time --- complexity that is linear in the 'Set.size' of the set. --- --- @since 0.0.2.0 --- -fromSet :: MonoidNull v => (k -> v) -> Set k -> MonoidMap k v -fromSet f = fromMap . Map.fromSet f - --- | \(O(1)\). Constructs a 'MonoidMap' from a single key-value pair. --- --- Satisfies the following property: --- --- @ --- 'get' 'k' ('singleton' k v) '==' v --- @ --- --- Nullifying the value for key __@k@__ produces an 'empty' map: --- --- @ --- 'nullify' 'k' ('singleton' k v) '==' 'empty' --- @ --- -singleton :: (Ord k, MonoidNull v) => k -> v -> MonoidMap k v -singleton k v = set k v mempty - --------------------------------------------------------------------------------- --- Deconstruction --------------------------------------------------------------------------------- - --- | \(O(n)\). Converts a 'MonoidMap' to a list of key-value pairs, where the --- keys are in ascending order. --- --- The result only includes entries with values that are not 'C.null'. --- --- Satisfies the following round-trip property: --- --- @ --- 'fromList' ('toList' m) '==' m --- @ --- --- The resulting list is sorted in ascending key order: --- --- @ --- 'L.sortOn' 'fst' ('toList' m) '==' 'toList' m --- @ --- -toList :: MonoidMap k v -> [(k, v)] -toList = Map.toAscList . toMap - --- | \(O(1)\). Converts a 'MonoidMap' to an ordinary 'Map'. --- --- The result only includes entries with values that are not 'C.null'. --- --- Satisfies the following round-trip property: --- --- @ --- 'fromMap' ('toMap' m) '==' m --- @ --- -toMap :: forall k v. MonoidMap k v -> Map k v -toMap = coerce - --------------------------------------------------------------------------------- --- Lookup --------------------------------------------------------------------------------- - --- | \(O(\log n)\). Gets the value associated with the given key. --- --- By default, every key in an 'empty' map is associated with a value of --- 'mempty': --- --- @ --- ∀ k. 'get' k 'empty' '==' 'mempty' --- @ --- -get :: (Ord k, Monoid v) => k -> MonoidMap k v -> v -get k m = fromMaybe mempty $ Map.lookup k $ toMap m - --------------------------------------------------------------------------------- --- Modification --------------------------------------------------------------------------------- - --- | \(O(\log n)\). Sets the value associated with the given key. --- --- Satisfies the following property: --- --- @ --- 'get' k ('set' k v m) '==' v --- @ --- -set :: (Ord k, MonoidNull v) => k -> v -> MonoidMap k v -> MonoidMap k v -set k v (MonoidMap m) = MonoidMap $ case maybeNonNull v of - Just v0 -> Map.insert k v0 m - Nothing -> Map.delete k m - --- | \(O(\log n)\). Adjusts the value associated with the given key. --- --- Satisfies the following property: --- --- @ --- 'adjust' f k m '==' 'set' k (f ('get' k m)) m --- @ --- -adjust - :: (Ord k, MonoidNull v) - => (v -> v) - -> k - -> MonoidMap k v - -> MonoidMap k v -adjust f k (MonoidMap m) = MonoidMap $ - Map.alter (maybeNonNull . maybe (f mempty) (applyNonNull f)) k m - --- | \(O(\log n)\). Sets the value associated with the given key to 'mempty'. --- --- Satisfies the following property: --- --- @ --- 'get' k ('nullify' k m) '==' 'mempty' --- @ --- -nullify :: Ord k => k -> MonoidMap k v -> MonoidMap k v -nullify k (MonoidMap m) = MonoidMap $ Map.delete k m - --------------------------------------------------------------------------------- --- Membership --------------------------------------------------------------------------------- - --- | \(O(1)\). Returns 'True' if (and only if) all values in the map are --- 'C.null'. --- --- Satisfies the following property: --- --- @ --- 'null' m '==' (∀ k. 'nullKey' k m) --- @ --- --- Provides the definition of 'C.null' for the 'MonoidMap' instance of --- 'MonoidNull'. --- -null :: MonoidMap k v -> Bool -null = Map.null . toMap - --- | \(O(\log n)\). Returns 'True' if (and only if) the given key is associated --- with a value that is 'C.null'. --- --- Satisfies the following property: --- --- @ --- 'nullKey' k m '==' 'C.null' ('get' k m) --- @ --- -nullKey :: Ord k => k -> MonoidMap k v -> Bool -nullKey k = Map.notMember k . toMap - --- | \(O(1)\). Returns 'True' if (and only if) the map contains at least one --- value that is not 'C.null'. --- --- Satisfies the following property: --- --- @ --- 'nonNull' m '==' (∃ k. 'nonNullKey' k m) --- @ --- -nonNull :: MonoidMap k v -> Bool -nonNull = not . null - --- | \(O(1)\). Returns a count of all values in the map that are not 'C.null'. --- --- Satisfies the following property: --- --- @ --- 'nonNullCount' m '==' 'Set.size' ('nonNullKeys' m) --- @ --- -nonNullCount :: MonoidMap k v -> Int -nonNullCount = Map.size . toMap - --- | \(O(\log n)\). Returns 'True' if (and only if) the given key is associated --- with a value that is not 'C.null'. --- --- Satisfies the following property: --- --- @ --- 'nonNullKey' k m '==' 'not' ('C.null' ('get' k m)) --- @ --- -nonNullKey :: Ord k => k -> MonoidMap k v -> Bool -nonNullKey k = Map.member k . toMap - --- | \(O(n)\). Returns the set of keys associated with values that are not --- 'C.null'. --- --- Satisfies the following property: --- --- @ --- k '`Set.member`' ('nonNullKeys' m) '==' 'nonNullKey' k m --- @ --- -nonNullKeys :: MonoidMap k v -> Set k -nonNullKeys = Map.keysSet . toMap - --------------------------------------------------------------------------------- --- Slicing --------------------------------------------------------------------------------- - --- | \(O(\log n)\). /Takes/ a slice from a map. --- --- This function takes a given number of non-'C.null' entries from a map, --- producing a new map from the entries that were /taken/. --- --- Entries are taken in /key order/, beginning with the /smallest/ keys. --- --- Satifies the following property: --- --- @ --- 'take' n '==' 'fromList' . 'Prelude.take' n . 'toList' --- @ --- -take :: Int -> MonoidMap k v -> MonoidMap k v -take i (MonoidMap m) = MonoidMap (Map.take i m) - --- | \(O(\log n)\). /Drops/ a slice from a map. --- --- This function drops a given number of non-'C.null' entries from a map, --- producing a new map from the entries that /remain/. --- --- Entries are dropped in /key order/, beginning with the /smallest/ keys. --- --- Satifies the following property: --- --- @ --- 'drop' n '==' 'fromList' . 'Prelude.drop' n . 'toList' --- @ --- -drop :: Int -> MonoidMap k v -> MonoidMap k v -drop i (MonoidMap m) = MonoidMap (Map.drop i m) - --- | \(O(\log n)\). /Splits/ a map into /two/ slices. --- --- This function is equivalent to a combination of 'take' and 'drop': --- --- @ --- 'splitAt' n m '==' ('take' n m, 'drop' n m) --- @ --- --- The resulting maps can be combined to reproduce the original map: --- --- @ --- 'splitAt' n m '&' --- \\(m1, m2) -> m1 '<>' m2 '==' m --- @ --- --- The resulting maps have disjoint sets of non-'C.null' entries: --- --- @ --- 'splitAt' n m '&' --- \\(m1, m2) -> 'Set.disjoint' ('nonNullKeys' m1) ('nonNullKeys' m2) --- @ --- -splitAt :: Int -> MonoidMap k a -> (MonoidMap k a, MonoidMap k a) -splitAt i m = (take i m, drop i m) - --------------------------------------------------------------------------------- --- Filtering --------------------------------------------------------------------------------- - --- | \(O(n)\). Filters a map according to a predicate on /values/. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('filter' f m) '==' --- if f ('get' k m) --- then 'get' k m --- else 'mempty' --- @ --- --- The resulting map is identical to that obtained by constructing a map from a --- filtered list of key-value pairs: --- --- @ --- 'filter' f m '==' 'fromList' ('L.filter' (f . 'snd') ('toList' m)) --- @ --- -filter :: (v -> Bool) -> MonoidMap k v -> MonoidMap k v -filter f (MonoidMap m) = MonoidMap $ Map.filter (applyNonNull f) m - --- | \(O(n)\). Filters a map according to a predicate on /keys/. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('filterKeys' f m) '==' --- if f k --- then 'get' k m --- else 'mempty' --- @ --- --- The resulting map is identical to that obtained by constructing a map from a --- filtered list of key-value pairs: --- --- @ --- 'filter' f m '==' 'fromList' ('L.filter' (f . 'fst') ('toList' m)) --- @ --- -filterKeys :: (k -> Bool) -> MonoidMap k v -> MonoidMap k v -filterKeys f (MonoidMap m) = MonoidMap $ Map.filterWithKey (\k _ -> f k) m - --- | \(O(n)\). Filters a map according to a predicate on /keys and values/. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('filterWithKey' f m) '==' --- if f k ('get' k m) --- then 'get' k m --- else 'mempty' --- @ --- --- The resulting map is identical to that obtained by constructing a map from a --- filtered list of key-value pairs: --- --- @ --- 'filterWithKey' f m '==' 'fromList' ('L.filter' ('uncurry' f) ('toList' m)) --- @ --- -filterWithKey :: (k -> v -> Bool) -> MonoidMap k v -> MonoidMap k v -filterWithKey f (MonoidMap m) = - MonoidMap $ Map.filterWithKey (applyNonNull . f) m - --------------------------------------------------------------------------------- --- Partitioning --------------------------------------------------------------------------------- - --- | \(O(n)\). Partitions a map according to a predicate on /values/. --- --- Satisfies the following property: --- --- @ --- 'partition' f m '==' --- ( 'filter' \ \ f m --- , 'filter' ('not' . f) m --- ) --- @ --- --- The resulting maps can be combined to reproduce the original map: --- --- @ --- 'partition' f m '&' \\(m1, m2) -> --- m1 '<>' m2 '==' m --- @ --- --- The resulting maps have disjoint sets of non-'C.null' entries: --- --- @ --- 'partition' f m '&' \\(m1, m2) -> --- 'Set.disjoint' --- ('nonNullKeys' m1) --- ('nonNullKeys' m2) --- @ --- -partition :: (v -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) -partition f (MonoidMap m) = - B.bimap MonoidMap MonoidMap $ Map.partition (applyNonNull f) m - --- | \(O(n)\). Partitions a map according to a predicate on /keys/. --- --- Satisfies the following property: --- --- @ --- 'partitionKeys' f m '==' --- ( 'filterKeys' \ \ f m --- , 'filterKeys' ('not' . f) m --- ) --- @ --- --- The resulting maps can be combined to reproduce the original map: --- --- @ --- 'partitionKeys' f m '&' \\(m1, m2) -> --- m1 '<>' m2 '==' m --- @ --- --- The resulting maps have disjoint sets of non-'C.null' entries: --- --- @ --- 'partitionKeys' f m '&' \\(m1, m2) -> --- 'Set.disjoint' --- ('nonNullKeys' m1) --- ('nonNullKeys' m2) --- @ --- -partitionKeys - :: (k -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) -partitionKeys f (MonoidMap m) = - B.bimap MonoidMap MonoidMap $ Map.partitionWithKey (\k _ -> f k) m - --- | \(O(n)\). Partitions a map according to a predicate on /keys and values/. --- --- Satisfies the following property: --- --- @ --- 'partitionWithKey' f m '==' --- ( 'filterWithKey' \ \ \ \ \ \ f m --- , 'filterWithKey' (('fmap' . 'fmap') 'not' f) m --- ) --- @ --- --- The resulting maps can be combined to reproduce the original map: --- --- @ --- 'partitionWithKey' f m '&' \\(m1, m2) -> --- m1 '<>' m2 '==' m --- @ --- --- The resulting maps have disjoint sets of non-'C.null' entries: --- --- @ --- 'partitionWithKey' f m '&' \\(m1, m2) -> --- 'Set.disjoint' --- ('nonNullKeys' m1) --- ('nonNullKeys' m2) --- @ --- -partitionWithKey - :: (k -> v -> Bool) -> MonoidMap k v -> (MonoidMap k v, MonoidMap k v) -partitionWithKey f (MonoidMap m) = - B.bimap MonoidMap MonoidMap $ Map.partitionWithKey (applyNonNull . f) m - --------------------------------------------------------------------------------- --- Mapping --------------------------------------------------------------------------------- - --- | \(O(n)\). Applies a function to all non-'C.null' values of a 'MonoidMap'. --- --- Satisfies the following properties for all functions __@f@__: --- --- @ --- ('get' k m '==' 'mempty') ==> ('get' k ('map' f m) '==' 'mempty' ) --- ('get' k m '/=' 'mempty') ==> ('get' k ('map' f m) '==' f ('get' k m)) --- @ --- --- === Conditional properties --- --- If applying function __@f@__ to 'mempty' produces 'mempty', then the --- following additional properties hold: --- --- @ --- (f 'mempty' '==' 'mempty') --- ==> --- (∀ k. 'get' k ('map' f m) '==' f ('get' k m)) --- @ --- --- @ --- (f 'mempty' '==' 'mempty') --- ==> --- (∀ g. 'map' (f . g) m '==' 'map' f ('map' g m)) --- @ --- -map - :: MonoidNull v2 - => (v1 -> v2) - -> MonoidMap k v1 - -> MonoidMap k v2 -map f (MonoidMap m) = - MonoidMap $ Map.mapMaybe (maybeNonNull . applyNonNull f) m - --- | \(O(n \log n)\). Applies a function to all the keys of a 'MonoidMap' that --- are associated with non-'C.null' values. --- --- If the resultant map would contain more than one value for the same key, --- values are combined together in ascending key order with the '(<>)' --- operator. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('mapKeys' f m) '==' --- 'F.foldMap' --- ('`get`' m) --- ('Set.filter' (('==') k . f) ('nonNullKeys' m)) --- @ --- -mapKeys - :: (Ord k2, MonoidNull v) - => (k1 -> k2) - -> MonoidMap k1 v - -> MonoidMap k2 v -mapKeys = mapKeysWith (<>) - --- | \(O(n \log n)\). Applies a function to all the keys of a 'MonoidMap' that --- are associated with non-'C.null' values, with a combining function for --- values. --- --- If the resultant map would contain more than one value for the same key, --- values are combined together in ascending key order with the given --- combining function. --- --- Satisfies the following property: --- --- @ --- 'mapKeysWith' c f '==' 'fromListWith' c . 'fmap' ('B.first' f) . 'toList' --- @ --- -mapKeysWith - :: (Ord k2, MonoidNull v) - => (v -> v -> v) - -- ^ Function with which to combine values for duplicate keys. - -> (k1 -> k2) - -> MonoidMap k1 v - -> MonoidMap k2 v -mapKeysWith combine fk = fromListWith combine . fmap (B.first fk) . toList - --- | \(O(n)\). Applies a key-dependent function to all non-'C.null' values of --- a 'MonoidMap'. --- --- Satisfies the following properties for all functions __@f@__: --- --- @ --- ('nonNullKey' k m) ==> ('get' k ('mapWithKey' f m) '==' f k ('get' k m)) --- ( 'nullKey' k m) ==> ('get' k ('mapWithKey' f m) '==' 'mempty' ) --- @ --- --- @since 0.0.3.0 --- -mapWithKey - :: MonoidNull v2 - => (k -> v1 -> v2) - -> MonoidMap k v1 - -> MonoidMap k v2 -mapWithKey f (MonoidMap m) = - MonoidMap . runIdentity $ - Map.traverseMaybeWithKey - (\k v -> Identity $ maybeNonNull $ applyNonNull (f k) v) m - --------------------------------------------------------------------------------- --- Lazy folding --------------------------------------------------------------------------------- - --- | \(O(n)\). Folds over the values in the map using the given --- left-associative binary operator. --- --- Satisfies the following property: --- --- @ --- 'foldl' f r m '==' 'Map'.'Map.foldl' f r ('toMap' m) --- @ --- --- @since 0.0.1.7 --- -foldl :: (r -> v -> r) -> r -> MonoidMap k v -> r -foldl = - (coerce - :: ((r -> v -> r) -> r -> Map k v -> r) - -> ((r -> v -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldl -{-# INLINE foldl #-} - --- | \(O(n)\). Folds over the values in the map using the given --- right-associative binary operator. --- --- Satisfies the following property: --- --- @ --- 'foldr' f r m '==' 'Map'.'Map.foldr' f r ('toMap' m) --- @ --- --- @since 0.0.1.7 --- -foldr :: (v -> r -> r) -> r -> MonoidMap k v -> r -foldr = - (coerce - :: ((v -> r -> r) -> r -> Map k v -> r) - -> ((v -> r -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldr -{-# INLINE foldr #-} - --- | \(O(n)\). Folds over the keys and values in the map using the given --- left-associative binary operator. --- --- Satisfies the following property: --- --- @ --- 'foldlWithKey' f r m '==' 'Map'.'Map.foldlWithKey' f r ('toMap' m) --- @ --- --- @since 0.0.1.7 --- -foldlWithKey :: (r -> k -> v -> r) -> r -> MonoidMap k v -> r -foldlWithKey = - (coerce - :: ((r -> k -> v -> r) -> r -> Map k v -> r) - -> ((r -> k -> v -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldlWithKey -{-# INLINE foldlWithKey #-} - --- | \(O(n)\). Folds over the keys and values in the map using the given --- right-associative binary operator. --- --- Satisfies the following property: --- --- @ --- 'foldrWithKey' f r m '==' 'Map'.'Map.foldrWithKey' f r ('toMap' m) --- @ --- --- @since 0.0.1.7 --- -foldrWithKey :: (k -> v -> r -> r) -> r -> MonoidMap k v -> r -foldrWithKey = - (coerce - :: ((k -> v -> r -> r) -> r -> Map k v -> r) - -> ((k -> v -> r -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldrWithKey -{-# INLINE foldrWithKey #-} - --- | \(O(n)\). Folds over the keys and values in the map using the given --- monoid. --- --- Satisfies the following property: --- --- @ --- 'foldMapWithKey' f m '==' 'Map'.'Map.foldMapWithKey' f ('toMap' m) --- @ --- --- @since 0.0.1.7 --- -foldMapWithKey :: Monoid r => (k -> v -> r) -> MonoidMap k v -> r -foldMapWithKey = - (coerce - :: ((k -> v -> r) -> Map k v -> r) - -> ((k -> v -> r) -> MonoidMap k v -> r) - ) - Map.foldMapWithKey -{-# INLINE foldMapWithKey #-} - --------------------------------------------------------------------------------- --- Strict folding --------------------------------------------------------------------------------- - --- | \(O(n)\). A strict version of 'foldl'. --- --- Each application of the operator is evaluated before using the result in the --- next application. This function is strict in the starting value. --- --- @since 0.0.1.7 --- -foldl' :: (r -> v -> r) -> r -> MonoidMap k v -> r -foldl' = - (coerce - :: ((r -> v -> r) -> r -> Map k v -> r) - -> ((r -> v -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldl' -{-# INLINE foldl' #-} - --- | \(O(n)\). A strict version of 'foldr'. --- --- Each application of the operator is evaluated before using the result in the --- next application. This function is strict in the starting value. --- --- @since 0.0.1.7 --- -foldr' :: (v -> r -> r) -> r -> MonoidMap k v -> r -foldr' = - (coerce - :: ((v -> r -> r) -> r -> Map k v -> r) - -> ((v -> r -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldr' -{-# INLINE foldr' #-} - --- | \(O(n)\). A strict version of 'foldlWithKey'. --- --- Each application of the operator is evaluated before using the result in the --- next application. This function is strict in the starting value. --- --- @since 0.0.1.7 --- -foldlWithKey' :: (r -> k -> v -> r) -> r -> MonoidMap k v -> r -foldlWithKey' = - (coerce - :: ((r -> k -> v -> r) -> r -> Map k v -> r) - -> ((r -> k -> v -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldlWithKey' -{-# INLINE foldlWithKey' #-} - --- | \(O(n)\). A strict version of 'foldrWithKey'. --- --- Each application of the operator is evaluated before using the result in the --- next application. This function is strict in the starting value. --- --- @since 0.0.1.7 --- -foldrWithKey' :: (k -> v -> r -> r) -> r -> MonoidMap k v -> r -foldrWithKey' = - (coerce - :: ((k -> v -> r -> r) -> r -> Map k v -> r) - -> ((k -> v -> r -> r) -> r -> MonoidMap k v -> r) - ) - Map.foldrWithKey' -{-# INLINE foldrWithKey' #-} - --- | \(O(n)\). A strict version of 'foldMapWithKey'. --- --- Each application of `mappend` is evaluated before using the result in the --- next application. --- --- @since 0.0.1.8 --- -foldMapWithKey' :: Monoid r => (k -> v -> r) -> MonoidMap k v -> r -foldMapWithKey' f = foldlWithKey' (\r k v -> r <> f k v) mempty -{-# 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 --------------------------------------------------------------------------------- - --- | Indicates whether or not the first map is a /submap/ of the second. --- --- Map __@m1@__ is a submap of map __@m2@__ if (and only if) __@m1@__ can be --- subtracted from __@m2@__ with the 'minusMaybe' operation: --- --- @ --- m1 '`isSubmapOf`' m2 '==' 'isJust' (m2 '`minusMaybe`' m1) --- @ --- --- Equivalently, map __@m1@__ is a submap of map __@m2@__ if (and only if) for --- all possible keys __@k@__, the value for __@k@__ in __@m1@__ can be --- subtracted from the value for __@k@__ in __@m2@__ with the '()' operator: --- --- @ --- m1 '`isSubmapOf`' m2 '==' (∀ k. 'isJust' ('get' k m2 '' 'get' k m1)) --- @ --- -isSubmapOf - :: (Ord k, Monoid v, Reductive v) - => MonoidMap k v - -> MonoidMap k v - -> Bool -isSubmapOf = isSubmapOfBy $ \v1 v2 -> isJust (v2 v1) -{-# INLINE isSubmapOf #-} - --- | Indicates whether or not the first map is a /submap/ of the second, using --- the given function to compare values for matching keys. --- --- Satisfies the following property: --- --- @ --- 'isSubmapOfBy' f m1 m2 '==' --- 'all' (\\k -> f ('get' k m1) ('get' k m2)) ('nonNullKeys' m1) --- @ --- --- === Conditional totality --- --- /If/ the given comparison function __@f@__ /always/ evaluates to 'True' --- when its first argument is 'mempty': --- --- @ --- ∀ v. f 'mempty' v --- @ --- --- /Then/ the following property holds: --- --- @ --- 'isSubmapOfBy' f m1 m2 '==' (∀ k. f ('get' k m1) ('get' k m2)) --- @ --- -isSubmapOfBy - :: (Ord k, Monoid v1, Monoid v2) - => (v1 -> v2 -> Bool) - -- ^ Function with which to compare values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> Bool -isSubmapOfBy leq m1 m2 = - all - (\k -> get k m1 `leq` get k m2) - (nonNullKeys m1) -{-# INLINE isSubmapOfBy #-} - --- | Indicates whether or not a pair of maps are /disjoint/. --- --- Maps __@m1@__ and __@m2@__ are disjoint if (and only if) their intersection --- is empty: --- --- @ --- 'disjoint' m1 m2 '==' ('intersection' m1 m2 '==' 'mempty') --- @ --- --- Equivalently, maps __@m1@__ and __@m2@__ are disjoint if (and only if) for --- all possible keys __@k@__, the values for __@k@__ in __@m1@__ and __@m2@__ --- have a 'C.gcd' that is 'C.null': --- --- @ --- 'disjoint' m1 m2 '==' (∀ k. 'C.null' ('C.gcd' ('get' k m1) ('get' k m2))) --- @ --- -disjoint - :: (Ord k, GCDMonoid v, MonoidNull v) - => MonoidMap k v - -> MonoidMap k v - -> Bool -disjoint = disjointBy (\v1 v2 -> C.null (C.gcd v1 v2)) -{-# INLINE disjoint #-} - --- | Indicates whether or not a pair of maps are /disjoint/ using the given --- indicator function to test pairs of values for matching keys. --- --- Satisfies the following property: --- --- @ --- 'disjointBy' f m1 m2 '==' --- 'all' --- (\\k -> f ('get' k m1) ('get' k m2)) --- ('Set.intersection' ('nonNullKeys' m1) ('nonNullKeys' m2)) --- @ --- --- === Conditional totality --- --- /If/ the given indicator function __@f@__ /always/ evaluates to 'True' --- when /either/ or /both/ of its arguments are 'mempty': --- --- @ --- ∀ v. (f v 'mempty') '&&' (f 'mempty' v) --- @ --- --- /Then/ the following property holds: --- --- @ --- 'disjointBy' f m1 m2 '==' (∀ k. f ('get' k m1) ('get' k m2)) --- @ --- -disjointBy - :: (Ord k, Monoid v1, Monoid v2) - => (v1 -> v2 -> Bool) - -- ^ Function with which to test pairs of values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> Bool -disjointBy f m1 m2 = - all - (\k -> f (get k m1) (get k m2)) - (Set.intersection (nonNullKeys m1) (nonNullKeys m2)) -{-# INLINE disjointBy #-} - --------------------------------------------------------------------------------- --- Association --------------------------------------------------------------------------------- - --- | Appends a pair of maps together. --- --- Uses the 'Semigroup' operator '(<>)' to append each value in the first map --- to its matching value in the second map. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('append' m1 m2) '==' 'get' k m1 '<>' 'get' k m2 --- @ --- --- This function provides the definition of '(<>)' for the 'MonoidMap' instance --- of 'Semigroup'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1, "abc"), (2, "ij" ), (3, "p" ) ] --- >>> m2 = 'fromList' [ (2, " k"), (3, "qr"), (4, "xyz")] --- >>> m3 = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] --- @ --- @ --- >>> 'append' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 4), ("b", 2), ("c", 1) ] --- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 4)] --- >>> m3 = 'fromList' [("a", 4), ("b", 3), ("c", 3), ("d", 4)] --- @ --- @ --- >>> 'append' m1 m2 '==' m3 --- 'True' --- @ --- -append - :: (Ord k, MonoidNull v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -append = merge MergeStrategy - { withNonNullL = - keepNonNull - -- Justification: - -- - -- v <> mempty ≡ v - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- mempty <> v ≡ v - - , withNonNullP = - withBoth (<>) - } -{-# INLINE append #-} - --------------------------------------------------------------------------------- --- Prefixes and suffixes --------------------------------------------------------------------------------- - --- | Indicates whether or not the first map is a /prefix/ of the second. --- --- 'MonoidMap' __@m1@__ is a /prefix/ of 'MonoidMap' __@m2@__ if (and only if) --- for all possible keys __@k@__, the value for __@k@__ in __@m1@__ is a --- /prefix/ of the value for __@k@__ in __@m2@__: --- --- @ --- m1 '`isPrefixOf`' m2 '==' (∀ k. 'get' k m1 '`C.isPrefixOf`' 'get' k m2) --- @ --- --- This function provides the definition of 'C.isPrefixOf' for the 'MonoidMap' --- instance of 'LeftReductive'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1, "a" ), (2, "p" ), (3, "x" )] --- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isPrefixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [ (2, "p" ) ] --- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isPrefixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [(1, "abc"), (2, "p" ), (3, "x" )] --- >>> m2 = 'fromList' [(1, "a" ), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isPrefixOf`' m2 --- 'False' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 1), ("b", 1), ("c", 1)] --- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] --- >>> m1 '`isPrefixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [ ("b", 1) ] --- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] --- >>> m1 '`isPrefixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 1), ("c", 1)] --- >>> m2 = 'fromList' [("a", 1), ("b", 4), ("c", 8)] --- >>> m1 '`isPrefixOf`' m2 --- 'False' --- @ --- -isPrefixOf - :: (Ord k, Monoid v, LeftReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Bool -isPrefixOf = isSubmapOfBy C.isPrefixOf - -- Note that in practice, it's sufficient to check the following property: - -- - -- @ - -- m1 '`isPrefixOf`' m2 '==' - -- 'all' - -- (\\k -> 'get' k m1 '`C.isPrefixOf`' 'get' k m2) - -- ('nonNullKeys' m1) - -- @ - -- - -- ==== Justification - -- - -- According to the laws for 'LeftReductive': - -- - -- @ - -- ∀ a b. b '`C.isPrefixOf`' (b '<>' a) - -- @ - -- - -- Substituting 'mempty' for @b@: - -- - -- @ - -- ∀ a. 'mempty' '`C.isPrefixOf`' ('mempty' '<>' a) - -- @ - -- - -- According to the left identity law for 'Monoid': - -- - -- @ - -- ∀ a. 'mempty' '<>' a '==' a - -- @ - -- - -- We can therefore assert that: - -- - -- @ - -- ∀ a. 'mempty' '`C.isPrefixOf`' a - -- @ - -- - -- Since 'mempty' is /always/ a valid prefix, we only need to consider - -- values in 'm1' that are /not/ 'mempty'. - -- - -- The 'nonNullKeys' function, when applied to 'm1', gives us /precisely/ - -- the set of keys that are not associated with 'mempty' in 'm1': - -- - -- @ - -- (k '`Data.Set.member`' 'nonNullKeys' m1) '==' ('get' k m1 '/=' 'mempty') - -- @ - -- -{-# INLINE isPrefixOf #-} - --- | Indicates whether or not the first map is a /suffix/ of the second. --- --- 'MonoidMap' __@m1@__ is a /suffix/ of 'MonoidMap' __@m2@__ if (and only if) --- for all possible keys __@k@__, the value for __@k@__ in __@m1@__ is a --- /suffix/ of the value for __@k@__ in __@m2@__: --- --- @ --- m1 '`isSuffixOf`' m2 '==' (∀ k. 'get' k m1 '`C.isSuffixOf`' 'get' k m2) --- @ --- --- This function provides the definition of 'C.isSuffixOf' for the 'MonoidMap' --- instance of 'RightReductive'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1, "c"), (2, "r"), (3, "z")] --- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isSuffixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [ (2, "r") ] --- >>> m2 = 'fromList' [(1, "abc"), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isSuffixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [(1, "abc"), (2, "r"), (3, "z")] --- >>> m2 = 'fromList' [(1, "c"), (2, "pqr"), (3, "xyz")] --- >>> m1 '`isSuffixOf`' m2 --- 'False' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 1), ("b", 1), ("c", 1)] --- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] --- >>> m1 '`isSuffixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [ ("b", 1) ] --- >>> m2 = 'fromList' [("a", 2), ("b", 4), ("c", 8)] --- >>> m1 '`isSuffixOf`' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 1), ("c", 1)] --- >>> m2 = 'fromList' [("a", 1), ("b", 4), ("c", 8)] --- >>> m1 '`isSuffixOf`' m2 --- 'False' --- @ --- -isSuffixOf - :: (Ord k, Monoid v, RightReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Bool -isSuffixOf = isSubmapOfBy C.isSuffixOf - -- Note that in practice, it's sufficient to check the following property: - -- - -- @ - -- m1 '`isSuffixOf`' m2 '==' - -- 'all' - -- (\\k -> 'get' k m1 '`C.isSuffixOf`' 'get' k m2) - -- ('nonNullKeys' m1) - -- @ - -- - -- ==== Justification - -- - -- According to the laws for 'RightReductive': - -- - -- @ - -- ∀ a b. b '`C.isSuffixOf`' (a '<>' b) - -- @ - -- - -- Substituting 'mempty' for @b@: - -- - -- @ - -- ∀ a. 'mempty' '`C.isSuffixOf`' (a '<>' 'mempty') - -- @ - -- - -- According to the right identity law for 'Monoid': - -- - -- @ - -- ∀ a. a '<>' 'mempty' '==' a - -- @ - -- - -- We can therefore assert that: - -- - -- @ - -- ∀ a. 'mempty' '`C.isSuffixOf`' a - -- @ - -- - -- Since 'mempty' is /always/ a valid suffix, we only need to consider - -- values in 'm1' that are /not/ 'mempty'. - -- - -- The 'nonNullKeys' function, when applied to 'm1', gives us /precisely/ - -- the set of keys that are not associated with 'mempty' in 'm1': - -- - -- @ - -- (k '`Data.Set.member`' 'nonNullKeys' m1) '==' ('get' k m1 '/=' 'mempty') - -- @ - -- -{-# INLINE isSuffixOf #-} - --- | Strips a /prefix/ from a 'MonoidMap'. --- --- If map __@m1@__ is a /prefix/ of map __@m2@__, then 'stripPrefix' __@m1@__ --- __@m2@__ will produce a /reduced/ map where prefix __@m1@__ is /stripped/ --- from __@m2@__. --- --- === Properties --- --- The 'stripPrefix' function, when applied to maps __@m1@__ and __@m2@__, --- produces a result if (and only if) __@m1@__ is a prefix of __@m2@__: --- --- @ --- 'isJust' ('stripPrefix' m1 m2) '==' m1 '`isPrefixOf`' m2 --- @ --- --- The value for any key __@k@__ in the result is /identical/ to the result of --- stripping the value for __@k@__ in map __@m1@__ from the value for __@k@__ --- in map __@m2@__: --- --- @ --- 'all' --- (\\r -> 'Just' ('get' k r) '==' 'C.stripPrefix' ('get' k m1) ('get' k m2)) --- ('stripPrefix' m1 m2) --- @ --- --- If we append prefix __@m1@__ to the /left-hand/ side of the result, we can --- always recover the original map __@m2@__: --- --- @ --- 'all' --- (\\r -> m1 '<>' r '==' m2) --- ('stripPrefix' m1 m2) --- @ --- --- This function provides the definition of 'C.stripPrefix' for the 'MonoidMap' --- instance of 'LeftReductive'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> __m1__ = 'fromList' [(1, "" ), (2, "i" ), (3, "pq" ), (4, "xyz")] --- >>> __m2__ = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] --- >>> __m3__ = 'fromList' [(1, "abc"), (2, "jk"), (3, "r"), (4, "")] --- @ --- @ --- >>> 'stripPrefix' __m1__ __m2__ '==' 'Just' __m3__ --- 'True' --- @ --- @ --- >>> 'stripPrefix' __m2__ __m1__ '==' 'Nothing' --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> __m2__ = 'fromList' [("a", 3), ("b", 3), ("c", 3), ("d", 3)] --- >>> __m3__ = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] --- @ --- @ --- >>> 'stripPrefix' __m1__ __m2__ '==' 'Just' __m3__ --- 'True' --- @ --- @ --- >>> 'stripPrefix' __m2__ __m1__ '==' 'Nothing' --- 'True' --- @ --- -stripPrefix - :: (Ord k, MonoidNull v, LeftReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Maybe (MonoidMap k v) -stripPrefix = mergeA MergeStrategy - { withNonNullL = - withNonNullA (\v -> C.stripPrefix v mempty) - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- stripPrefix mempty a ≡ a - - , withNonNullP = - withBothA C.stripPrefix - } -{-# INLINE stripPrefix #-} - --- | Strips a /suffix/ from a 'MonoidMap'. --- --- If map __@m1@__ is a /suffix/ of map __@m2@__, then 'stripSuffix' __@m1@__ --- __@m2@__ will produce a /reduced/ map where suffix __@m1@__ is /stripped/ --- from __@m2@__. --- --- === Properties --- --- The 'stripSuffix' function, when applied to maps __@m1@__ and __@m2@__, --- produces a result if (and only if) __@m1@__ is a suffix of __@m2@__: --- --- @ --- 'isJust' ('stripSuffix' m1 m2) '==' m1 '`isSuffixOf`' m2 --- @ --- --- The value for any key __@k@__ in the result is /identical/ to the result of --- stripping the value for __@k@__ in map __@m1@__ from the value for __@k@__ --- in map __@m2@__: --- --- @ --- 'all' --- (\\r -> 'Just' ('get' k r) '==' 'C.stripSuffix' ('get' k m1) ('get' k m2)) --- ('stripSuffix' m1 m2) --- @ --- --- If we append suffix __@m1@__ to the /right-hand/ side of the result, we can --- always recover the original map __@m2@__: --- --- @ --- 'all' --- (\\r -> r '<>' m1 '==' m2) --- ('stripSuffix' m1 m2) --- @ --- --- This function provides the definition of 'C.stripSuffix' for the 'MonoidMap' --- instance of 'RightReductive'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> __m1__ = 'fromList' [(1, ""), (2, "k"), (3, "qr"), (4, "xyz")] --- >>> __m2__ = 'fromList' [(1, "abc"), (2, "ijk"), (3, "pqr"), (4, "xyz")] --- >>> __m3__ = 'fromList' [(1, "abc"), (2, "ij" ), (3, "p" ), (4, "" )] --- @ --- @ --- >>> 'stripSuffix' __m1__ __m2__ '==' 'Just' __m3__ --- 'True' --- @ --- @ --- >>> 'stripSuffix' __m2__ __m1__ '==' 'Nothing' --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> __m2__ = 'fromList' [("a", 3), ("b", 3), ("c", 3), ("d", 3)] --- >>> __m3__ = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] --- @ --- @ --- >>> 'stripSuffix' __m1__ __m2__ '==' 'Just' __m3__ --- 'True' --- @ --- @ --- >>> 'stripSuffix' __m2__ __m1__ '==' 'Nothing' --- 'True' --- @ --- -stripSuffix - :: (Ord k, MonoidNull v, RightReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Maybe (MonoidMap k v) -stripSuffix = mergeA MergeStrategy - { withNonNullL = - withNonNullA (\v -> C.stripSuffix v mempty) - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- stripSuffix mempty a ≡ a - - , withNonNullP = - withBothA C.stripSuffix - } -{-# INLINE stripSuffix #-} - --- | Finds the /greatest common prefix/ of two maps. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('commonPrefix' m1 m2) --- '==' 'C.commonPrefix' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.commonPrefix' for the --- 'MonoidMap' instance of 'LeftGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> __m1__ = 'fromList' [(1, "+++"), (2, "b++"), (3, "cc+"), (4, "ddd")] --- >>> __m2__ = 'fromList' [(1, "---"), (2, "b--"), (3, "cc-"), (4, "ddd")] --- >>> __m3__ = 'fromList' [(1, "" ), (2, "b" ), (3, "cc" ), (4, "ddd")] --- @ --- @ --- >>> 'commonPrefix' __m1__ __m2__ '==' __m3__ --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> __m2__ = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] --- >>> __m3__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 2)] --- @ --- @ --- >>> 'commonPrefix' __m1__ __m2__ '==' __m3__ --- 'True' --- @ --- -commonPrefix - :: (Ord k, MonoidNull v, LeftGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -commonPrefix = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- commonPrefix a mempty ≡ mempty - - , withNonNullR = - keepNull - -- Justification: - -- - -- commonPrefix mempty a ≡ mempty - - , withNonNullP = - withBoth C.commonPrefix - } -{-# INLINE commonPrefix #-} - --- | Finds the /greatest common suffix/ of two maps. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('commonSuffix' m1 m2) --- '==' 'C.commonSuffix' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.commonSuffix' for the --- 'MonoidMap' instance of 'RightGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> __m1__ = 'fromList' [(1, "+++"), (2, "++b"), (3, "+cc"), (4, "ddd")] --- >>> __m2__ = 'fromList' [(1, "---"), (2, "--b"), (3, "-cc"), (4, "ddd")] --- >>> __m3__ = 'fromList' [(1, ""), (2, "b"), (3, "cc"), (4, "ddd")] --- @ --- @ --- >>> 'commonSuffix' __m1__ __m2__ '==' __m3__ --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> __m1__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> __m2__ = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] --- >>> __m3__ = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 2)] --- @ --- @ --- >>> 'commonSuffix' __m1__ __m2__ '==' __m3__ --- 'True' --- @ --- -commonSuffix - :: (Ord k, MonoidNull v, RightGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -commonSuffix = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- commonSuffix a mempty ≡ mempty - - , withNonNullR = - keepNull - -- Justification: - -- - -- commonSuffix mempty a ≡ mempty - - , withNonNullP = - withBoth C.commonSuffix - } -{-# INLINE commonSuffix #-} - --- | Strips the /greatest common prefix/ from a pair of maps. --- --- Given two maps __@m1@__ and __@m2@__, 'stripCommonPrefix' produces a --- tuple __@(p, r1, r2)@__, where: --- --- - __@p@__ is the /greatest common prefix/ of __@m1@__ and __@m2@__ --- - __@r1@__ is the /remainder/ of stripping prefix __@p@__ from __@m1@__ --- - __@r2@__ is the /remainder/ of stripping prefix __@p@__ from __@m2@__ --- --- The resulting prefix __@p@__ can be appended to the /left-hand/ side of --- either remainder __@r1@__ or __@r2@__ to /reproduce/ either of the original --- maps __@m1@__ or __@m2@__ respectively: --- --- @ --- 'stripCommonPrefix' m1 m2 --- '&' \\(p, r1, _) -> p '<>' r1 '==' m1 --- 'stripCommonPrefix' m1 m2 --- '&' \\(p, _, r2) -> p '<>' r2 '==' m2 --- @ --- --- Prefix __@p@__ is /identical/ to the result of applying 'commonPrefix' to --- __@m1@__ and __@m2@__: --- --- @ --- 'stripCommonPrefix' m1 m2 --- '&' \\(p, _, _) -> p '==' 'commonPrefix' m1 m2 --- @ --- --- Remainders __@r1@__ and __@r2@__ are /identical/ to the results of applying --- 'stripPrefix' to __@p@__ and __@m1@__ or to __@p@__ and __@m2@__ --- respectively: --- --- @ --- 'stripCommonPrefix' m1 m2 --- '&' \\(p, r1, _) -> 'Just' r1 '==' 'stripPrefix' p m1 --- 'stripCommonPrefix' m1 m2 --- '&' \\(p, _, r2) -> 'Just' r2 '==' 'stripPrefix' p m2 --- @ --- --- This function provides the definition of 'C.stripCommonPrefix' for the --- 'MonoidMap' instance of 'LeftGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1, "+++"), (2, "a++"), (3, "aa+"), (4, "aaa")] --- >>> m2 = 'fromList' [(1, "---"), (2, "a--"), (3, "aa-"), (4, "aaa")] --- @ --- @ --- >>> p = 'fromList' [(1, "" ), (2, "a" ), (3, "aa" ), (4, "aaa")] --- >>> r1 = 'fromList' [(1, "+++"), (2, "++"), (3, "+"), (4, "")] --- >>> r2 = 'fromList' [(1, "---"), (2, "--"), (3, "-"), (4, "")] --- @ --- @ --- >>> 'stripCommonPrefix' m1 m2 '==' (p, r1, r2) --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] --- @ --- @ --- >>> p = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] --- >>> r1 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] --- >>> r2 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] --- @ --- @ --- >>> 'stripCommonPrefix' m1 m2 '==' (p, r1, r2) --- 'True' --- @ --- -stripCommonPrefix - :: (Ord k, MonoidNull v, LeftGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) -stripCommonPrefix = C.stripCommonPrefix - --- | Strips the /greatest common suffix/ from a pair of maps. --- --- Given two maps __@m1@__ and __@m2@__, 'stripCommonSuffix' produces a --- tuple __@(r1, r2, s)@__, where: --- --- - __@s@__ is the /greatest common suffix/ of __@m1@__ and __@m2@__ --- - __@r1@__ is the /remainder/ of stripping suffix __@s@__ from __@m1@__ --- - __@r2@__ is the /remainder/ of stripping suffix __@s@__ from __@m2@__ --- --- The resulting suffix __@s@__ can be appended to the /right-hand/ side of --- either remainder __@r1@__ or __@r2@__ to /reproduce/ either of the original --- maps __@m1@__ or __@m2@__ respectively: --- --- @ --- 'stripCommonSuffix' m1 m2 --- '&' \\(r1, _, s) -> r1 '<>' s '==' m1 --- 'stripCommonSuffix' m1 m2 --- '&' \\(_, r2, s) -> r2 '<>' s '==' m2 --- @ --- --- Suffix __@s@__ is /identical/ to the result of applying 'commonSuffix' to --- __@m1@__ and __@m2@__: --- --- @ --- 'stripCommonSuffix' m1 m2 --- '&' \\(_, _, s) -> s '==' 'commonSuffix' m1 m2 --- @ --- --- Remainders __@r1@__ and __@r2@__ are /identical/ to the results of applying --- 'stripSuffix' to __@s@__ and __@m1@__ or to __@s@__ and __@m2@__ --- respectively: --- --- @ --- 'stripCommonSuffix' m1 m2 --- '&' \\(r1, _, s) -> 'Just' r1 '==' 'stripSuffix' s m1 --- 'stripCommonSuffix' m1 m2 --- '&' \\(_, r2, s) -> 'Just' r2 '==' 'stripSuffix' s m2 --- @ --- --- This function provides the definition of 'C.stripCommonSuffix' for the --- 'MonoidMap' instance of 'RightGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1, "+++"), (2, "++a"), (3, "+aa"), (4, "aaa")] --- >>> m2 = 'fromList' [(1, "---"), (2, "--a"), (3, "-aa"), (4, "aaa")] --- @ --- @ --- >>> r1 = 'fromList' [(1, "+++"), (2, "++" ), (3, "+" ), (4, "" )] --- >>> r2 = 'fromList' [(1, "---"), (2, "--" ), (3, "-" ), (4, "" )] --- >>> s = 'fromList' [(1, ""), (2, "a"), (3, "aa"), (4, "aaa")] --- @ --- @ --- >>> 'stripCommonSuffix' m1 m2 '==' (r1, r2, s) --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] --- @ --- @ --- >>> r1 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] --- >>> r2 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] --- >>> s = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] --- @ --- @ --- >>> 'stripCommonSuffix' m1 m2 '==' (r1, r2, s) --- 'True' --- @ --- -stripCommonSuffix - :: (Ord k, MonoidNull v, RightGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) -stripCommonSuffix = C.stripCommonSuffix - --------------------------------------------------------------------------------- --- Overlap --------------------------------------------------------------------------------- - --- | Finds the /greatest overlap/ of two maps. --- --- The /greatest overlap/ __@o@__ of maps __@m1@__ and __@m2@__ is the /unique/ --- greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of __@m2@__: --- --- @ --- m1 '==' r1 '<>' o \ \ --- m2 '==' \ \ o '<>' r2 --- @ --- --- Where: --- --- - __@r1@__ is the /remainder/ obtained by stripping /suffix overlap/ --- __@o@__ from __@m1@__. --- --- (see 'stripSuffixOverlap') --- --- - __@r2@__ is the /remainder/ obtained by stripping /prefix overlap/ --- __@o@__ from __@m2@__. --- --- (see 'stripPrefixOverlap') --- --- This function satisfies the following property: --- --- @ --- 'get' k ('overlap' m1 m2) '==' 'C.overlap' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.overlap' for the 'MonoidMap' --- instance of 'OverlappingGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde "), (4,"abcdef")] --- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3," bcdef"), (4,"abcdef")] --- >>> m3 = 'fromList' [(1, "" ), (2, "cd" ), (3," bcde" ), (4,"abcdef")] --- @ --- @ --- >>> 'overlap' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] --- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 1), ("e", 0)] --- @ --- @ --- >>> 'overlap' m1 m2 '==' m3 --- 'True' --- @ --- -overlap - :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -overlap = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- overlap a mempty ≡ mempty - - , withNonNullR = - keepNull - -- Justification: - -- - -- overlap mempty a ≡ mempty - - , withNonNullP = - withBoth C.overlap - } -{-# INLINE overlap #-} - --- | /Strips/ from the second map its /greatest prefix overlap/ with suffixes --- of the first map. --- --- Evaluating 'stripPrefixOverlap' __@m1@__ __@m2@__ produces the /remainder/ --- __@r2@__: --- --- @ --- m1 '==' r1 '<>' o \ \ --- m2 '==' \ \ o '<>' r2 --- @ --- --- Where __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the --- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of --- __@m2@__. --- --- This function satisfies the following property: --- --- @ --- 'get' k ('stripPrefixOverlap' m1 m2) --- '==' 'C.stripPrefixOverlap' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.stripPrefixOverlap' for the --- 'MonoidMap' instance of 'OverlappingGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde" ), (4,"abcdef")] --- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3, "bcdef"), (4,"abcdef")] --- >>> m3 = 'fromList' [(1, "def"), (2, "ef"), (3, "f"), (4, "")] --- @ --- @ --- >>> 'stripPrefixOverlap' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] --- >>> m3 = 'fromList' [("a", 4), ("b", 2), ("c", 0), ("d", 0), ("e", 0)] --- @ --- @ --- >>> 'stripPrefixOverlap' m1 m2 '==' m3 --- 'True' --- @ --- -stripPrefixOverlap - :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -stripPrefixOverlap = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- overlap a b <> stripPrefixOverlap a b ≡ b - -- overlap a mempty <> stripPrefixOverlap a mempty ≡ mempty - -- mempty <> stripPrefixOverlap a mempty ≡ mempty - -- stripPrefixOverlap a mempty ≡ mempty - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- overlap a b <> stripPrefixOverlap a b ≡ b - -- overlap mempty b <> stripPrefixOverlap mempty b ≡ b - -- mempty <> stripPrefixOverlap mempty b ≡ b - -- stripPrefixOverlap mempty b ≡ b - - , withNonNullP = - withBoth C.stripPrefixOverlap - } -{-# INLINE stripPrefixOverlap #-} - --- | /Strips/ from the second map its /greatest suffix overlap/ with prefixes --- of the first map. --- --- Evaluating 'stripSuffixOverlap' __@m2@__ __@m1@__ produces the /remainder/ --- __@r1@__: --- --- @ --- m1 '==' r1 '<>' o \ \ --- m2 '==' \ \ o '<>' r2 --- @ --- --- Where __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the --- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ of --- __@m2@__. --- --- This function satisfies the following property: --- --- @ --- 'get' k ('stripSuffixOverlap' m2 m1) --- '==' 'C.stripSuffixOverlap' ('get' k m2) ('get' k m1) --- @ --- --- This function provides the definition of 'C.stripSuffixOverlap' for the --- 'MonoidMap' instance of 'OverlappingGCDMonoid'. --- --- === __Examples__ --- --- With 'String' values: --- --- @ --- >>> m1 = 'fromList' [(1,"abc" ), (2,"abcd" ), (3,"abcde" ), (4,"abcdef")] --- >>> m2 = 'fromList' [(1, "def"), (2, "cdef"), (3, "bcdef"), (4,"abcdef")] --- >>> m3 = 'fromList' [(1,"abc" ), (2,"ab" ), (3,"a" ), (4,"" )] --- @ --- @ --- >>> 'stripSuffixOverlap' m2 m1 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m2 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1), ("e", 0)] --- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 2), ("e", 4)] --- @ --- @ --- >>> 'stripSuffixOverlap' m2 m1 '==' m3 --- 'True' --- @ --- -stripSuffixOverlap - :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -stripSuffixOverlap = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- stripSuffixOverlap b a <> overlap a b ≡ a - -- stripSuffixOverlap b mempty <> overlap mempty b ≡ mempty - -- stripSuffixOverlap b mempty <> mempty ≡ mempty - -- stripSuffixOverlap b mempty ≡ mempty - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- stripSuffixOverlap b a <> overlap a b ≡ a - -- stripSuffixOverlap mempty a <> overlap a mempty ≡ a - -- stripSuffixOverlap mempty a <> mempty ≡ a - -- stripSuffixOverlap mempty a ≡ a - - , withNonNullP = - withBoth C.stripSuffixOverlap - } -{-# INLINE stripSuffixOverlap #-} - --- | Finds the /greatest overlap/ of two maps and /strips/ it from both maps. --- --- Evaluating 'stripOverlap' __@m1@__ __@m2@__ produces the tuple --- __@(r1, o, r2)@__, where: --- --- @ --- m1 '==' r1 '<>' o \ \ --- m2 '==' \ \ o '<>' r2 --- @ --- --- Where: --- --- - __@o@__ is the /greatest overlap/ of maps __@m1@__ and __@m2@__: the --- /unique/ greatest map that is both a /suffix/ of __@m1@__ and a /prefix/ --- of __@m2@__. --- --- (see 'overlap') --- --- - __@r1@__ is the /remainder/ obtained by stripping /suffix overlap/ --- __@o@__ from __@m1@__. --- --- (see 'stripSuffixOverlap') --- --- - __@r2@__ is the /remainder/ obtained by stripping /prefix overlap/ --- __@o@__ from __@m2@__. --- --- (see 'stripPrefixOverlap') --- --- This function satisfies the following property: --- --- @ --- 'stripOverlap' m1 m2 '==' --- ( 'stripSuffixOverlap' m2 m1 --- , 'overlap' m1 m2 --- , 'stripPrefixOverlap' m1 m2 --- ) --- @ --- --- This function provides the definition of 'C.stripOverlap' for the --- 'MonoidMap' instance of 'OverlappingGCDMonoid'. --- -stripOverlap - :: (Ord k, MonoidNull v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> (MonoidMap k v, MonoidMap k v, MonoidMap k v) -stripOverlap m1 m2 = - ( stripSuffixOverlap m2 m1 - , m1 `overlap` m2 - , stripPrefixOverlap m1 m2 - ) - --------------------------------------------------------------------------------- --- Intersection --------------------------------------------------------------------------------- - --- | Finds the /intersection/ of two maps. --- --- The intersection of maps __@m1@__ and __@m2@__ is the greatest single map --- __@m@__ that is a /submap/ of both __@m1@__ /and/ __@m2@__: --- --- @ --- 'intersection' m1 m2 '`isSubmapOf`' m1 --- 'intersection' m1 m2 '`isSubmapOf`' m2 --- @ --- --- The intersection is /unique/: --- --- @ --- 'and' --- [ 'intersection' m1 m2 '`isSubmapOf`' m --- , \ \ \ \ m '`isSubmapOf`' m1 --- , \ \ \ \ m '`isSubmapOf`' m2 --- ] --- ==> --- (m '==' 'intersection' m1 m2) --- @ --- --- The following property holds for all possible keys __@k@__: --- --- @ --- 'get' k ('intersection' m1 m2) '==' 'C.gcd' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.gcd' for the 'MonoidMap' --- instance of 'GCDMonoid'. --- --- === __Examples__ --- --- With 'Data.Monoid.Product' 'Numeric.Natural.Natural' values, this function --- computes the /greatest common divisor/ of each pair of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 6), ("c", 15), ("d", 35)] --- >>> m2 = 'fromList' [("a", 6), ("b", 15), ("c", 35), ("d", 77)] --- >>> m3 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 7)] --- @ --- @ --- >>> 'intersection' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function --- computes the /minimum/ of each pair of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] --- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 1), ("d", 0)] --- @ --- @ --- >>> 'intersection' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Set' 'Numeric.Natural.Natural' values, this function computes the --- /set/ /intersection/ of each pair of matching values: --- --- @ --- f xs = 'fromList' ('Set.fromList' '<$>' xs) --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] --- >>> m2 = f [("a", [0,1,2]), ("b", [ 1,2,3]), ("c", [ 2,3,4])] --- >>> m3 = f [("a", [0,1,2]), ("b", [ 1,2 ]), ("c", [ 2 ])] --- @ --- @ --- >>> 'intersection' m1 m2 '==' m3 --- 'True' --- @ --- -intersection - :: (Ord k, MonoidNull v, GCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -intersection = merge MergeStrategy - { withNonNullL = - keepNull - -- Justification: - -- - -- gcd a mempty ≡ mempty - - , withNonNullR = - keepNull - -- Justification: - -- - -- gcd mempty b ≡ mempty - - , withNonNullP = - withBoth C.gcd - } -{-# INLINE intersection #-} - --------------------------------------------------------------------------------- --- Union --------------------------------------------------------------------------------- - --- | Finds the /union/ of two maps. --- --- The union of maps __@m1@__ and __@m2@__ is the smallest single map __@m@__ --- that includes both __@m1@__ /and/ __@m2@__ as /submaps/: --- --- @ --- m1 '`isSubmapOf`' 'union' m1 m2 --- m2 '`isSubmapOf`' 'union' m1 m2 --- @ --- --- The union is /unique/: --- --- @ --- 'and' --- [ m1 '`isSubmapOf`' m --- , m2 '`isSubmapOf`' m --- , \ \ m '`isSubmapOf`' 'union' m1 m2 --- ] --- ==> --- (m '==' 'union' m1 m2) --- @ --- --- The following property holds for all possible keys __@k@__: --- --- @ --- 'get' k ('union' m1 m2) '==' 'C.lcm' ('get' k m1) ('get' k m2) --- @ --- --- This function provides the definition of 'C.lcm' for the 'MonoidMap' --- instance of 'LCMMonoid'. --- --- === __Examples__ --- --- With 'Data.Monoid.Product' 'Numeric.Natural.Natural' values, this function --- computes the /least common multiple/ of each pair of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 6), ("c", 15), ("d", 35)] --- >>> m2 = 'fromList' [("a", 6), ("b", 15), ("c", 35), ("d", 77)] --- >>> m3 = 'fromList' [("a", 6), ("b", 30), ("c", 105), ("d", 385)] --- @ --- @ --- >>> 'union' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function --- computes the /maximum/ of each pair of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 3), ("b", 2), ("c", 1), ("d", 0)] --- >>> m3 = 'fromList' [("a", 3), ("b", 2), ("c", 2), ("d", 3)] --- @ --- @ --- >>> 'union' m1 m2 '==' m3 --- 'True' --- @ --- --- With 'Set' 'Numeric.Natural.Natural' values, this function computes the --- /set/ /union/ of each pair of matching values: --- --- @ --- f xs = 'fromList' ('Set.fromList' '<$>' xs) --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] --- >>> m2 = f [("a", [0,1,2]), ("b", [ 1,2,3]), ("c", [ 2,3,4])] --- >>> m3 = f [("a", [0,1,2]), ("b", [0,1,2,3]), ("c", [0,1,2,3,4])] --- @ --- @ --- >>> 'union' m1 m2 '==' m3 --- 'True' --- @ --- -union - :: (Ord k, MonoidNull v, LCMMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -union = merge MergeStrategy - { withNonNullL = - keepNonNull - -- Justification: - -- - -- lcm a mempty ≡ a - - , withNonNullR = - keepNonNull - -- Justification: - -- - -- lcm mempty a ≡ a - - , withNonNullP = - withBoth C.lcm - } -{-# INLINE union #-} - --------------------------------------------------------------------------------- --- Subtraction --------------------------------------------------------------------------------- - --- | Performs /group subtraction/ of the second map from the first. --- --- Uses the 'Group' subtraction operator '(C.~~)' to subtract each value in the --- second map from its matching value in the first map. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k (m1 '`minus`' m2) '==' 'get' k m1 'C.~~' 'get' k m2 --- @ --- --- This function provides the definition of '(C.~~)' for the 'MonoidMap' --- instance of 'Group'. --- --- === __Examples__ --- --- With 'Data.Monoid.Sum' 'Integer' values, this function performs normal --- integer subtraction of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", (-1)), ("b", 0 ), ("c", 1)] --- >>> m2 = 'fromList' [("a", 1 ), ("b", 1 ), ("c", 1)] --- >>> m3 = 'fromList' [("a", (-2)), ("b", (-1)), ("c", 0)] --- @ --- @ --- >>> m1 '`minus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", (-1)), ("b", 0 ), ("c", 1 )] --- >>> m2 = 'fromList' [("a", (-1)), ("b", (-1)), ("c", (-1))] --- >>> m3 = 'fromList' [("a", 0 ), ("b", 1 ), ("c", 2 )] --- @ --- @ --- >>> m1 '`minus`' m2 '==' m3 --- 'True' --- @ --- -minus - :: (Ord k, MonoidNull v, Group v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -minus = merge MergeStrategy - { withNonNullL = - keepNonNull - -- Justification: - -- - -- a ~~ mempty ≡ a - - , withNonNullR = - withNonNull C.invert - -- Justification: - -- - -- a ~~ b ≡ a <> invert b - -- mempty ~~ b ≡ mempty <> invert b - -- mempty ~~ b ≡ invert b - - , withNonNullP = - withBoth (C.~~) - } -{-# INLINE minus #-} - --- | Performs /reductive subtraction/ of the second map from the first. --- --- Uses the 'Reductive' subtraction operator '()' to subtract each value in --- the second map from its matching value in the first map. --- --- This function produces a result if (and only if) for all possible keys --- __@k@__, it is possible to subtract the value for __@k@__ in the second map --- from the value for __@k@__ in the first map: --- --- @ --- 'isJust' (m1 '`minusMaybe`' m2) --- '==' (∀ k. 'isJust' ('get' k m1 '' 'get' k m2)) --- @ --- --- Otherwise, this function returns 'Nothing'. --- --- This function satisfies the following property: --- --- @ --- 'all' --- (\\r -> 'Just' ('get' k r) '==' 'get' k m1 '' 'get' k m2) --- (m1 '`minusMaybe`' m2) --- @ --- --- This function provides the definition of '()' for the 'MonoidMap' --- instance of 'Reductive'. --- --- === __Examples__ --- --- With 'Set' 'Numeric.Natural.Natural' values, this function performs /set/ --- /subtraction/ of matching values, succeeding if (and only if) each value --- from the second map is a subset of its matching value from the first map: --- --- @ --- f xs = 'fromList' ('Set.fromList' '<$>' xs) --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2])] --- >>> m2 = f [("a", [ ]), ("b", [0,1,2])] --- >>> m3 = f [("a", [0,1,2]), ("b", [ ])] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 --- 'True' --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2]), ("c", [0,1,2])] --- >>> m2 = f [("a", [0 ]), ("b", [ 1 ]), ("c", [ 2])] --- >>> m3 = f [("a", [ 1,2]), ("b", [0, 2]), ("c", [0,1 ])] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 --- 'True' --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2 ]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] --- >>> m2 = f [("a", [ 2,3,4]), ("b", [ 1,2,3,4]), ("c", [0,1,2,3,4])] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Nothing' --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function --- performs /ordinary/ /subtraction/ of matching values, succeeding if (and only --- if) each value from the second map is less than or equal to its matching --- value from the first map: --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- >>> m2 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] --- >>> m3 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- >>> m2 = 'fromList' [("a", 1), ("b", 2), ("c", 3), ("d", 5)] --- >>> m3 = 'fromList' [("a", 1), ("b", 1), ("c", 2), ("d", 3)] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- >>> m2 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Just' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 2), ("b", 3), ("c", 5), ("d", 8)] --- >>> m2 = 'fromList' [("a", 3), ("b", 3), ("c", 5), ("d", 8)] --- @ --- @ --- >>> m1 '`minusMaybe`' m2 '==' 'Nothing' --- 'True' --- @ --- -minusMaybe - :: (Ord k, MonoidNull v, Reductive v) - => MonoidMap k v - -> MonoidMap k v - -> Maybe (MonoidMap k v) -minusMaybe = mergeA MergeStrategy - { withNonNullL = - keepNonNull - -- Justification: - -- - -- According to laws for Reductive: - -- maybe a (b <>) (a b ) ≡ a - -- maybe a (mempty <>) (a mempty) ≡ a - -- maybe a (id ) (a mempty) ≡ a - -- (a mempty) ∈ {Just a, Nothing} - -- - -- According to laws for LeftReductive and RightReductive: - -- isJust (a b ) ≡ b `isPrefixOf` a ≡ b `isSuffixOf` a - -- isJust (a mempty) ≡ mempty `isPrefixOf` a ≡ mempty `isSuffixOf` a - -- - -- According to laws for LeftReductive and RightReductive: - -- b `isPrefixOf` (b <> a) - -- mempty `isPrefixOf` (mempty <> a) - -- mempty `isPrefixOf` a - -- - -- Therefore: - -- a mempty ≡ Just a - - , withNonNullR = - withNonNullA (\v -> mempty v) - - , withNonNullP = - withBothA () - } -{-# INLINE minusMaybe #-} - --- | Performs /monus subtraction/ of the second map from the first. --- --- Uses the 'Monus' subtraction operator '(<\>)' to subtract each value in --- the second map from its matching value in the first map. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k (m1 '`monus`' m2) '==' 'get' k m1 '<\>' 'get' k m2 --- @ --- --- This function provides the definition of '(<\>)' for the 'MonoidMap' --- instance of 'Monus'. --- --- === __Examples__ --- --- With 'Set' 'Numeric.Natural.Natural' values, this function performs /set/ --- /subtraction/ of matching values: --- --- @ --- f xs = 'fromList' ('Set.fromList' '<$>' xs) --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2])] --- >>> m2 = f [("a", [ ]), ("b", [0,1,2])] --- >>> m3 = f [("a", [0,1,2]), ("b", [ ])] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2]), ("b", [0,1,2]), ("c", [0,1,2])] --- >>> m2 = f [("a", [0 ]), ("b", [ 1 ]), ("c", [ 2])] --- >>> m3 = f [("a", [ 1,2]), ("b", [0, 2]), ("c", [0,1 ])] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = f [("a", [0,1,2 ]), ("b", [0,1,2 ]), ("c", [0,1,2 ])] --- >>> m2 = f [("a", [ 2,3,4]), ("b", [ 1,2,3,4]), ("c", [0,1,2,3,4])] --- >>> m3 = f [("a", [0,1 ]), ("b", [0 ]), ("c", [ ])] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function --- performs /truncated/ /subtraction/ of matching values: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] --- >>> m3 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 1), ("b", 1), ("c", 1), ("d", 1)] --- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 1), ("d", 2)] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 2), ("b", 2), ("c", 2), ("d", 2)] --- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 1)] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 4), ("b", 4), ("c", 4), ("d", 4)] --- >>> m3 = 'fromList' [("a", 0), ("b", 0), ("c", 0), ("d", 0)] --- @ --- @ --- >>> m1 '`monus`' m2 '==' m3 --- 'True' --- @ --- -monus - :: (Ord k, MonoidNull v, Monus v) - => MonoidMap k v - -> MonoidMap k v - -> MonoidMap k v -monus = merge MergeStrategy - { withNonNullL = - keepNonNull - -- Justification: - -- - -- a <> (b <\> a ) ≡ b <> (a <\> b) - -- mempty <> (b <\> mempty) ≡ b <> (mempty <\> a) - -- b <\> mempty ≡ b <> (mempty <\> a) - -- b <\> mempty ≡ b <> mempty - -- b <\> mempty ≡ b - - , withNonNullR = - keepNull - -- Justification: - -- - -- mempty <\> a ≡ mempty - - , withNonNullP = - withBoth (<\>) - } -{-# INLINE monus #-} - --------------------------------------------------------------------------------- --- Inversion --------------------------------------------------------------------------------- - --- | Inverts every value in a map. --- --- Applies the 'Group' method 'C.invert' to every value in a map. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('invert' m) '==' 'C.invert' ('get' k m) --- @ --- --- This function provides the definition of 'C.invert' for the 'MonoidMap' --- instance of 'Group'. --- --- === __Examples__ --- --- With 'Data.Monoid.Sum' 'Integer' values, this function performs negation --- of values: --- --- @ --- >>> m1 = 'fromList' [("a", (-1)), ("b", 0), ("c", 1) ] --- >>> m2 = 'fromList' [("a", 1 ), ("b", 0), ("c", (-1))] --- @ --- @ --- >>> 'negate' m1 '==' m2 --- 'True' --- @ --- -invert - :: (MonoidNull v, Group v) - => MonoidMap k v - -> MonoidMap k v -invert = map C.invert -{-# INLINE invert #-} - --------------------------------------------------------------------------------- --- Exponentiation --------------------------------------------------------------------------------- - --- | Performs exponentiation of every value in a map. --- --- Uses the 'Group' exponentiation method 'C.pow' to raise every value in a map --- to the power of the given exponent. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k (m '`power`' i) '==' 'get' k m '`C.pow`' i --- @ --- --- This function provides the definition of 'C.pow' for the 'MonoidMap' --- instance of 'Group'. --- --- === __Examples__ --- --- With 'Data.Monoid.Sum' 'Numeric.Natural.Natural' values, this function --- performs /ordinary multiplication/ of all values by the given exponent: --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1), ("c", 2), ("d", 3)] --- >>> m2 = 'fromList' [("a", 0), ("b", 2), ("c", 4), ("d", 6)] --- @ --- @ --- >>> m1 '`power`' 2 '==' m2 --- 'True' --- @ --- --- @ --- >>> m1 = 'fromList' [("a", 0), ("b", 1 ), ("c", 2 ), ("d", 3 )] --- >>> m2 = 'fromList' [("a", 0), ("b", (-1)), ("c", (-2)), ("d", (-3))] --- @ --- @ --- >>> m1 '`power`' (-1) '==' m2 --- 'True' --- @ --- -power - :: (Integral i, MonoidNull v, Group v) - => MonoidMap k v - -> i - -> MonoidMap k v -power m i = map (`C.pow` i) m -{-# INLINE power #-} - --------------------------------------------------------------------------------- --- Intersection --------------------------------------------------------------------------------- - --- | Computes the /intersection/ of a pair of maps using the given function --- to combine values for matching keys. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('intersectionWith' f m1 m2) '==' --- if k '`Set.member`' --- 'Set.intersection' --- ('nonNullKeys' m1) --- ('nonNullKeys' m2) --- then f ('get' k m1) ('get' k m2) --- else 'mempty' --- @ --- --- === Conditional totality --- --- /If/ the given combining function __@f@__ /always/ produces 'mempty' when --- /either/ or /both/ of its arguments are 'mempty': --- --- @ --- (f v 'mempty' '==' 'mempty') '&&' --- (f 'mempty' v '==' 'mempty') --- @ --- --- /Then/ the following property holds for all possible keys __@k@__: --- --- @ --- 'get' k ('intersectionWith' f m1 m2) '==' f ('get' k m1) ('get' k m2) --- @ --- --- === __Examples__ --- --- With the 'Prelude.min' function applied to 'Data.Monoid.Sum' --- 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1) ] --- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m3 = 'fromList' [ ("b", 1), ("c", 2), ("d", 1) ] --- @ --- @ --- >>> 'intersectionWith' 'Prelude.min' m1 m2 '==' m3 --- 'True' --- @ --- -intersectionWith - :: (Ord k, MonoidNull v3) - => (v1 -> v2 -> v3) - -- ^ Function with which to combine values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> MonoidMap k v3 -intersectionWith f = merge MergeStrategy - { withNonNullL = - keepNull - , withNonNullR = - keepNull - , withNonNullP = - withBoth f - } -{-# INLINE intersectionWith #-} - --- | An /applicative/ version of 'intersectionWith'. --- --- Satisfies the following property: --- --- @ --- 'runIdentity' ('intersectionWithA' (('fmap' . 'fmap') 'Identity' f) m1 m2) --- '==' ('intersectionWith' \ \ \ \ \ \ f m1 m2) --- @ --- -intersectionWithA - :: (Applicative f, Ord k, MonoidNull v3) - => (v1 -> v2 -> f v3) - -- ^ Function with which to combine values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> f (MonoidMap k v3) -intersectionWithA f = mergeA MergeStrategy - { withNonNullL = - keepNull - , withNonNullR = - keepNull - , withNonNullP = - withBothA f - } -{-# INLINE intersectionWithA #-} - --------------------------------------------------------------------------------- --- Union --------------------------------------------------------------------------------- - --- | Computes the /union/ of a pair of maps using the given function to combine --- values for matching keys. --- --- Satisfies the following property for all possible keys __@k@__: --- --- @ --- 'get' k ('unionWith' f m1 m2) '==' --- if k '`Set.member`' --- 'Set.union' --- ('nonNullKeys' m1) --- ('nonNullKeys' m2) --- then f ('get' k m1) ('get' k m2) --- else 'mempty' --- @ --- --- === Conditional totality --- --- /If/ the given combining function __@f@__ /always/ produces 'mempty' when --- /both/ of its arguments are 'mempty': --- --- @ --- f 'mempty' 'mempty' '==' 'mempty' --- @ --- --- /Then/ the following property holds for all possible keys __@k@__: --- --- @ --- 'get' k ('unionWith' f m1 m2) '==' f ('get' k m1) ('get' k m2) --- @ --- --- === __Examples__ --- --- With the 'Prelude.max' function applied to 'Data.Monoid.Sum' --- 'Numeric.Natural.Natural' values: --- --- @ --- >>> m1 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 1) ] --- >>> m2 = 'fromList' [ ("b", 1), ("c", 2), ("d", 3), ("e", 4)] --- >>> m3 = 'fromList' [("a", 4), ("b", 3), ("c", 2), ("d", 3), ("e", 4)] --- @ --- @ --- >>> 'unionWith' 'Prelude.max' m1 m2 '==' m3 --- 'True' --- @ --- -unionWith - :: (Ord k, Monoid v1, Monoid v2, MonoidNull v3) - => (v1 -> v2 -> v3) - -- ^ Function with which to combine values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> MonoidMap k v3 -unionWith f = merge MergeStrategy - { withNonNullL = - withNonNull (\v -> f v mempty) - , withNonNullR = - withNonNull (\v -> f mempty v) - , withNonNullP = - withBoth f - } -{-# INLINE unionWith #-} - --- | An /applicative/ version of 'unionWith'. --- --- Satisfies the following property: --- --- @ --- 'runIdentity' ('unionWithA' (('fmap' . 'fmap') 'Identity' f) m1 m2) --- '==' ('unionWith' \ \ \ \ \ \ f m1 m2) --- @ --- -unionWithA - :: (Applicative f, Ord k, Monoid v1, Monoid v2, MonoidNull v3) - => (v1 -> v2 -> f v3) - -- ^ Function with which to combine values for matching keys. - -> MonoidMap k v1 - -> MonoidMap k v2 - -> f (MonoidMap k v3) -unionWithA f = mergeA MergeStrategy - { withNonNullL = - withNonNullA (\v -> f v mempty) - , withNonNullR = - withNonNullA (\v -> f mempty v) - , withNonNullP = - withBothA f - } -{-# INLINE unionWithA #-} - --------------------------------------------------------------------------------- --- Merging --------------------------------------------------------------------------------- - -type WhenOneSideNull f k vx vr - = Map.WhenMissing f k (NonNull vx) (NonNull vr) -type WhenBothNonNull f k v1 v2 vr - = Map.WhenMatched f k (NonNull v1) (NonNull v2) (NonNull vr) - -data MergeStrategy f k v1 v2 v3 = MergeStrategy - { withNonNullL :: !(WhenOneSideNull f k v1 v3) - , withNonNullR :: !(WhenOneSideNull f k v2 v3) - , withNonNullP :: !(WhenBothNonNull f k v1 v2 v3) - } - -merge - :: Ord k - => MergeStrategy Identity k v1 v2 v3 - -> MonoidMap k v1 - -> MonoidMap k v2 - -> MonoidMap k v3 -merge (MergeStrategy nnl nnr nnp) (MonoidMap m1) (MonoidMap m2) = - MonoidMap $ Map.merge nnl nnr nnp m1 m2 -{-# INLINE merge #-} - -mergeA - :: (Applicative f, Ord k) - => MergeStrategy f k v1 v2 v3 - -> MonoidMap k v1 - -> MonoidMap k v2 - -> f (MonoidMap k v3) -mergeA (MergeStrategy nnl nnr nnp) (MonoidMap m1) (MonoidMap m2) = - MonoidMap <$> Map.mergeA nnl nnr nnp m1 m2 -{-# INLINE mergeA #-} - -keepNull - :: Applicative f - => WhenOneSideNull f k v1 v2 -keepNull = Map.dropMissing -{-# INLINE keepNull #-} - -keepNonNull - :: Applicative f - => WhenOneSideNull f k v v -keepNonNull = Map.preserveMissing -{-# INLINE keepNonNull #-} - -withNonNull - :: (Applicative f, MonoidNull v2) - => (v1 -> v2) - -> WhenOneSideNull f k v1 v2 -withNonNull f - = Map.mapMaybeMissing - $ \_k v -> maybeNonNull $ applyNonNull f v -{-# INLINE withNonNull #-} - -withNonNullA - :: (Applicative f, MonoidNull v2) - => (v1 -> f v2) - -> WhenOneSideNull f k v1 v2 -withNonNullA f - = Map.traverseMaybeMissing - $ \_k v -> maybeNonNull <$> applyNonNull f v -{-# INLINE withNonNullA #-} - -withBoth - :: (Applicative f, MonoidNull v3) - => (v1 -> v2 -> v3) - -> WhenBothNonNull f k v1 v2 v3 -withBoth f - = Map.zipWithMaybeMatched - $ \_k v1 v2 -> maybeNonNull $ applyNonNull2 f v1 v2 -{-# INLINE withBoth #-} - -withBothA - :: (Applicative f, MonoidNull v3) - => (v1 -> v2 -> f v3) - -> WhenBothNonNull f k v1 v2 v3 -withBothA f - = 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/internal/Data/MonoidMap/Unsafe.hs b/src/internal/Data/MonoidMap/Unsafe.hs deleted file mode 100644 --- a/src/internal/Data/MonoidMap/Unsafe.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- Provides /unsafe/ operations for the 'MonoidMap' type. --- -module Data.MonoidMap.Unsafe - ( - -- * Construction - unsafeFromMap - ) - where - -import Prelude - -import Data.Coerce - ( coerce ) -import Data.Map.Strict - ( Map ) -import Data.MonoidMap.Internal - ( MonoidMap (..), NonNull (..), fromMap ) - -import qualified Data.Foldable as F -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap.Internal as Internal - --------------------------------------------------------------------------------- --- Unsafe construction --------------------------------------------------------------------------------- - --- | \(O(1)\). /Unsafely/ constructs a 'MonoidMap' from an ordinary 'Map'. --- --- Constructs a 'MonoidMap' in /constant time/, without imposing the burden --- of a canonicalisation step to remove 'null' values. --- --- When applied to a given 'Map' @m@, this function /expects/ but does /not/ --- check the following pre-condition: --- --- @ --- 'F.all' ('not' . 'Null.null') m --- @ --- --- Not satisfying this pre-condition will result in undefined behaviour. --- --- See 'fromMap' for a safe version of this function. --- -unsafeFromMap :: Map k v -> MonoidMap k v -unsafeFromMap = coerce diff --git a/src/public/Data/MonoidMap.hs b/src/public/Data/MonoidMap.hs deleted file mode 100644 --- a/src/public/Data/MonoidMap.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap - ( - -- * Introduction - -- $_introduction - -- $_totality - -- $_encoding - -- $_monoidal_operations - - -- * Type - MonoidMap - - -- * General operations - - -- ** Construction - , empty - , fromList - , fromListWith - , fromMap - , fromSet - , singleton - - -- ** Deconstruction - , toList - , toMap - - -- ** Lookup - , get - - -- ** Modification - , set - , adjust - , nullify - - -- ** Membership - , null - , nullKey - , nonNull - , nonNullCount - , nonNullKey - , nonNullKeys - - -- ** Slicing - , take - , drop - , splitAt - - -- ** Filtering - , filter - , filterKeys - , filterWithKey - - -- ** Partitioning - , partition - , partitionKeys - , partitionWithKey - - -- ** Mapping - , map - , mapKeys - , mapKeysWith - , mapWithKey - - -- ** Folding - , foldl - , foldl' - , foldr - , foldr' - , foldlWithKey - , foldlWithKey' - , foldrWithKey - , foldrWithKey' - , foldMapWithKey - , foldMapWithKey' - - -- ** Traversal - , traverse - , traverseWithKey - , mapAccumL - , mapAccumLWithKey - , mapAccumR - , mapAccumRWithKey - - -- * Monoidal operations - - -- | See the section on [monoidal operations](#_monoidal_operations) within - -- the [introduction](#_introduction). - - -- ** Association - , append - - -- ** Subtraction - , minus - , minusMaybe - , monus - - -- ** Inversion - , invert - - -- ** Exponentiation - , power - - -- ** Comparison - , isSubmapOf - , isSubmapOfBy - , disjoint - , disjointBy - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithA - - -- ** Union - , union - , unionWith - , unionWithA - - -- ** Prefixes - , isPrefixOf - , stripPrefix - , commonPrefix - , stripCommonPrefix - - -- ** Suffixes - , isSuffixOf - , stripSuffix - , commonSuffix - , stripCommonSuffix - - -- ** Overlap - , overlap - , stripPrefixOverlap - , stripSuffixOverlap - , stripOverlap - ) - where - -import Data.MonoidMap.Internal - --- Imports for module documentation: - -import Data.Eq - ( Eq (..) ) -import Data.Group - ( Group ((~~)) ) -import Data.Map.Strict - ( Map ) -import Data.Maybe - ( Maybe (Just, Nothing) ) -import Data.Monoid - ( Monoid (mempty) ) -import Data.Monoid.GCD - ( GCDMonoid ) -import Data.Monoid.LCM - ( LCMMonoid ) -import Data.Monoid.Monus - ( Monus ((<\>)) ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.Ord - ( Ord ) -import Data.Semigroup - ( Semigroup ((<>)) ) - -import qualified Data.Map.Strict as SMap -import qualified Data.MonoidMap.Internal as MMap - -import qualified Data.Group as C -import qualified Data.Monoid.GCD as C -import qualified Data.Monoid.LCM as C -import qualified Data.Monoid.Null as C - --------------------------------------------------------------------------------- --- Introduction --------------------------------------------------------------------------------- - --- $_introduction --- #_introduction# --- --- This module provides the 'MonoidMap' type, which: --- --- - models a [__total function__](#_totality) with --- [__finite support__](https://wikipedia.org/wiki/Support_\(mathematics\)) --- from keys to [__monoidal values__]("Data.Monoid"), with a default value --- of 'mempty'. --- --- - encodes key-value mappings with a [__minimal encoding__](#_encoding) that --- only includes values /not/ equal to 'mempty'. --- --- - provides a comprehensive set of --- [__monoidal operations__](#_monoidal_operations) for transforming, --- combining, and comparing maps. --- --- The documentation in this module serves as __reference guide__ to the --- 'MonoidMap' type and its operations. --- --- See the --- [@README@](https://github.com/jonathanknowles/monoidmap/blob/main/README.md) --- file for: --- --- - a __deeper introduction__ to the design of the 'MonoidMap' type. --- --- - worked examples of using 'MonoidMap' to implement more specialised --- monoidal data structures. --- --- - detailed comparisons between 'MonoidMap' and other map types. - --------------------------------------------------------------------------------- --- Totality --------------------------------------------------------------------------------- - --- $_totality --- #_totality# --- --- = Relationship between keys and values --- --- A 'MonoidMap' of key type __@k@__ and value type __@v@__ associates /every/ --- possible key of type __@k@__ with a value of type __@v@__: --- --- @ --- 'get' :: ('Ord' k, 'Monoid' v) => k -> 'MonoidMap' k v -> v --- @ --- --- The 'empty' map associates every key __@k@__ with a default value of --- 'mempty': --- --- @ --- ∀ k. 'get' k 'empty' '==' 'mempty' --- @ --- --- == Comparison with standard 'Map' type --- --- The 'MonoidMap' type differs from the standard 'Map' type in how it relates --- keys to values: --- --- +---------------------------+---------------------------------------------+ --- | Type | Models a total function with finite support | --- +===========================+=============================================+ --- | @       'Map'@__@ k v @__ | from keys of type __@k@__ | --- | | to values of type __@'Maybe' v@__. | --- +---------------------------+---------------------------------------------+ --- | @ 'MonoidMap'@__@ k v @__ | from keys of type __@k@__ | --- | | to values of type __@v@__. | --- +---------------------------+---------------------------------------------+ --- --- This difference can be illustrated by comparing the type signatures of --- operations to query a key for its value, for both types: --- --- @ --- 'Map'.'SMap.lookup' :: \ \ k -> 'Map' k v -> 'Maybe' v --- 'MonoidMap'.'MMap.get' :: 'Monoid' v => k -> 'MonoidMap' k v -> \ \ v --- @ --- --- Whereas a standard 'Map' has a default value of 'Nothing', a 'MonoidMap' has --- a default value of 'mempty': --- --- @ --- ∀ k. 'Map'.'SMap.lookup' k 'Map'.'SMap.empty' '==' 'Nothing' --- ∀ k. 'MonoidMap'.'MMap.get' k 'MonoidMap'.'MMap.empty' '==' 'mempty' --- @ --- --- In practice, the standard 'Map' type uses 'Maybe' to indicate the /presence/ --- or /absence/ of a value for a particular key. This representation is --- necessary because the 'Map' type imposes no constraints on value types. --- --- However, /monoidal/ types already have a natural way to represent null or --- empty values: the 'mempty' constant, which represents the /neutral/ or --- /identity/ element of a 'Monoid'. --- --- Consequently, using a standard 'Map' with a /monoidal/ value type gives rise --- to two distinct representations for null or empty values: --- --- +-------------------------+--------------------------------------------+ --- | @ | | --- | 'Map'.'SMap.lookup' k m | Interpretation | --- | @ | | --- +=========================+============================================+ --- | @ | 'Map' __@m@__ has /no/ entry | --- | 'Nothing' | for key __@k@__. | --- | @ | | --- +-------------------------+--------------------------------------------+ --- | @ | 'Map' __@m@__ has an entry | --- | 'Just' 'mempty' | for key __@k@__, but the value is /empty/. | --- | @ | | --- +-------------------------+--------------------------------------------+ --- --- In constrast, the 'MonoidMap' type provides a single, /canonical/ --- representation for null or empty values, according to the following --- conceptual mapping: --- --- +------------------------------------+---+------------------------------+ --- | @ | | @ | --- | 'Map'.'SMap.lookup' k m | | 'MonoidMap'.'MMap.get' k m | --- | @ | | @ | --- +====================================+===+==============================+ --- | @ | | @ | --- | 'Nothing' | ⟼ | 'mempty' | --- | @ | | @ | --- +--------------+---------------------+---+------------------------------+ --- | @ | @ | | @ | --- | 'Just' __v__ | __v__ '==' 'mempty' | ⟼ | 'mempty' | --- | @ | @ | | @ | --- +--------------+---------------------+---+------------------------------+ --- | @ | @ | | @ | --- | 'Just' __v__ | __v__ '/=' 'mempty' | ⟼ | __v__ | --- | @ | @ | | @ | --- +--------------+---------------------+---+------------------------------+ - --------------------------------------------------------------------------------- --- Encoding --------------------------------------------------------------------------------- - --- $_encoding --- #_encoding# --- --- = Encoding --- --- A 'MonoidMap' only encodes mappings from keys to values that are /not/ equal --- to 'mempty'. --- --- The total function \(T\) modelled by a 'MonoidMap' is encoded as a --- __support__ __map__ \(S\), where \(S\) is the finite subset of key-value --- mappings in \(T\) for which values are not equal to 'mempty' (denoted by --- \(\varnothing\)): --- --- \( \quad S = \{ (k, v) \in T \ | \ v \ne \varnothing \} \) --- --- == Automatic minimisation --- --- All 'MonoidMap' operations perform __automatic minimisation__ of the support --- map, so that 'mempty' values do not appear in: --- --- - any encoding of a 'MonoidMap' --- - any traversal of a 'MonoidMap' --- --- == Constraints on values --- --- 'MonoidMap' operations require the monoidal value type to be an instance of --- 'MonoidNull'. --- --- Instances of 'MonoidNull' must provide a 'C.null' indicator function that --- satisfies the following law: --- --- @ --- ∀ v. 'MonoidNull'.'C.null' v '==' (v '==' 'mempty') --- @ --- --- 'MonoidMap' operations use the 'C.null' indicator function to detect and --- exclude 'mempty' values from the support map. --- --- Note that it is /not/ generally necessary for the value type to be an --- instance of 'Eq'. - --------------------------------------------------------------------------------- --- Monoidal operations --------------------------------------------------------------------------------- - --- $_monoidal_operations --- #_monoidal_operations# --- --- = Monoidal operations --- --- The 'MonoidMap' type provides a comprehensive set of __monoidal operations__ --- for transforming, combining, and comparing maps. --- --- Instances for several __subclasses__ of 'Semigroup' and 'Monoid' are --- provided, including classes from the following libraries: --- --- - [groups](https://hackage.haskell.org/package/groups) --- - [monoid-subclasses](https://hackage.haskell.org/package/monoid-subclasses) --- --- At the root of this hierarchy of subclasses is the 'Semigroup' class, whose --- instance for 'MonoidMap' is defined in terms of the /underlying value type/, --- so that applying `(<>)` to a /pair of maps/ is equivalent to applying `(<>)` --- to all /pairs of values/ for matching keys: --- --- @ --- ∀ k. 'get' k (m1 '<>' m2) '==' 'get' k m1 '<>' 'get' k m2 --- @ --- --- In general, operations for subclasses of 'Semigroup' and 'Monoid' are --- defined /analogously/ to the 'Semigroup' instance, so that: --- --- - /unary/ operations on /individual maps/ are defined in terms of their --- distributive application to all values. --- --- - /binary/ operations on /pairs of maps/ are defined in terms of their --- distributive application to all /pairs of values/ for matching keys. --- --- Unary monoidal operations typically satisfy a property similar to: --- --- @ --- ∀ k. 'get' k (f m) '==' f ('get' k m) --- @ --- --- Binary monoidal operations typically satisfy a property similar to: --- --- @ --- ∀ k. 'get' k (f m1 m2) '==' f ('get' k m1) ('get' k m2) --- @ --- --- Defining monoidal operations in this way makes it possible to transform, --- combine, and compare maps in ways that are consistent with the algebraic --- properties of the underlying monoidal value type. diff --git a/src/test/Data/MonoidMap/AccessSpec.hs b/src/test/Data/MonoidMap/AccessSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/AccessSpec.hs +++ /dev/null @@ -1,165 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.AccessSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -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 - ( Fun, Property, applyFun, cover, (===) ) - -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Accessors" $ 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 "Get" $ do - it "prop_get_nonNullKey" $ - prop_get_nonNullKey - @k @v & property - it "prop_get_nonNullKeys" $ - prop_get_nonNullKeys - @k @v & property - - describe "Set" $ do - it "prop_set_get" $ - prop_set_get - @k @v & property - it "prop_set_nonNullKey" $ - prop_set_nonNullKey - @k @v & property - it "prop_set_nonNullKeys" $ - prop_set_nonNullKeys - @k @v & property - it "prop_set_toList" $ - prop_set_toList - @k @v & property - - describe "Adjust" $ do - it "prop_adjust_get_set" $ - prop_adjust_get_set - @k @v & property - --------------------------------------------------------------------------------- --- Get --------------------------------------------------------------------------------- - -prop_get_nonNullKey - :: Test k v => MonoidMap k v -> k -> Property -prop_get_nonNullKey m k = - MonoidMap.nonNullKey k m === (MonoidMap.get k m /= mempty) - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - -prop_get_nonNullKeys - :: Test k v => MonoidMap k v -> k -> Property -prop_get_nonNullKeys m k = - Set.member k (MonoidMap.nonNullKeys m) === (MonoidMap.get k m /= mempty) - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - --------------------------------------------------------------------------------- --- Set --------------------------------------------------------------------------------- - -prop_set_get - :: Test k v => MonoidMap k v -> k -> v -> Property -prop_set_get m k v = - MonoidMap.get k (MonoidMap.set k v m) === v - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - -prop_set_nonNullKey - :: Test k v => MonoidMap k v -> k -> v -> Property -prop_set_nonNullKey m k v = - MonoidMap.nonNullKey k (MonoidMap.set k v m) === - (v /= mempty) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_set_nonNullKeys - :: Test k v => MonoidMap k v -> k -> v -> Property -prop_set_nonNullKeys m k v = - Set.member k (MonoidMap.nonNullKeys (MonoidMap.set k v m)) === - (v /= mempty) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_set_toList - :: Test k v => MonoidMap k v -> k -> v -> Property -prop_set_toList m k v = - filter ((== k) . fst) (MonoidMap.toList (MonoidMap.set k v m)) === - [(k, v) | v /= mempty] - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - --------------------------------------------------------------------------------- --- Adjust --------------------------------------------------------------------------------- - -prop_adjust_get_set - :: Test k v => MonoidMap k v -> Fun v v -> k -> Property -prop_adjust_get_set m (applyFun -> f) k = - MonoidMap.adjust f k m === MonoidMap.set k (f (MonoidMap.get k m)) m - & cover 1 - (MonoidMap.nullKey k m && Null.null (f mempty)) - "MonoidMap.nullKey k m && Null.null (f mempty)" - & cover 1 - (MonoidMap.nullKey k m && not (Null.null (f mempty))) - "MonoidMap.nullKey k m && not (Null.null (f mempty))" - & cover 0.1 - (MonoidMap.nonNullKey k m && Null.null (f (MonoidMap.get k m))) - "MonoidMap.nonNullKey k m && Null.null (f (MonoidMap.get k m))" - & cover 0.1 - (MonoidMap.nonNullKey k m && not (Null.null (f (MonoidMap.get k m)))) - "MonoidMap.nonNullKey k m && not (Null.null (f (MonoidMap.get k m)))" diff --git a/src/test/Data/MonoidMap/ClassSpec.hs b/src/test/Data/MonoidMap/ClassSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/ClassSpec.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.ClassSpec - where - -import Prelude - -import Data.Monoid - ( Product (..), Sum (..) ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Data.Set - ( Set ) -import Data.Typeable - ( Typeable, typeRep ) -import GHC.Exts - ( IsList (..) ) -import Numeric.Natural - ( Natural ) -import Test.Combinators.NonZero - ( NonZero, genNonZero, shrinkNonZero ) -import Test.Hspec - ( Spec, describe ) -import Test.QuickCheck - ( Arbitrary (..), listOf, scale, shrinkMapBy ) -import Test.QuickCheck.Classes - ( eqLaws - , isListLaws - , monoidLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ) -import Test.QuickCheck.Classes.Group - ( groupLaws ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) -import Test.QuickCheck.Classes.Monoid.GCD - ( distributiveGCDMonoidLaws - , gcdMonoidLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , overlappingGCDMonoidLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - ) -import Test.QuickCheck.Classes.Monoid.LCM - ( distributiveLCMMonoidLaws, lcmMonoidLaws ) -import Test.QuickCheck.Classes.Monoid.Monus - ( monusLaws ) -import Test.QuickCheck.Classes.Monoid.Null - ( monoidNullLaws, positiveMonoidLaws ) -import Test.QuickCheck.Classes.Semigroup.Cancellative - ( cancellativeLaws - , commutativeLaws - , leftCancellativeLaws - , leftReductiveLaws - , reductiveLaws - , rightCancellativeLaws - , rightReductiveLaws - ) -import Test.QuickCheck.Instances.Natural - () -import Test.QuickCheck.Instances.Text - () - -import qualified Data.MonoidMap as MonoidMap - -spec :: Spec -spec = do - describe "Class laws" $ do - -- Test against a variety of key types, in ascending order of - -- cardinality: - specLawsFor (Proxy @Bool) - specLawsFor (Proxy @Ordering) - specLawsFor (Proxy @Int) - specLawsFor (Proxy @Integer) - -specLawsFor - :: forall k. () => - ( Arbitrary k - , Ord k - , Read k - , Show k - , Typeable k - ) - => Proxy k - -> Spec -specLawsFor keyType = do - let description = "Class laws for key type " <> show (typeRep keyType) - describe description $ do - testLawsMany @(MonoidMap k String) - [ eqLaws - , isListLaws - , leftCancellativeLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , rightCancellativeLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Product Integer)) - [ commutativeLaws - , eqLaws - , isListLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , reductiveLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Product Natural)) - [ commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - -- Here we restrict the generator and shrinker so that they can never - -- produce zero values, to avoid running into cases of ArithException - -- caused by operations that may produce zero demoninators: - testLawsMany @(MonoidMap k (NonZero (Product Rational))) - [ commutativeLaws - , eqLaws - , groupLaws - , isListLaws - , monoidLaws - , monoidNullLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Sum Integer)) - [ cancellativeLaws - , commutativeLaws - , eqLaws - , groupLaws - , isListLaws - , leftCancellativeLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , reductiveLaws - , rightCancellativeLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Sum Natural)) - [ cancellativeLaws - , commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftCancellativeLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightCancellativeLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Set ())) - [ commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Set k)) - [ commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Set Ordering)) - [ commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (Set Int)) - [ commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - testLawsMany @(MonoidMap k (MonoidMap k (Sum Natural))) - [ cancellativeLaws - , commutativeLaws - , distributiveGCDMonoidLaws - , distributiveLCMMonoidLaws - , eqLaws - , gcdMonoidLaws - , lcmMonoidLaws - , isListLaws - , leftCancellativeLaws - , leftDistributiveGCDMonoidLaws - , leftGCDMonoidLaws - , leftReductiveLaws - , monoidLaws - , monoidNullLaws - , monusLaws - , overlappingGCDMonoidLaws - , positiveMonoidLaws - , reductiveLaws - , rightCancellativeLaws - , rightDistributiveGCDMonoidLaws - , rightGCDMonoidLaws - , rightReductiveLaws - , semigroupLaws - , semigroupMonoidLaws - , showReadLaws - ] - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -instance (Arbitrary a, Eq a, Num a) => Arbitrary (NonZero a) where - arbitrary = genNonZero arbitrary - shrink = shrinkNonZero shrink - -instance (Arbitrary k, Ord k, Arbitrary v, MonoidNull v) => - Arbitrary (MonoidMap k v) - where - arbitrary = - fromList <$> scale (`mod` 16) (listOf ((,) <$> arbitrary <*> arbitrary)) - shrink = - shrinkMapBy MonoidMap.fromMap MonoidMap.toMap shrink diff --git a/src/test/Data/MonoidMap/ComparisonSpec.hs b/src/test/Data/MonoidMap/ComparisonSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/ComparisonSpec.hs +++ /dev/null @@ -1,278 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.ComparisonSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Maybe - ( isJust ) -import Data.Monoid.Cancellative - ( Reductive (..) ) -import Data.Monoid.GCD - ( GCDMonoid ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesGCDMonoid - , testTypesMonoidNull - , testTypesReductive - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun2, cover, expectFailure, (.||.), (===) ) - -import qualified Data.Monoid.GCD as GCDMonoid - ( GCDMonoid (..) ) -import qualified Data.Monoid.Null as Null - ( MonoidNull (..) ) -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Comparison" $ do - - forM_ testTypesGCDMonoid $ - \(TestType p) -> specGCDMonoid - (Proxy @Key) p - - forM_ testTypesReductive $ - \(TestType p) -> specReductive - (Proxy @Key) p - - forM_ testTypesMonoidNull $ - \(TestType p) -> specMonoidNull - (Proxy @Key) p - -specGCDMonoid - :: forall k v. (Test k v, GCDMonoid v) => Proxy k -> Proxy v -> Spec -specGCDMonoid = makeSpec $ do - it "prop_disjoint_gcd" $ - prop_disjoint_gcd - @k @v & property - it "prop_disjoint_intersection" $ - prop_disjoint_intersection - @k @v & property - -specReductive - :: forall k v. (Test k v, Reductive v) => Proxy k -> Proxy v -> Spec -specReductive = makeSpec $ do - it "prop_isSubmapOf_minusMaybe" $ - prop_isSubmapOf_minusMaybe - @k @v & property - it "prop_isSubmapOf_reduce" $ - prop_isSubmapOf_reduce - @k @v & property - -specMonoidNull - :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specMonoidNull = makeSpec $ do - it "prop_disjointBy_get_total" $ - prop_disjointBy_get_total - @k @v & property - it "prop_disjointBy_get_total_failure" $ - prop_disjointBy_get_total_failure - @k @v & property - it "prop_isSubmapOfBy_get_total" $ - prop_isSubmapOfBy_get_total - @k @v & property - it "prop_isSubmapOfBy_get_total_failure" $ - prop_isSubmapOfBy_get_total_failure - @k @v & property - -prop_disjoint_gcd - :: (Test k v, GCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_disjoint_gcd m1 m2 k = - MonoidMap.disjoint m1 m2 ==> - (Null.null (GCDMonoid.gcd (MonoidMap.get k m1) (MonoidMap.get k m2))) - & cover 8 - (MonoidMap.disjoint m1 m2) - "MonoidMap.disjoint m1 m2" - & cover 8 - (not (MonoidMap.disjoint m1 m2)) - "not (MonoidMap.disjoint m1 m2)" - -prop_disjoint_intersection - :: (Test k v, GCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_disjoint_intersection m1 m2 = - MonoidMap.disjoint m1 m2 === (MonoidMap.intersection m1 m2 == mempty) - & cover 8 - (MonoidMap.disjoint m1 m2) - "MonoidMap.disjoint m1 m2" - & cover 8 - (not (MonoidMap.disjoint m1 m2)) - "not (MonoidMap.disjoint m1 m2)" - -prop_disjointBy_get_total - :: Test k v - => Fun (v, v) Bool - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_disjointBy_get_total (applyFun2 -> f0) m1 m2 k = - MonoidMap.disjointBy f m1 m2 - ==> - f (MonoidMap.get k m1) (MonoidMap.get k m2) - & cover 8 - (m1 /= mempty && m2 /= mempty && MonoidMap.disjointBy f m1 m2) - "m1 /= mempty && m2 /= mempty && MonoidMap.disjointBy f m1 m2" - & cover 2 - (keyWithinIntersection) - "keyWithinIntersection" - & cover 2 - (not keyWithinIntersection) - "not keyWithinIntersection" - where - keyWithinIntersection = - k `Set.member` Set.intersection - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - f v1 v2 - | Null.null v1 = True - | Null.null v2 = True - | otherwise = f0 v1 v2 - -prop_disjointBy_get_total_failure - :: Test k v - => Fun (v, v) Bool - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_disjointBy_get_total_failure (applyFun2 -> f) m1 m2 k = - expectFailure $ - MonoidMap.disjointBy f m1 m2 - ==> - f (MonoidMap.get k m1) (MonoidMap.get k m2) - -prop_isSubmapOf_minusMaybe - :: (Test k v, Reductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_isSubmapOf_minusMaybe m1 m2 = - MonoidMap.isSubmapOf m1 m2 - ==> isJust (m2 `MonoidMap.minusMaybe` m1) - & cover 0.01 - (nonTrivialSubmap) - "nonTrivialSubmap" - where - nonTrivialSubmap = - MonoidMap.isSubmapOf m1 m2 - && m1 /= mempty - && m2 /= mempty - && m1 /= m2 - -prop_isSubmapOf_reduce - :: (Test k v, Reductive v) - => MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_isSubmapOf_reduce m1 m2 k = - MonoidMap.isSubmapOf m1 m2 - ==> isJust (MonoidMap.get k m2 MonoidMap.get k m1) - & cover 0.001 - (nonTrivialSubmap && nonNullKeyL && nonNullKeyR) - "nonTrivialSubmap && nonNullKeyL && nonNullKeyR" - & cover 0.001 - (nonTrivialSubmap && nullKeyL && nonNullKeyR) - "nonTrivialSubmap && nullKeyL && nonNullKeyR" - & cover 0.001 - (nonTrivialSubmap && nullKeyL && nullKeyR) - "nonTrivialSubmap && nullKeyL && nullKeyR" - where - nonTrivialSubmap = - MonoidMap.isSubmapOf m1 m2 - && m1 /= mempty - && m2 /= mempty - && m1 /= m2 - nonNullKeyL = MonoidMap.nonNullKey k m1 - nonNullKeyR = MonoidMap.nonNullKey k m2 - nullKeyL = MonoidMap.nullKey k m1 - nullKeyR = MonoidMap.nullKey k m2 - -prop_isSubmapOfBy_get_total - :: Test k v - => Fun (v, v) Bool - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_isSubmapOfBy_get_total (applyFun2 -> f0) m1 m2 k = - MonoidMap.isSubmapOfBy f m1 m2 - ==> - f (MonoidMap.get k m1) (MonoidMap.get k m2) - & cover 0.01 - (nonTrivialSubmap && nonNullKeyL && nonNullKeyR) - "nonTrivialSubmap && nonNullKeyL && nonNullKeyR" - & cover 0.1 - (nonTrivialSubmap && nullKeyL && nonNullKeyR) - "nonTrivialSubmap && nullKeyL && nonNullKeyR" - & cover 0.1 - (nonTrivialSubmap && nonNullKeyL && nullKeyR) - "nonTrivialSubmap && nonNullKeyL && nullKeyR" - & cover 0.1 - (nonTrivialSubmap && nullKeyL && nullKeyR) - "nonTrivialSubmap && nullKeyL && nullKeyR" - where - f v1 v2 - | Null.null v1 = True - | otherwise = f0 v1 v2 - nonTrivialSubmap = - MonoidMap.isSubmapOfBy f m1 m2 - && m1 /= mempty - && m2 /= mempty - && m1 /= m2 - nonNullKeyL = MonoidMap.nonNullKey k m1 - nonNullKeyR = MonoidMap.nonNullKey k m2 - nullKeyL = MonoidMap.nullKey k m1 - nullKeyR = MonoidMap.nullKey k m2 - -prop_isSubmapOfBy_get_total_failure - :: Test k v - => Fun (v, v) Bool - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_isSubmapOfBy_get_total_failure (applyFun2 -> f) m1 m2 k = - expectFailure $ - MonoidMap.isSubmapOfBy f m1 m2 - ==> - f (MonoidMap.get k m1) (MonoidMap.get k m2) - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -infixr 3 ==> -(==>) :: Bool -> Bool -> Property -a ==> b = not a .||. b diff --git a/src/test/Data/MonoidMap/ConversionSpec.hs b/src/test/Data/MonoidMap/ConversionSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/ConversionSpec.hs +++ /dev/null @@ -1,220 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.ConversionSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Map.Strict - ( Map ) -import Data.MonoidMap - ( MonoidMap, nonNullCount ) -import Data.Proxy - ( Proxy (..) ) -import Data.Set - ( Set ) -import Test.Common - ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) - -import qualified Data.Foldable as F -import qualified Data.List as List -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Conversions" $ 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 "Conversion to and from lists" $ do - it "prop_fromList_get" $ - prop_fromList_get - @k @v & property - it "prop_fromList_toMap" $ - prop_fromList_toMap - @k @v & property - it "prop_fromList_toList" $ - prop_fromList_toList - @k @v & property - it "prop_toList_fromList" $ - prop_toList_fromList - @k @v & property - it "prop_toList_sort" $ - prop_toList_sort - @k @v & property - it "prop_fromListWith_get" $ - prop_fromListWith_get - @k @v & property - - describe "Conversion to and from ordinary maps" $ do - it "prop_fromMap_toMap" $ - prop_fromMap_toMap - @k @v & property - it "prop_toMap_fromMap" $ - prop_toMap_fromMap - @k @v & property - - describe "Conversion from sets" $ do - it "prop_fromSet_get" $ - prop_fromSet_get - @k @v & property - --------------------------------------------------------------------------------- --- Conversion to and from lists --------------------------------------------------------------------------------- - -prop_fromList_get - :: Test k v => [(k, v)] -> k -> Property -prop_fromList_get kvs k = - MonoidMap.get k (MonoidMap.fromList kvs) - === - F.foldMap snd (filter ((== k) . fst) kvs) - & cover 2 - (matchingKeyCount == 0) - "matchingKeyCount == 0" - & cover 2 - (matchingKeyCount == 1) - "matchingKeyCount == 1" - & cover 2 - (matchingKeyCount == 2) - "matchingKeyCount == 2" - & cover 2 - (matchingKeyCount >= 3) - "matchingKeyCount >= 3" - where - matchingKeyCount = - length $ filter ((== k) . fst) kvs - -prop_fromList_toMap - :: Test k v => [(k, v)] -> Property -prop_fromList_toMap kvs = - MonoidMap.toMap m === Map.filter (/= mempty) o - & cover 2 - (MonoidMap.nonNull m && nonNullCount m /= Map.size o) - "MonoidMap.nonNull m && nonNullCount m /= Map.size o" - & cover 2 - (MonoidMap.nonNull m && nonNullCount m == Map.size o) - "MonoidMap.nonNull m && nonNullCount m == Map.size o" - where - m = MonoidMap.fromList kvs - o = Map.fromListWith (flip (<>)) kvs - -prop_fromList_toList - :: Test k v => [(k, v)] -> Property -prop_fromList_toList kvs = - MonoidMap.toList m === Map.toList (Map.filter (/= mempty) o) - & cover 2 - (MonoidMap.nonNull m && nonNullCount m /= Map.size o) - "MonoidMap.nonNull m && nonNullCount m /= Map.size o" - & cover 2 - (MonoidMap.nonNull m && nonNullCount m == Map.size o) - "MonoidMap.nonNull m && nonNullCount m == Map.size o" - where - m = MonoidMap.fromList kvs - o = Map.fromListWith (flip (<>)) kvs - -prop_toList_fromList - :: Test k v => MonoidMap k v -> Property -prop_toList_fromList m = - MonoidMap.fromList (MonoidMap.toList m) === m - & cover 2 - (MonoidMap.nonNull m) - "MonoidMap.nonNull m" - -prop_toList_sort - :: Test k v => MonoidMap k v -> Property -prop_toList_sort m = - List.sortOn fst (MonoidMap.toList m) === MonoidMap.toList m - & cover 2 - (MonoidMap.nonNull m) - "MonoidMap.nonNull m" - -prop_fromListWith_get - :: Test k v => Fun (v, v) v -> [(k, v)] -> k -> Property -prop_fromListWith_get (applyFun2 -> f) kvs k = - MonoidMap.get k (MonoidMap.fromListWith f kvs) - === - maybe mempty - (F.foldl1 f) - (NE.nonEmpty (snd <$> filter ((== k) . fst) kvs)) - & cover 2 - (matchingKeyCount == 0) - "matchingKeyCount == 0" - & cover 2 - (matchingKeyCount == 1) - "matchingKeyCount == 1" - & cover 2 - (matchingKeyCount == 2) - "matchingKeyCount == 2" - & cover 2 - (matchingKeyCount >= 3) - "matchingKeyCount >= 3" - where - matchingKeyCount = - length $ filter ((== k) . fst) kvs - --------------------------------------------------------------------------------- --- Conversion to and from ordinary maps --------------------------------------------------------------------------------- - -prop_fromMap_toMap - :: Test k v => Map k v -> Property -prop_fromMap_toMap o = - MonoidMap.toMap m === Map.filter (/= mempty) o - & cover 2 - (MonoidMap.nonNull m && nonNullCount m /= Map.size o) - "MonoidMap.nonNull m && nonNullCount m /= Map.size o" - & cover 2 - (MonoidMap.nonNull m && nonNullCount m == Map.size o) - "MonoidMap.nonNull m && nonNullCount m == Map.size o" - where - m = MonoidMap.fromMap o - -prop_toMap_fromMap - :: Test k v => MonoidMap k v -> Property -prop_toMap_fromMap m = - MonoidMap.fromMap (MonoidMap.toMap m) === m - --------------------------------------------------------------------------------- --- Conversion from sets --------------------------------------------------------------------------------- - -prop_fromSet_get - :: Test k v => Fun k v -> Set k -> k -> Property -prop_fromSet_get (applyFun -> f) ks k = - MonoidMap.get k (MonoidMap.fromSet f ks) - === - (if Set.member k ks then f k else mempty) - & cover 0.2 - (Set.member k ks && Null.null (f k)) - "Set.member k ks && Null.null (f k)" - & cover 8.0 - (Set.member k ks && not (Null.null (f k))) - "Set.member k ks && not (Null.null (f k))" - & cover 0.2 - (not (Set.member k ks) && Null.null (f k)) - "not (Set.member k ks) && Null.null (f k)" - & cover 8.0 - (not (Set.member k ks) && not (Null.null (f k))) - "not (Set.member k ks) && not (Null.null (f k))" diff --git a/src/test/Data/MonoidMap/DistributivitySpec.hs b/src/test/Data/MonoidMap/DistributivitySpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/DistributivitySpec.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.DistributivitySpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Data - ( typeRep ) -import Data.Function - ( (&) ) -import Data.Maybe - ( isJust ) -import Data.MonoidMap - ( MonoidMap, get ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key - , Test - , TestType (..) - , TestValue - , property - , testTypesGCDMonoid - , testTypesGroup - , testTypesLCMMonoid - , testTypesLeftGCDMonoid - , testTypesLeftReductive - , testTypesMonoidNull - , testTypesMonus - , testTypesOverlappingGCDMonoid - , testTypesReductive - , testTypesRightGCDMonoid - , testTypesRightReductive - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Property, cover, (===) ) - -import qualified Data.Group as Group - ( Group (..) ) -import qualified Data.Monoid.GCD as LeftGCDMonoid - ( LeftGCDMonoid (..) ) -import qualified Data.Monoid.GCD as RightGCDMonoid - ( RightGCDMonoid (..) ) -import qualified Data.Monoid.GCD as OverlappingGCDMonoid - ( OverlappingGCDMonoid (..) ) -import qualified Data.Monoid.GCD as GCDMonoid - ( GCDMonoid (..) ) -import qualified Data.Monoid.LCM as LCMMonoid - ( LCMMonoid (..) ) -import qualified Data.Monoid.Monus as Monus - ( Monus (..) ) -import qualified Data.Semigroup as Semigroup - ( Semigroup (..) ) -import qualified Data.Semigroup.Cancellative as LeftReductive - ( LeftReductive (..) ) -import qualified Data.Semigroup.Cancellative as RightReductive - ( RightReductive (..) ) -import qualified Data.Semigroup.Cancellative as Reductive - ( Reductive (..) ) - -spec :: Spec -spec = do - specDistributiveGet - specDistributiveGetMaybe - -specDistributiveGet :: Spec -specDistributiveGet = do - specForAll - testTypesMonoidNull - "Semigroup.<>" - (Semigroup.<>) - (Semigroup.<>) - specForAll - testTypesLeftGCDMonoid - "LeftGCDMonoid.commonPrefix" - (LeftGCDMonoid.commonPrefix) - (LeftGCDMonoid.commonPrefix) - specForAll - testTypesRightGCDMonoid - "RightGCDMonoid.commonSuffix" - (RightGCDMonoid.commonSuffix) - (RightGCDMonoid.commonSuffix) - specForAll - testTypesOverlappingGCDMonoid - "OverlappingGCDMonoid.overlap" - (OverlappingGCDMonoid.overlap) - (OverlappingGCDMonoid.overlap) - specForAll - testTypesGCDMonoid - "GCDMonoid.gcd" - (GCDMonoid.gcd) - (GCDMonoid.gcd) - specForAll - testTypesLCMMonoid - "LCMMonoid.lcm" - (LCMMonoid.lcm) - (LCMMonoid.lcm) - specForAll - testTypesGroup - "Group.minus" - (Group.~~) - (Group.~~) - specForAll - testTypesMonus - "Monus.monus" - (Monus.<\>) - (Monus.<\>) - where - specForAll - :: [TestType c] - -> String - -> (forall k v m. (Test k v, c v, m ~ MonoidMap k v) => (m -> m -> m)) - -> (forall v. (TestValue v, c v) => (v -> v -> v)) - -> Spec - specForAll testTypes funName f g = - describe description $ forM_ testTypes $ specFor f g - where - description = "Distributivity of 'get' with '" <> funName <> "'" - - specFor - :: (forall k v m. (Test k v, c v, m ~ MonoidMap k v) => (m -> m -> m)) - -> (forall v. (TestValue v, c v) => (v -> v -> v)) - -> TestType c - -> Spec - specFor f g (TestType (_ :: Proxy v)) = - it description $ property $ propDistributiveGet @Key @v f g - where - description = show $ typeRep $ Proxy @(MonoidMap Key v) - -specDistributiveGetMaybe :: Spec -specDistributiveGetMaybe = do - specForAll - testTypesLeftReductive - "LeftReductive.stripPrefix" - (LeftReductive.stripPrefix) - (LeftReductive.stripPrefix) - specForAll - testTypesRightReductive - "RightReductive.stripSuffix" - (RightReductive.stripSuffix) - (RightReductive.stripSuffix) - specForAll - testTypesReductive - "Reductive.minusMaybe" - (Reductive.) - (Reductive.) - where - specForAll - :: [TestType c] - -> String - -> (forall k v m. (Test k v, c v, m ~ MonoidMap k v) - => (m -> m -> Maybe m)) - -> (forall v. (TestValue v, c v) - => (v -> v -> Maybe v)) - -> Spec - specForAll testTypes funName f g = - describe description $ forM_ testTypes $ specFor f g - where - description = "Distributivity of 'get' with '" <> funName <> "'" - - specFor - :: (forall k v m. (Test k v, c v, m ~ MonoidMap k v) - => (m -> m -> Maybe m)) - -> (forall v. (TestValue v, c v) - => (v -> v -> Maybe v)) - -> TestType c - -> Spec - specFor f g (TestType (_ :: Proxy v)) = - it description $ property $ propDistributiveGetMaybe @Key @v f g - where - description = show $ typeRep $ Proxy @(MonoidMap Key v) - -propDistributiveGet - :: Test k v - => (MonoidMap k v -> MonoidMap k v -> MonoidMap k v) - -> (v -> v -> v) - -> k - -> MonoidMap k v - -> MonoidMap k v - -> Property -propDistributiveGet f g k m1 m2 = - get k (f m1 m2) === g (get k m1) (get k m2) - & cover 2 - (get k (f m1 m2) == mempty) - "get k (f m1 m2) == mempty" - & cover 2 - (get k (f m1 m2) /= mempty) - "get k (f m1 m2) /= mempty" - & cover 2 - (get k m1 == mempty && get k m2 == mempty) - "get k m1 == mempty && get k m2 == mempty" - & cover 2 - (get k m1 == mempty && get k m2 /= mempty) - "get k m1 == mempty && get k m2 /= mempty" - & cover 2 - (get k m1 /= mempty && get k m2 == mempty) - "get k m1 /= mempty && get k m2 == mempty" - & cover 2 - (get k m1 /= mempty && get k m2 /= mempty) - "get k m1 /= mempty && get k m2 /= mempty" - -propDistributiveGetMaybe - :: Test k v - => (MonoidMap k v -> MonoidMap k v -> Maybe (MonoidMap k v)) - -> (v -> v -> Maybe v) - -> k - -> MonoidMap k v - -> MonoidMap k v - -> Property -propDistributiveGetMaybe f g k m1 m2 = property $ - all (\m -> g (get k m1) (get k m2) == Just (get k m)) (f m1 m2) - & cover 2 - (isJust (f m1 m2) && g (get k m1) (get k m2) == Just mempty) - "isJust (f m1 m2) && g (get k m1) (get k m2) == Just mempty" - & cover 2 - (isJust (f m1 m2) && g (get k m1) (get k m2) /= Just mempty) - "isJust (f m1 m2) && g (get k m1) (get k m2) /= Just mempty" diff --git a/src/test/Data/MonoidMap/ExampleSpec.hs b/src/test/Data/MonoidMap/ExampleSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/ExampleSpec.hs +++ /dev/null @@ -1,1740 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.ExampleSpec - where - -import Prelude hiding - ( gcd, lcm ) - -import Data.Function - ( (&) ) -import Data.Group - ( Group (..) ) -import Data.Monoid - ( Product (..), Sum (..) ) -import Data.Monoid.GCD - ( GCDMonoid (..), LeftGCDMonoid (..), RightGCDMonoid (..) ) -import Data.Monoid.LCM - ( LCMMonoid (..) ) -import Data.Monoid.Monus - ( OverlappingGCDMonoid (..), (<\>) ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Ratio - ( (%) ) -import Data.Semigroup.Cancellative - ( LeftReductive (..), RightReductive (..) ) -import Data.Set - ( Set ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe ) -import Test.Hspec.Unit - ( UnitTestData1 - , UnitTestData2 - , unitTestData1 - , unitTestData2 - , unitTestSpec - ) -import Test.QuickCheck.Instances.Natural - () -import Test.QuickCheck.Instances.Text - () - -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Examples" $ do - - describe "Conversion" $ do - - exampleSpec_fromList_String - exampleSpec_toList_String - - describe "Comparison" $ do - - exampleSpec_isSubmapOf_Sum_Natural - exampleSpec_disjoint_Product_Natural - exampleSpec_disjoint_Sum_Natural - exampleSpec_disjoint_Set_Natural - - describe "Intersection" $ do - - exampleSpec_intersectionWith_min_Sum_Natural - - describe "Union" $ do - - exampleSpec_unionWith_max_Sum_Natural - - describe "Semigroup" $ do - - exampleSpec_Semigroup_mappend_String - exampleSpec_Semigroup_mappend_Sum_Natural - - describe "Group" $ do - - exampleSpec_Group_invert_Product_Rational - exampleSpec_Group_invert_Sum_Integer - exampleSpec_Group_pow_Product_Rational - exampleSpec_Group_pow_Sum_Integer - exampleSpec_Group_subtract_Product_Rational - exampleSpec_Group_subtract_Sum_Integer - - describe "Reductive" $ do - - exampleSpec_Reductive_isPrefixOf_String - exampleSpec_Reductive_isPrefixOf_Sum_Natural - exampleSpec_Reductive_isSuffixOf_String - exampleSpec_Reductive_isSuffixOf_Sum_Natural - exampleSpec_Reductive_stripPrefix_String - exampleSpec_Reductive_stripPrefix_Sum_Natural - exampleSpec_Reductive_stripSuffix_String - exampleSpec_Reductive_stripSuffix_Sum_Natural - - describe "LeftGCDMonoid" $ do - - exampleSpec_LeftGCDMonoid_commonPrefix_String - exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural - exampleSpec_LeftGCDMonoid_stripCommonPrefix_String - exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural - - describe "RightGCDMonoid" $ do - - exampleSpec_RightGCDMonoid_commonSuffix_String - exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural - exampleSpec_RightGCDMonoid_stripCommonSuffix_String - exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural - - describe "OverlappingGCDMonoid" $ do - - exampleSpec_OverlappingGCDMonoid_overlap_String - exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural - exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String - exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural - exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String - exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural - - describe "GCDMonoid" $ do - - exampleSpec_GCDMonoid_gcd_Product_Natural - exampleSpec_GCDMonoid_gcd_Sum_Natural - exampleSpec_GCDMonoid_gcd_Set_Natural - - describe "LCMMonoid" $ do - - exampleSpec_LCMMonoid_lcm_Product_Natural - exampleSpec_LCMMonoid_lcm_Sum_Natural - exampleSpec_LCMMonoid_lcm_Set_Natural - - describe "Monus" $ do - - exampleSpec_Monus_monus_Set_Natural - exampleSpec_Monus_monus_Sum_Natural - --------------------------------------------------------------------------------- --- Conversion --------------------------------------------------------------------------------- - -exampleSpec_fromList_String :: Spec -exampleSpec_fromList_String = unitTestSpec - "MonoidMap.fromList (String)" - "MonoidMap.fromList" - (MonoidMap.fromList) - (exampleData_fromList_String) - -exampleData_fromList_String :: UnitTestData1 - [(Int, String)] - (MonoidMap Int String) -exampleData_fromList_String = unitTestData1 - [ ( [(1, "a"), (2, "x"), (1, "b"), (2, "y"), (1, "c"), (2, "z")] - , [(1, "abc"), (2, "xyz")] - ) - ] - -exampleSpec_toList_String :: Spec -exampleSpec_toList_String = unitTestSpec - "MonoidMap.toList (String)" - "MonoidMap.toList" - (MonoidMap.toList) - (exampleData_toList_String) - -exampleData_toList_String :: UnitTestData1 - (MonoidMap Int String) - [(Int, String)] -exampleData_toList_String = unitTestData1 - [ ( [(3, "z"), (2, "y"), (1, "x")] - , [(1, "x"), (2, "y"), (3, "z")] - ) - ] - --------------------------------------------------------------------------------- --- Comparison --------------------------------------------------------------------------------- - -exampleSpec_isSubmapOf_Sum_Natural :: Spec -exampleSpec_isSubmapOf_Sum_Natural = unitTestSpec - "MonoidMap.isSubmapOf (Sum Natural)" - "MonoidMap.isSubmapOf" - (MonoidMap.isSubmapOf) - (exampleData_isSubmapOf_Sum_Natural) - -exampleData_isSubmapOf_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (Bool) -exampleData_isSubmapOf_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3] - , m [4, 4, 4, 4] - , True - ) - , ( m [0, 1, 2, 3] - , m [0, 4, 4, 4] - , True - ) - , ( m [0, 1, 2, 3] - , m [0, 1, 4, 4] - , True - ) - , ( m [0, 1, 2, 3] - , m [0, 1, 2, 4] - , True - ) - , ( m [0, 1, 2, 3] - , m [0, 1, 2, 3] - , True - ) - , ( m [0, 1, 2, 3] - , m [0, 0, 2, 3] - , False - ) - , ( m [0, 1, 2, 3] - , m [0, 1, 1, 3] - , False - ) - , ( m [0, 1, 2, 3] - , m [0, 1, 2, 2] - , False - ) - , ( m [0, 1, 2, 3] - , m [0, 0, 0, 0] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_disjoint_Product_Natural :: Spec -exampleSpec_disjoint_Product_Natural = unitTestSpec - "MonoidMap.disjoint (Product Natural)" - "MonoidMap.disjoint" - (MonoidMap.disjoint) - (exampleData_disjoint_Product_Natural) - -exampleData_disjoint_Product_Natural :: UnitTestData2 - (MonoidMap LatinChar (Product Natural)) - (MonoidMap LatinChar (Product Natural)) - (Bool) -exampleData_disjoint_Product_Natural = unitTestData2 - [ ( m [] - , m [] - , True - ) - , ( m [2, 3, 5, 7] - , m [3, 5, 7, 2] - , True - ) - , ( m [2 * 3, 5 * 7] - , m [5 * 7, 2 * 3] - , True - ) - , ( m [2 * 3 , 3 * 5 ] - , m [ 3 * 5, 5 * 7] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_disjoint_Sum_Natural :: Spec -exampleSpec_disjoint_Sum_Natural = unitTestSpec - "MonoidMap.disjoint (Sum Natural)" - "MonoidMap.disjoint" - (MonoidMap.disjoint) - (exampleData_disjoint_Sum_Natural) - -exampleData_disjoint_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (Bool) -exampleData_disjoint_Sum_Natural = unitTestData2 - [ ( m [] - , m [] - , True - ) - , ( m [0, 1, 0, 1] - , m [1, 0, 1, 0] - , True - ) - , ( m [0, 8, 0, 8] - , m [8, 0, 8, 0] - , True - ) - , ( m [0, 8, 0, 8] - , m [8, 0, 8, 1] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_disjoint_Set_Natural :: Spec -exampleSpec_disjoint_Set_Natural = unitTestSpec - "MonoidMap.disjoint (Set Natural)" - "MonoidMap.disjoint" - (MonoidMap.disjoint) - (exampleData_disjoint_Set_Natural) - -exampleData_disjoint_Set_Natural :: UnitTestData2 - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) - (Bool) -exampleData_disjoint_Set_Natural = unitTestData2 - [ ( m [] - , m [] - , True - ) - , ( m [[1], [2], [3], [4]] - , m [[5], [6], [7], [8]] - , True - ) - , ( m [[1, 2], [3, 4]] - , m [[5, 6], [7, 8]] - , True - ) - , ( m [[1, 2 ], [3, 4 ]] - , m [[ 2, 3], [ 4, 5]] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList - --------------------------------------------------------------------------------- --- Intersection --------------------------------------------------------------------------------- - -exampleSpec_intersectionWith_min_Sum_Natural :: Spec -exampleSpec_intersectionWith_min_Sum_Natural = unitTestSpec - "MonoidMap.intersectionWith (Sum Natural)" - "MonoidMap.intersectionWith" - (MonoidMap.intersectionWith min) - (exampleData_intersectionWith_min_Sum_Natural) - -exampleData_intersectionWith_min_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_intersectionWith_min_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7] - , m [7, 6, 5, 4, 3, 2, 1, 0] - , m [0, 1, 2, 3, 3, 2, 1, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- Union --------------------------------------------------------------------------------- - -exampleSpec_unionWith_max_Sum_Natural :: Spec -exampleSpec_unionWith_max_Sum_Natural = unitTestSpec - "MonoidMap.unionWith (Sum Natural)" - "MonoidMap.unionWith" - (MonoidMap.unionWith max) - (exampleData_unionWith_max_Sum_Natural) - -exampleData_unionWith_max_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_unionWith_max_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7] - , m [7, 6, 5, 4, 3, 2, 1, 0] - , m [7, 6, 5, 4, 4, 5, 6, 7] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- Semigroup --------------------------------------------------------------------------------- - -exampleSpec_Semigroup_mappend_String :: Spec -exampleSpec_Semigroup_mappend_String = unitTestSpec - "Semigroup.mappend (String)" - "mappend" - (mappend) - (exampleData_Semigroup_concat_String) - -exampleData_Semigroup_concat_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_Semigroup_concat_String = unitTestData2 - [ ( m ["abc", "ij" , "p" , "" ] - , m [ "", "k", "qr", "xyz"] - , m ["abc", "ijk", "pqr", "xyz"] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Semigroup_mappend_Sum_Natural :: Spec -exampleSpec_Semigroup_mappend_Sum_Natural = unitTestSpec - "Semigroup.mappend (Sum Natural)" - "mappend" - (mappend) - (exampleData_Semigroup_concat_Sum_Natural) - -exampleData_Semigroup_concat_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_Semigroup_concat_Sum_Natural = unitTestData2 - [ ( m [4, 2, 1, 0] - , m [0, 1, 2, 4] - , m [4, 3, 3, 4] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- Group --------------------------------------------------------------------------------- - -exampleSpec_Group_invert_Product_Rational :: Spec -exampleSpec_Group_invert_Product_Rational = unitTestSpec - "Group.invert (Product Rational)" - "invert" - (invert) - (exampleData_Group_invert_Product_Rational) - -exampleData_Group_invert_Product_Rational :: UnitTestData1 - (MonoidMap LatinChar (Product Rational)) - (MonoidMap LatinChar (Product Rational)) -exampleData_Group_invert_Product_Rational = unitTestData1 - [ ( m [ 2, 4, 8, 16] - , m [1%2, 1%4, 1%8, 1%16] - ) - , ( m [1%2, 1%4, 1%8, 1%16] - , m [ 2, 4, 8, 16] - ) - , ( m [ 2, 1%4, 8, 16] - , m [1%2, 4, 1%8, 1%16] - ) - , ( m [1%2, 4, 1%8, 1%16] - , m [ 2, 1%4, 8, 16] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Product - -exampleSpec_Group_invert_Sum_Integer :: Spec -exampleSpec_Group_invert_Sum_Integer = unitTestSpec - "Group.invert (Sum Integer)" - "invert" - (invert) - (exampleData_Group_invert_Sum_Integer) - -exampleData_Group_invert_Sum_Integer :: UnitTestData1 - (MonoidMap LatinChar (Sum Integer)) - (MonoidMap LatinChar (Sum Integer)) -exampleData_Group_invert_Sum_Integer = unitTestData1 - [ ( m [ 1, 2, 3, 4] - , m [-1, -2, -3, -4] - ) - , ( m [-1, -2, -3, -4] - , m [ 1, 2, 3, 4] - ) - , ( m [ 1, -2, 3, -4] - , m [-1, 2, -3, 4] - ) - , ( m [-1, 2, -3, 4] - , m [ 1, -2, 3, -4] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Sum - -exampleSpec_Group_pow_Product_Rational :: Spec -exampleSpec_Group_pow_Product_Rational = unitTestSpec - "Group.pow (Product Rational)" - "pow" - (pow) - (exampleData_Group_pow_Product_Rational) - -exampleData_Group_pow_Product_Rational :: UnitTestData2 - (MonoidMap LatinChar (Product Rational)) - (Integer) - (MonoidMap LatinChar (Product Rational)) -exampleData_Group_pow_Product_Rational = unitTestData2 - [ ( m [ 2, -4, 8, -16], (-1) - , m [1%2, -1%4, 1%8, -1%16] - ) - , ( m [ 2, -4, 8, -16], 0 - , m [ 1, 1, 1, 1] - ) - , ( m [ 2, -4, 8, -16], 1 - , m [ 2, -4, 8, -16] - ) - , ( m [ 2, -4, 8, -16], 2 - , m [ 4, 16, 64, 256] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Product - -exampleSpec_Group_pow_Sum_Integer :: Spec -exampleSpec_Group_pow_Sum_Integer = unitTestSpec - "Group.pow (Sum Integer)" - "pow" - (pow) - (exampleData_Group_pow_Sum_Integer) - -exampleData_Group_pow_Sum_Integer :: UnitTestData2 - (MonoidMap LatinChar (Sum Integer)) - (Integer) - (MonoidMap LatinChar (Sum Integer)) -exampleData_Group_pow_Sum_Integer = unitTestData2 - [ ( m [ 1, -2, 3, -4], (-1) - , m [-1, 2, -3, 4] - ) - , ( m [ 1, -2, 3, -4], 0 - , m [ 0, 0, 0, 0] - ) - , ( m [ 1, -2, 3, -4], 1 - , m [ 1, -2, 3, -4] - ) - , ( m [ 1, -2, 3, -4], 2 - , m [ 2, -4, 6, -8] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Sum - -exampleSpec_Group_subtract_Product_Rational :: Spec -exampleSpec_Group_subtract_Product_Rational = unitTestSpec - "Group.(~~) (Product Rational)" - "(~~)" - (~~) - (exampleData_Group_subtract_Product_Rational) - -exampleData_Group_subtract_Product_Rational :: UnitTestData2 - (MonoidMap LatinChar (Product Rational)) - (MonoidMap LatinChar (Product Rational)) - (MonoidMap LatinChar (Product Rational)) -exampleData_Group_subtract_Product_Rational = unitTestData2 - [ ( m [ 1, 1, 1, 1] - , m [ 1, 2, 4, 8] - , m [ 1, 1%2, 1%4, 1%8] - ) - , ( m [-1, -1, -1, -1] - , m [ 1, 2, 4, 8] - , m [-1, -1%2, -1%4, -1%8] - ) - , ( m [ 1, 1, 1, 1] - , m [-1, -2, -4, -8] - , m [-1, -1%2, -1%4, -1%8] - ) - , ( m [-1, -1, -1, -1] - , m [-1, -2, -4, -8] - , m [ 1, 1%2, 1%4, 1%8] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Product - -exampleSpec_Group_subtract_Sum_Integer :: Spec -exampleSpec_Group_subtract_Sum_Integer = unitTestSpec - "Group.(~~) (Sum Integer)" - "(~~)" - (~~) - (exampleData_Group_subtract_Sum_Integer) - -exampleData_Group_subtract_Sum_Integer :: UnitTestData2 - (MonoidMap LatinChar (Sum Integer)) - (MonoidMap LatinChar (Sum Integer)) - (MonoidMap LatinChar (Sum Integer)) -exampleData_Group_subtract_Sum_Integer = unitTestData2 - [ ( m [ 1, 2, 3, 4] - , m [ 1, 2, 3, 4] - , m [ 0, 0, 0, 0] - ) - , ( m [ 0, 0, 0, 0] - , m [ 1, 2, 3, 4] - , m [-1, -2, -3, -4] - ) - , ( m [ 1, 2, 3, 4] - , m [-1, -2, -3, -4] - , m [ 2, 4, 6, 8] - ) - , ( m [-1, -2, -3, -4] - , m [-1, -2, -3, -4] - , m [ 0, 0, 0, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Sum - --------------------------------------------------------------------------------- --- Reductive --------------------------------------------------------------------------------- - -exampleSpec_Reductive_isPrefixOf_String :: Spec -exampleSpec_Reductive_isPrefixOf_String = unitTestSpec - "Reductive.isPrefixOf (String)" - "isPrefixOf" - (isPrefixOf) - (exampleData_Reductive_isPrefixOf_String) - -exampleData_Reductive_isPrefixOf_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (Bool) -exampleData_Reductive_isPrefixOf_String = unitTestData2 - [ ( m ["A" , "B" , "C" ] - , m ["A123", "B123", "C123"] - , True - ) - , ( m ["A123", "B123", "C123"] - , m ["A" , "B" , "C" ] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Reductive_isSuffixOf_String :: Spec -exampleSpec_Reductive_isSuffixOf_String = unitTestSpec - "Reductive.isSuffixOf (String)" - "isSuffixOf" - (isSuffixOf) - (exampleData_Reductive_isSuffixOf_String) - -exampleData_Reductive_isSuffixOf_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (Bool) -exampleData_Reductive_isSuffixOf_String = unitTestData2 - [ ( m [ "A", "B", "C"] - , m ["123A", "123B", "123C"] - , True - ) - , ( m ["123A", "123B", "123C"] - , m [ "A", "B", "C"] - , False - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Reductive_isPrefixOf_Sum_Natural :: Spec -exampleSpec_Reductive_isPrefixOf_Sum_Natural = unitTestSpec - "Reductive.isPrefixOf (Sum Natural)" - "isPrefixOf" - (isPrefixOf) - (exampleData_Reductive_Sum_Natural) - -exampleSpec_Reductive_isSuffixOf_Sum_Natural :: Spec -exampleSpec_Reductive_isSuffixOf_Sum_Natural = unitTestSpec - "Reductive.isSuffixOf (Sum Natural)" - "isSuffixOf" - (isSuffixOf) - (exampleData_Reductive_Sum_Natural) - -exampleData_Reductive_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (Bool) -exampleData_Reductive_Sum_Natural = unitTestData2 - [ ( m [1, 1], m [1, 1], True ) - , ( m [1, 1], m [1, 2], True ) - , ( m [1, 1], m [2, 1], True ) - , ( m [1, 1], m [2, 2], True ) - , ( m [1, 2], m [1, 1], False) - , ( m [1, 2], m [1, 2], True ) - , ( m [1, 2], m [2, 1], False) - , ( m [1, 2], m [2, 2], True ) - , ( m [2, 1], m [1, 1], False) - , ( m [2, 1], m [1, 2], False) - , ( m [2, 1], m [2, 1], True ) - , ( m [2, 1], m [2, 2], True ) - , ( m [2, 2], m [1, 1], False) - , ( m [2, 2], m [1, 2], False) - , ( m [2, 2], m [2, 1], False) - , ( m [2, 2], m [2, 2], True ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Sum - -exampleSpec_Reductive_stripPrefix_String :: Spec -exampleSpec_Reductive_stripPrefix_String = unitTestSpec - "Reductive.stripPrefix (String)" - "stripPrefix" - (stripPrefix) - (exampleData_Reductive_stripPrefix_String) - -exampleData_Reductive_stripPrefix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (Maybe (MonoidMap LatinChar String)) -exampleData_Reductive_stripPrefix_String = unitTestData2 - [ ( m ["" , "" , "" ] - , m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] & Just - ) - , ( m ["a" , "p" , "x" ] - , m ["abc", "pqr", "xyz"] - , m [ "bc", "qr", "yz"] & Just - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - , m [ "", "", ""] & Just - ) - , ( m ["?" , "p" , "x" ] - , m ["abc", "pqr", "xyz"] - , Nothing - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Reductive_stripPrefix_Sum_Natural :: Spec -exampleSpec_Reductive_stripPrefix_Sum_Natural = unitTestSpec - "Reductive.stripPrefix (Sum Natural)" - "stripPrefix" - (stripPrefix) - (exampleData_Reductive_stripPrefix_Sum_Natural) - -exampleData_Reductive_stripPrefix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (Maybe (MonoidMap LatinChar (Sum Natural))) -exampleData_Reductive_stripPrefix_Sum_Natural = unitTestData2 - [ ( m [0, 0, 0] - , m [2, 4, 8] - , m [2, 4, 8] & Just - ) - , ( m [1, 2, 4] - , m [2, 4, 8] - , m [1, 2, 4] & Just - ) - , ( m [2, 4, 8] - , m [2, 4, 8] - , m [0, 0, 0] & Just - ) - , ( m [3, 4, 8] - , m [2, 4, 8] - , Nothing - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Reductive_stripSuffix_String :: Spec -exampleSpec_Reductive_stripSuffix_String = unitTestSpec - "Reductive.stripSuffix (String)" - "stripSuffix" - (stripSuffix) - (exampleData_Reductive_stripSuffix_String) - -exampleData_Reductive_stripSuffix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (Maybe (MonoidMap LatinChar String)) -exampleData_Reductive_stripSuffix_String = unitTestData2 - [ ( m [ "", "", ""] - , m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] & Just - ) - , ( m [ "c", "r", "z"] - , m ["abc", "pqr", "xyz"] - , m ["ab" , "pq" , "xy" ] & Just - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - , m ["" , "" , "" ] & Just - ) - , ( m [ "?", "r", "z"] - , m ["abc", "pqr", "xyz"] - , Nothing - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_Reductive_stripSuffix_Sum_Natural :: Spec -exampleSpec_Reductive_stripSuffix_Sum_Natural = unitTestSpec - "Reductive.stripSuffix (Sum Natural)" - "stripSuffix" - (stripSuffix) - (exampleData_Reductive_stripSuffix_Sum_Natural) - -exampleData_Reductive_stripSuffix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (Maybe (MonoidMap LatinChar (Sum Natural))) -exampleData_Reductive_stripSuffix_Sum_Natural = unitTestData2 - [ ( m [0, 0, 0] - , m [2, 4, 8] - , m [2, 4, 8] & Just - ) - , ( m [1, 2, 4] - , m [2, 4, 8] - , m [1, 2, 4] & Just - ) - , ( m [2, 4, 8] - , m [2, 4, 8] - , m [0, 0, 0] & Just - ) - , ( m [3, 4, 8] - , m [2, 4, 8] - , Nothing - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- LeftGCDMonoid --------------------------------------------------------------------------------- - -exampleSpec_LeftGCDMonoid_commonPrefix_String :: Spec -exampleSpec_LeftGCDMonoid_commonPrefix_String = unitTestSpec - "LeftGCDMonoid.commonPrefix (String)" - "commonPrefix" - (commonPrefix) - (exampleData_LeftGCDMonoid_commonPrefix_String) - -exampleData_LeftGCDMonoid_commonPrefix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_LeftGCDMonoid_commonPrefix_String = unitTestData2 - [ ( m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - , m ["" , "" , "" ] - ) - , ( m ["a--", "p--", "x--"] - , m ["abc", "pqr", "xyz"] - , m ["a" , "p" , "x" ] - ) - , ( m ["ab-", "pq-", "xy-"] - , m ["abc", "pqr", "xyz"] - , m ["ab" , "pq" , "xy" ] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["ab-", "pq-", "xy-"] - , m ["ab" , "pq" , "xy" ] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["a--", "p--", "x--"] - , m ["a" , "p" , "x" ] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - , m ["" , "" , "" ] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural :: Spec -exampleSpec_LeftGCDMonoid_commonPrefix_Sum_Natural = unitTestSpec - "LeftGCDMonoid.commonPrefix (Sum Natural)" - "commonPrefix" - (commonPrefix) - (exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural) - -exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_LeftGCDMonoid_commonPrefix_Sum_Natural = unitTestData2 - [ ( m [0, 0, 0] - , m [1, 2, 3] - , m [0, 0, 0] - ) - , ( m [1, 1, 1] - , m [1, 2, 3] - , m [1, 1, 1] - ) - , ( m [2, 2, 2] - , m [1, 2, 3] - , m [1, 2, 2] - ) - , ( m [3, 3, 3] - , m [1, 2, 3] - , m [1, 2, 3] - ) - , ( m [4, 4, 4] - , m [1, 2, 3] - , m [1, 2, 3] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_LeftGCDMonoid_stripCommonPrefix_String :: Spec -exampleSpec_LeftGCDMonoid_stripCommonPrefix_String = unitTestSpec - "LeftGCDMonoid.stripCommonPrefix (String)" - "stripCommonPrefix" - (stripCommonPrefix) - (exampleData_LeftGCDMonoid_stripCommonPrefix_String) - -exampleData_LeftGCDMonoid_stripCommonPrefix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - ( MonoidMap LatinChar String - , MonoidMap LatinChar String - , MonoidMap LatinChar String - ) -exampleData_LeftGCDMonoid_stripCommonPrefix_String = unitTestData2 - [ ( m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - - , ( m ["" , "" , "" ] - , m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - ) - ) - , ( m ["a--", "p--", "x--"] - , m ["abc", "pqr", "xyz"] - - , ( m ["a" , "p" , "x" ] - , m [ "--", "--", "--"] - , m [ "bc", "qr", "yz"] - ) - ) - , ( m ["ab-", "pq-", "xy-"] - , m ["abc", "pqr", "xyz"] - - , ( m ["ab" , "pq" , "xy" ] - , m [ "-", "-", "-"] - , m [ "c", "r", "z"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - - , ( m ["abc", "pqr", "xyz"] - , m [ "", "", ""] - , m [ "", "", ""] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["ab-", "pq-", "xy-"] - - , ( m ["ab" , "pq" , "xy" ] - , m [ "c", "r", "z"] - , m [ "-", "-", "-"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["a--", "p--", "x--"] - , ( m ["a" , "p" , "x" ] - , m [ "bc", "qr", "yz"] - , m [ "--", "--", "--"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - , ( m ["" , "" , "" ] - , m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - ) - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural :: Spec -exampleSpec_LeftGCDMonoid_stripCommonPrefix_Sum_Natural = unitTestSpec - "LeftGCDMonoid.stripCommonPrefix (Sum Natural)" - "stripCommonPrefix" - (stripCommonPrefix) - (exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural) - -exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - ( MonoidMap LatinChar (Sum Natural) - , MonoidMap LatinChar (Sum Natural) - , MonoidMap LatinChar (Sum Natural) - ) -exampleData_LeftGCDMonoid_stripCommonPrefix_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4] - , m [4, 3, 2, 1, 0] - - , ( m [0, 1, 2, 1, 0] - , m [0, 0, 0, 2, 4] - , m [4, 2, 0, 0, 0] - ) - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- RightGCDMonoid --------------------------------------------------------------------------------- - -exampleSpec_RightGCDMonoid_commonSuffix_String :: Spec -exampleSpec_RightGCDMonoid_commonSuffix_String = unitTestSpec - "RightGCDMonoid.commonSuffix (String)" - "commonSuffix" - (commonSuffix) - (exampleData_RightGCDMonoid_commonSuffix_String) - -exampleData_RightGCDMonoid_commonSuffix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_RightGCDMonoid_commonSuffix_String = unitTestData2 - [ ( m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - , m [ "" , "", ""] - ) - , ( m ["--c", "--r", "--z"] - , m ["abc", "pqr", "xyz"] - , m [ "c", "r", "z"] - ) - , ( m ["-bc", "-qr", "-yz"] - , m ["abc", "pqr", "xyz"] - , m [ "bc", "qr", "yz"] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["-bc", "-qr", "-yz"] - , m [ "bc", "qr", "yz"] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["--c", "--r", "--z"] - , m [ "c", "r", "z"] - ) - , ( m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - , m [ "", "", ""] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural :: Spec -exampleSpec_RightGCDMonoid_commonSuffix_Sum_Natural = unitTestSpec - "RightGCDMonoid.commonSuffix (Sum Natural)" - "commonSuffix" - (commonSuffix) - (exampleData_RightGCDMonoid_commonSuffix_Sum_Natural) - -exampleData_RightGCDMonoid_commonSuffix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_RightGCDMonoid_commonSuffix_Sum_Natural = unitTestData2 - [ ( m [0, 0, 0] - , m [1, 2, 3] - , m [0, 0, 0] - ) - , ( m [1, 1, 1] - , m [1, 2, 3] - , m [1, 1, 1] - ) - , ( m [2, 2, 2] - , m [1, 2, 3] - , m [1, 2, 2] - ) - , ( m [3, 3, 3] - , m [1, 2, 3] - , m [1, 2, 3] - ) - , ( m [4, 4, 4] - , m [1, 2, 3] - , m [1, 2, 3] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_RightGCDMonoid_stripCommonSuffix_String :: Spec -exampleSpec_RightGCDMonoid_stripCommonSuffix_String = unitTestSpec - "RightGCDMonoid.stripCommonSuffix (String)" - "stripCommonSuffix" - (stripCommonSuffix) - (exampleData_RightGCDMonoid_stripCommonSuffix_String) - -exampleData_RightGCDMonoid_stripCommonSuffix_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - ( MonoidMap LatinChar String - , MonoidMap LatinChar String - , MonoidMap LatinChar String - ) -exampleData_RightGCDMonoid_stripCommonSuffix_String = unitTestData2 - [ ( m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - - , ( m ["---", "---", "---"] - , m ["abc", "pqr", "xyz"] - , m [ "", "", ""] - ) - ) - , ( m ["--c", "--r", "--z"] - , m ["abc", "pqr", "xyz"] - - , ( m ["--" , "--" , "--" ] - , m ["ab" , "pq" , "xy" ] - , m [ "c", "r", "z"] - ) - ) - , ( m ["--c", "--r", "--z"] - , m ["abc", "pqr", "xyz"] - - , ( m ["--" , "--" , "--" ] - , m ["ab" , "pq" , "xy" ] - , m [ "c", "r", "z"] - ) - ) - , ( m ["-bc", "-qr", "-yz"] - , m ["abc", "pqr", "xyz"] - - , ( m ["-" , "-" , "-" ] - , m ["a" , "p" , "x" ] - , m [ "bc", "qr", "yz"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["abc", "pqr", "xyz"] - - , ( m ["" , "" , "" ] - , m ["" , "" , "" ] - , m ["abc", "pqr", "xyz"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["-bc", "-qr", "-yz"] - - , ( m ["a" , "p" , "x" ] - , m ["-" , "-" , "-" ] - , m [ "bc", "qr", "yz"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["--c", "--r", "--z"] - - , ( m ["ab" , "pq" , "xy" ] - , m ["--" , "--" , "--" ] - , m [ "c", "r", "z"] - ) - ) - , ( m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - - , ( m ["abc", "pqr", "xyz"] - , m ["---", "---", "---"] - , m [ "", "", ""] - ) - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural :: Spec -exampleSpec_RightGCDMonoid_stripCommonSuffix_Sum_Natural = unitTestSpec - "RightGCDMonoid.stripCommonSuffix (Sum Natural)" - "stripCommonSuffix" - (stripCommonSuffix) - (exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural) - -exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - ( MonoidMap LatinChar (Sum Natural) - , MonoidMap LatinChar (Sum Natural) - , MonoidMap LatinChar (Sum Natural) - ) -exampleData_RightGCDMonoid_stripCommonSuffix_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4] - , m [4, 3, 2, 1, 0] - - , ( m [0, 0, 0, 2, 4] - , m [4, 2, 0, 0, 0] - , m [0, 1, 2, 1, 0] - ) - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- OverlappingGCDMonoid --------------------------------------------------------------------------------- - -exampleSpec_OverlappingGCDMonoid_overlap_String :: Spec -exampleSpec_OverlappingGCDMonoid_overlap_String = unitTestSpec - "OverlappingGCDMonoid.overlap (String)" - "overlap" - (overlap) - (exampleData_OverlappingGCDMonoid_overlap_String) - -exampleData_OverlappingGCDMonoid_overlap_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_OverlappingGCDMonoid_overlap_String = unitTestData2 - [ ( m ["abcd" , "0123" ] - , m [ "efgh", "4567"] - , m [ "" , "" ] - ) - , ( m ["abcde" , "01234" ] - , m [ "defgh", "34567"] - , m [ "de" , "34" ] - ) - , ( m ["abcdef" , "012345" ] - , m [ "cdefgh", "234567"] - , m [ "cdef" , "2345" ] - ) - , ( m ["abcdefg" , "0123456" ] - , m [ "bcdefgh", "1234567"] - , m [ "bcdefg" , "123456" ] - ) - , ( m ["abcdefgh", "01234567"] - , m ["abcdefgh", "01234567"] - , m ["abcdefgh", "01234567"] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural :: Spec -exampleSpec_OverlappingGCDMonoid_overlap_Sum_Natural = unitTestSpec - "OverlappingGCDMonoid.overlap (Sum Natural)" - "overlap" - (overlap) - (exampleData_OverlappingGCDMonoid_overlap_Sum_Natural) - -exampleData_OverlappingGCDMonoid_overlap_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_OverlappingGCDMonoid_overlap_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String :: Spec -exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_String = unitTestSpec - "OverlappingGCDMonoid.stripPrefixOverlap (String)" - "stripPrefixOverlap" - (stripPrefixOverlap) - (exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String) - -exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_OverlappingGCDMonoid_stripPrefixOverlap_String = unitTestData2 - [ ( m ["abcd" , "0123" ] - , m [ "efgh", "4567"] - , m [ "efgh", "4567"] - ) - , ( m ["abcde" , "01234" ] - , m [ "defgh", "34567"] - , m [ "fgh", "567"] - ) - , ( m ["abcdef" , "012345" ] - , m [ "cdefgh", "234567"] - , m [ "gh", "67"] - ) - , ( m ["abcdefg" , "0123456" ] - , m [ "bcdefgh", "1234567"] - , m [ "h", "7"] - ) - , ( m ["abcdefgh", "01234567"] - , m ["abcdefgh", "01234567"] - , m [ "", ""] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String :: Spec -exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_String = unitTestSpec - "OverlappingGCDMonoid.stripSuffixOverlap (String)" - "stripSuffixOverlap" - (stripSuffixOverlap) - (exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String) - -exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String :: UnitTestData2 - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) - (MonoidMap LatinChar String) -exampleData_OverlappingGCDMonoid_stripSuffixOverlap_String = unitTestData2 - [ ( m [ "efgh", "4567"] - , m ["abcd" , "0123" ] - , m ["abcd" , "0123" ] - ) - , ( m [ "defgh", "34567"] - , m ["abcde" , "01234" ] - , m ["abc" , "012" ] - ) - , ( m [ "cdefgh", "234567"] - , m ["abcdef" , "012345" ] - , m ["ab" , "01" ] - ) - , ( m [ "bcdefgh", "1234567"] - , m ["abcdefg" , "0123456" ] - , m ["a" , "0" ] - ) - , ( m ["abcdefgh", "01234567"] - , m ["abcdefgh", "01234567"] - , m ["" , "" ] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural :: Spec -exampleSpec_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural = unitTestSpec - "OverlappingGCDMonoid.stripPrefixOverlap (Sum Natural)" - "stripPrefixOverlap" - (stripPrefixOverlap) - (exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural) - -exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural - :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_OverlappingGCDMonoid_stripPrefixOverlap_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [9, 7, 5, 3, 1, 0, 0, 0, 0, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural :: Spec -exampleSpec_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural = unitTestSpec - "OverlappingGCDMonoid.stripSuffixOverlap (Sum Natural)" - "stripSuffixOverlap" - (stripSuffixOverlap) - (exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural) - -exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural - :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_OverlappingGCDMonoid_stripSuffixOverlap_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [9, 7, 5, 3, 1, 0, 0, 0, 0, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- GCDMonoid --------------------------------------------------------------------------------- - -exampleSpec_GCDMonoid_gcd_Product_Natural :: Spec -exampleSpec_GCDMonoid_gcd_Product_Natural = unitTestSpec - "GCDMonoid.gcd (Product Natural)" - "gcd" - (gcd) - (exampleData_GCDMonoid_gcd_Product_Natural) - -exampleData_GCDMonoid_gcd_Product_Natural :: UnitTestData2 - (MonoidMap LatinChar (Product Natural)) - (MonoidMap LatinChar (Product Natural)) - (MonoidMap LatinChar (Product Natural)) -exampleData_GCDMonoid_gcd_Product_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [1, 1, 1, 1, 1, 1, 1, 1, 1, 1] - , m [1, 1, 1, 1, 1, 1, 1, 1, 1, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [2, 2, 2, 2, 2, 2, 2, 2, 2, 2] - , m [2, 1, 2, 1, 2, 1, 2, 1, 2, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [3, 3, 3, 3, 3, 3, 3, 3, 3, 3] - , m [3, 1, 1, 3, 1, 1, 3, 1, 1, 3] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [4, 4, 4, 4, 4, 4, 4, 4, 4, 4] - , m [4, 1, 2, 1, 4, 1, 2, 1, 4, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [5, 5, 5, 5, 5, 5, 5, 5, 5, 5] - , m [5, 1, 1, 1, 1, 5, 1, 1, 1, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [6, 6, 6, 6, 6, 6, 6, 6, 6, 6] - , m [6, 1, 2, 3, 2, 1, 6, 1, 2, 3] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [7, 7, 7, 7, 7, 7, 7, 7, 7, 7] - , m [7, 1, 1, 1, 1, 1, 1, 7, 1, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [8, 8, 8, 8, 8, 8, 8, 8, 8, 8] - , m [8, 1, 2, 1, 4, 1, 2, 1, 8, 1] - ) - , ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 9, 9, 9, 9, 9, 9, 9, 9, 9] - , m [9, 1, 1, 3, 1, 1, 3, 1, 1, 9] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_GCDMonoid_gcd_Sum_Natural :: Spec -exampleSpec_GCDMonoid_gcd_Sum_Natural = unitTestSpec - "GCDMonoid.gcd (Sum Natural)" - "gcd" - (gcd) - (exampleData_GCDMonoid_gcd_Sum_Natural) - -exampleData_GCDMonoid_gcd_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_GCDMonoid_gcd_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] - ) - , ( m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [0, 1, 2, 3, 4, 4, 3, 2, 1, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_GCDMonoid_gcd_Set_Natural :: Spec -exampleSpec_GCDMonoid_gcd_Set_Natural = unitTestSpec - "GCDMonoid.gcd (Set Natural)" - "gcd" - (gcd) - (exampleData_GCDMonoid_gcd_Set_Natural) - -exampleData_GCDMonoid_gcd_Set_Natural :: UnitTestData2 - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) -exampleData_GCDMonoid_gcd_Set_Natural = unitTestData2 - [ ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ ], [ ]] - , m [[ ], [ ]] - ) - , ( m [[ ], [ ]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ ], [ ]] - ) - , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - ) - , ( m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - ) - , ( m [[0, 1, 2 ], [4, 5, 6 ]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[ 1, 2 ], [ 5, 6 ]] - ) - , ( m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2 ], [4, 5, 6 ]] - , m [[ 1, 2 ], [ 5, 6 ]] - ) - , ( m [[0, 1 ], [4, 5 ]] - , m [[ 2, 3], [ 6, 7]] - , m [[ ], [ ]] - ) - , ( m [[ 2, 3], [ 6, 7]] - , m [[0, 1 ], [4, 5 ]] - , m [[ ], [ ]] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList - --------------------------------------------------------------------------------- --- LCMMonoid --------------------------------------------------------------------------------- - -exampleSpec_LCMMonoid_lcm_Product_Natural :: Spec -exampleSpec_LCMMonoid_lcm_Product_Natural = unitTestSpec - "LCMMonoid.lcm (Product Natural)" - "lcm" - (lcm) - (exampleData_LCMMonoid_lcm_Product_Natural) - -exampleData_LCMMonoid_lcm_Product_Natural :: UnitTestData2 - (MonoidMap LatinChar (Product Natural)) - (MonoidMap LatinChar (Product Natural)) - (MonoidMap LatinChar (Product Natural)) -exampleData_LCMMonoid_lcm_Product_Natural = unitTestData2 - [ ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - , m [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1] - , m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2] - , m [ 0, 2, 2, 6, 4, 10, 6, 14, 8, 18] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3] - , m [ 0, 3, 6, 3, 12, 15, 6, 21, 24, 9] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4] - , m [ 0, 4, 4, 12, 4, 20, 12, 28, 8, 36] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5] - , m [ 0, 5, 10, 15, 20, 5, 30, 35, 40, 45] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 6, 6, 6, 6, 6, 6, 6, 6, 6, 6] - , m [ 0, 6, 6, 6, 12, 30, 6, 42, 24, 18] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7] - , m [ 0, 7, 14, 21, 28, 35, 42, 7, 56, 63] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8] - , m [ 0, 8, 8, 24, 8, 40, 24, 56, 8, 72] - ) - , ( m [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9] - , m [ 0, 9, 18, 9, 36, 45, 18, 63, 72, 9] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_LCMMonoid_lcm_Sum_Natural :: Spec -exampleSpec_LCMMonoid_lcm_Sum_Natural = unitTestSpec - "LCMMonoid.lcm (Sum Natural)" - "lcm" - (lcm) - (exampleData_LCMMonoid_lcm_Sum_Natural) - -exampleData_LCMMonoid_lcm_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_LCMMonoid_lcm_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [9, 8, 7, 6, 5, 5, 6, 7, 8, 9] - ) - , ( m [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] - , m [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] - , m [9, 8, 7, 6, 5, 5, 6, 7, 8, 9] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - -exampleSpec_LCMMonoid_lcm_Set_Natural :: Spec -exampleSpec_LCMMonoid_lcm_Set_Natural = unitTestSpec - "LCMMonoid.lcm (Set Natural)" - "lcm" - (lcm) - (exampleData_LCMMonoid_lcm_Set_Natural) - -exampleData_LCMMonoid_lcm_Set_Natural :: UnitTestData2 - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) -exampleData_LCMMonoid_lcm_Set_Natural = unitTestData2 - [ ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ ], [ ]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[ ], [ ]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[0, 1, 2 ], [4, 5, 6 ]] - , m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[ 1, 2, 3], [ 5, 6, 7]] - , m [[0, 1, 2 ], [4, 5, 6 ]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[0, 1 ], [4, 5 ]] - , m [[ 2, 3], [ 6, 7]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - , ( m [[ 2, 3], [ 6, 7]] - , m [[0, 1 ], [4, 5 ]] - , m [[0, 1, 2, 3], [4, 5, 6, 7]] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList - --------------------------------------------------------------------------------- --- Monus --------------------------------------------------------------------------------- - -exampleSpec_Monus_monus_Set_Natural :: Spec -exampleSpec_Monus_monus_Set_Natural = unitTestSpec - "Monus.monus (Set Natural)" - "<\\>" - (<\>) - (exampleData_Monus_monus_Set_Natural) - -exampleData_Monus_monus_Set_Natural :: UnitTestData2 - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) - (MonoidMap LatinChar (Set Natural)) -exampleData_Monus_monus_Set_Natural = unitTestData2 - [ ( m [[0, 1, 2], [3, 4, 5]] - , m [[ ], [ ]] - , m [[0, 1, 2], [3, 4, 5]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[0 ], [3 ]] - , m [[ 1, 2], [ 4, 5]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[ 1 ], [ 4 ]] - , m [[0, 2], [3, 5]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[ 2], [ 5]] - , m [[0, 1 ], [3, 4 ]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[0, 1, 2], [3, 4, 5]] - , m [[ ], [ ]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[3, 4, 5], [0, 1, 2]] - , m [[0, 1, 2], [3, 4, 5]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[2, 3, 4], [1, 2, 3]] - , m [[0, 1 ], [ 4, 5]] - ) - , ( m [[0, 1, 2], [3, 4, 5]] - , m [[1, 2, 3], [2, 3, 4]] - , m [[0 ], [ 5]] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] . fmap Set.fromList - -exampleSpec_Monus_monus_Sum_Natural :: Spec -exampleSpec_Monus_monus_Sum_Natural = unitTestSpec - "Monus.monus (Sum Natural)" - "<\\>" - (<\>) - (exampleData_Monus_monus_Sum_Natural) - -exampleData_Monus_monus_Sum_Natural :: UnitTestData2 - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) - (MonoidMap LatinChar (Sum Natural)) -exampleData_Monus_monus_Sum_Natural = unitTestData2 - [ ( m [0, 1, 2, 3] - , m [0, 0, 0, 0] - , m [0, 1, 2, 3] - ) - , ( m [0, 1, 2, 3] - , m [1, 1, 1, 1] - , m [0, 0, 1, 2] - ) - , ( m [0, 1, 2, 3] - , m [2, 2, 2, 2] - , m [0, 0, 0, 1] - ) - , ( m [0, 1, 2, 3] - , m [3, 3, 3, 3] - , m [0, 0, 0, 0] - ) - , ( m [0, 1, 2, 3] - , m [4, 4, 4, 4] - , m [0, 0, 0, 0] - ) - ] - where - m = MonoidMap.fromList . zip [A ..] - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -data LatinChar - = A | B | C | D | E | F | G | H | I | J | K | L | M - | N | O | P | Q | R | S | T | U | V | W | X | Y | Z - deriving (Bounded, Enum, Eq, Ord, Show) diff --git a/src/test/Data/MonoidMap/FilterSpec.hs b/src/test/Data/MonoidMap/FilterSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/FilterSpec.hs +++ /dev/null @@ -1,156 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.FilterSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.MonoidMap - ( MonoidMap, nonNullCount ) -import Data.Proxy - ( Proxy (..) ) -import GHC.Exts - ( IsList (..) ) -import Test.Common - ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) - -import qualified Data.List as List -import qualified Data.MonoidMap as MonoidMap - -spec :: Spec -spec = describe "Filtering" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_filter_get" $ - prop_filter_get - @k @v & property - it "prop_filter_asList" $ - prop_filter_asList - @k @v & property - it "prop_filterKeys_get" $ - prop_filterKeys_get - @k @v & property - it "prop_filterKeys_asList" $ - prop_filterKeys_asList - @k @v & property - it "prop_filterWithKey_get" $ - prop_filterWithKey_get - @k @v & property - it "prop_filterWithKey_asList" $ - prop_filterWithKey_asList - @k @v & property - -prop_filter_get - :: Test k v => Fun v Bool -> k -> MonoidMap k v -> Property -prop_filter_get (applyFun -> f) k m = - MonoidMap.get k (MonoidMap.filter f m) - === - (MonoidMap.get k m & \v -> if f v then v else mempty) - & cover 2 - (MonoidMap.nullKey k m && f (MonoidMap.get k m)) - "MonoidMap.nullKey k m && f (MonoidMap.get k m)" - & cover 2 - (MonoidMap.nullKey k m && not (f (MonoidMap.get k m))) - "MonoidMap.nullKey k m && not (f (MonoidMap.get k m))" - & cover 2 - (MonoidMap.nonNullKey k m && f (MonoidMap.get k m)) - "MonoidMap.nonNullKey k m && f (MonoidMap.get k m)" - & cover 2 - (MonoidMap.nonNullKey k m && not (f (MonoidMap.get k m))) - "MonoidMap.nonNullKey k m && not (f (MonoidMap.get k m))" - -prop_filter_asList - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -prop_filter_asList (applyFun -> f) m = - n === fromList (List.filter (f . snd) (toList m)) - & cover 2 - (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" - & cover 2 - (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" - where - n = MonoidMap.filter f m - -prop_filterKeys_get - :: Test k v => Fun k Bool -> k -> MonoidMap k v -> Property -prop_filterKeys_get (applyFun -> f) k m = - MonoidMap.get k (MonoidMap.filterKeys f m) - === - (if f k then MonoidMap.get k m else mempty) - & cover 2 - (MonoidMap.nullKey k m && f k) - "MonoidMap.nullKey k m && f k" - & cover 2 - (MonoidMap.nullKey k m && not (f k)) - "MonoidMap.nullKey k m && not (f k)" - & cover 2 - (MonoidMap.nonNullKey k m && f k) - "MonoidMap.nonNullKey k m && f k" - & cover 2 - (MonoidMap.nonNullKey k m && not (f k)) - "MonoidMap.nonNullKey k m && not (f k)" - -prop_filterKeys_asList - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -prop_filterKeys_asList (applyFun -> f) m = - n === MonoidMap.fromList (List.filter (f . fst) (toList m)) - & cover 2 - (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" - & cover 2 - (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" - where - n = MonoidMap.filterKeys f m - -prop_filterWithKey_get - :: Test k v => Fun (k, v) Bool -> k -> MonoidMap k v -> Property -prop_filterWithKey_get (applyFun2 -> f) k m = - MonoidMap.get k (MonoidMap.filterWithKey f m) - === - (MonoidMap.get k m & \v -> if f k v then v else mempty) - & cover 2 - (MonoidMap.nullKey k m && f k (MonoidMap.get k m)) - "MonoidMap.nullKey k m && f k (MonoidMap.get k m)" - & cover 2 - (MonoidMap.nullKey k m && not (f k (MonoidMap.get k m))) - "MonoidMap.nullKey k m && not (f k (MonoidMap.get k m))" - & cover 2 - (MonoidMap.nonNullKey k m && f k (MonoidMap.get k m)) - "MonoidMap.nonNullKey k m && f k (MonoidMap.get k m)" - & cover 2 - (MonoidMap.nonNullKey k m && not (f k (MonoidMap.get k m))) - "MonoidMap.nonNullKey k m && not (f k (MonoidMap.get k m))" - -prop_filterWithKey_asList - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -prop_filterWithKey_asList (applyFun2 -> f) m = - n === MonoidMap.fromList (List.filter (uncurry f) (toList m)) - & cover 2 - (MonoidMap.nonNull n && nonNullCount n == nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n == nonNullCount m" - & cover 2 - (MonoidMap.nonNull n && nonNullCount n /= nonNullCount m) - "MonoidMap.nonNull n && nonNullCount n /= nonNullCount m" - where - n = MonoidMap.filterWithKey f m diff --git a/src/test/Data/MonoidMap/FoldSpec.hs b/src/test/Data/MonoidMap/FoldSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/FoldSpec.hs +++ /dev/null @@ -1,187 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.FoldSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -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 - ( Fun (..), Property, applyFun2, applyFun3, (===) ) - -import qualified Data.Map.Strict as Map -import qualified Data.MonoidMap as MonoidMap - -spec :: Spec -spec = describe "Folding" $ 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 "Lazy" $ do - - it "prop_equivalence_foldl" $ - prop_equivalence_foldl - @k @v & property - it "prop_equivalence_foldr" $ - prop_equivalence_foldr - @k @v & property - it "prop_equivalence_foldlWithKey" $ - prop_equivalence_foldlWithKey - @k @v & property - it "prop_equivalence_foldrWithKey" $ - prop_equivalence_foldrWithKey - @k @v & property - it "prop_equivalence_foldMapWithKey" $ - prop_equivalence_foldMapWithKey - @k @v & property - - describe "Strict" $ do - - it "prop_equivalence_foldl'" $ - prop_equivalence_foldl' - @k @v & property - it "prop_equivalence_foldr'" $ - prop_equivalence_foldr' - @k @v & property - it "prop_equivalence_foldlWithKey'" $ - prop_equivalence_foldlWithKey' - @k @v & property - it "prop_equivalence_foldrWithKey'" $ - prop_equivalence_foldrWithKey' - @k @v & property - it "prop_equivalence_foldMapWithKey'" $ - prop_equivalence_foldMapWithKey' - @k @v & property - --------------------------------------------------------------------------------- --- Lazy folding --------------------------------------------------------------------------------- - -prop_equivalence_foldl - :: Test k v - => r ~ v - => Fun (r, v) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldl (applyFun2 -> f) r m = - MonoidMap.foldl f r m - === Map.foldl f r (MonoidMap.toMap m) - -prop_equivalence_foldr - :: Test k v - => r ~ v - => Fun (v, r) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldr (applyFun2 -> f) r m = - MonoidMap.foldr f r m - === Map.foldr f r (MonoidMap.toMap m) - -prop_equivalence_foldlWithKey - :: Test k v - => r ~ v - => Fun (r, k, v) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldlWithKey (applyFun3 -> f) r m = - MonoidMap.foldlWithKey f r m - === Map.foldlWithKey f r (MonoidMap.toMap m) - -prop_equivalence_foldrWithKey - :: Test k v - => r ~ v - => Fun (k, v, r) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldrWithKey (applyFun3 -> f) r m = - MonoidMap.foldrWithKey f r m - === Map.foldrWithKey f r (MonoidMap.toMap m) - -prop_equivalence_foldMapWithKey - :: Test k v - => r ~ v - => Fun (k, v) r - -> MonoidMap k v - -> Property -prop_equivalence_foldMapWithKey (applyFun2 -> f) m = - MonoidMap.foldMapWithKey f m - === Map.foldMapWithKey f (MonoidMap.toMap m) - --------------------------------------------------------------------------------- --- Strict folding --------------------------------------------------------------------------------- - -prop_equivalence_foldl' - :: Test k v - => r ~ v - => Fun (r, v) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldl' (applyFun2 -> f) r m = - MonoidMap.foldl' f r m === - MonoidMap.foldl f r m - -prop_equivalence_foldr' - :: Test k v - => r ~ v - => Fun (v, r) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldr' (applyFun2 -> f) r m = - MonoidMap.foldr' f r m === - MonoidMap.foldr f r m - -prop_equivalence_foldlWithKey' - :: Test k v - => r ~ v - => Fun (r, k, v) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldlWithKey' (applyFun3 -> f) r m = - MonoidMap.foldlWithKey' f r m === - MonoidMap.foldlWithKey f r m - -prop_equivalence_foldrWithKey' - :: Test k v - => r ~ v - => Fun (k, v, r) r - -> r - -> MonoidMap k v - -> Property -prop_equivalence_foldrWithKey' (applyFun3 -> f) r m = - MonoidMap.foldrWithKey' f r m === - MonoidMap.foldrWithKey f r m - -prop_equivalence_foldMapWithKey' - :: Test k v - => r ~ v - => Fun (k, v) r - -> MonoidMap k v - -> Property -prop_equivalence_foldMapWithKey' (applyFun2 -> f) m = - MonoidMap.foldMapWithKey' f m === - MonoidMap.foldMapWithKey f m diff --git a/src/test/Data/MonoidMap/IntersectionSpec.hs b/src/test/Data/MonoidMap/IntersectionSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/IntersectionSpec.hs +++ /dev/null @@ -1,193 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.IntersectionSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Functor.Identity - ( Identity (..) ) -import Data.Monoid.Cancellative - ( GCDMonoid ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesGCDMonoid - , testTypesMonoidNull - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun2, conjoin, cover, expectFailure, (===) ) - -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Intersection" $ do - - forM_ testTypesMonoidNull $ - \(TestType p) -> specMonoidNull - (Proxy @Key) p - forM_ testTypesGCDMonoid $ - \(TestType p) -> specGCDMonoid - (Proxy @Key) p - -specMonoidNull :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specMonoidNull = makeSpec $ do - it "prop_intersectionWith_get" $ - prop_intersectionWith_get - @k @v & property - it "prop_intersectionWith_get_total" $ - prop_intersectionWith_get_total - @k @v & property - it "prop_intersectionWith_get_total_failure" $ - prop_intersectionWith_get_total_failure - @k @v & property - it "prop_intersectionWith_intersectionWithA" $ - prop_intersectionWith_intersectionWithA - @k @v & property - -specGCDMonoid - :: forall k v. (Test k v, GCDMonoid v) => Proxy k -> Proxy v -> Spec -specGCDMonoid = makeSpec $ do - it "prop_intersection_isSubmapOf" $ - prop_intersection_isSubmapOf - @k @v & property - -prop_intersection_isSubmapOf - :: (Test k v, GCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_intersection_isSubmapOf m1 m2 = conjoin - [ intersection_m1_m2 `MonoidMap.isSubmapOf` m1 - , intersection_m1_m2 `MonoidMap.isSubmapOf` m2 - ] - & cover 2 - (m1 /= m2 && MonoidMap.nonNull (intersection_m1_m2)) - "m1 /= m2 && MonoidMap.nonNull (intersection_m1_m2)" - where - intersection_m1_m2 = MonoidMap.intersection m1 m2 - -prop_intersectionWith_get - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_intersectionWith_get (applyFun2 -> f) m1 m2 k = - (MonoidMap.get k result - === - if keyWithinIntersection - then f (MonoidMap.get k m1) (MonoidMap.get k m2) - else mempty) - & cover 2 - (keyWithinIntersection) - "keyWithinIntersection" - & cover 2 - (not keyWithinIntersection) - "not keyWithinIntersection" - & cover 2 - (MonoidMap.null result) - "MonoidMap.null result" - & cover 2 - (MonoidMap.nonNull result) - "MonoidMap.nonNull result" - & cover 2 - (MonoidMap.nullKey k result) - "MonoidMap.nullKey k result" - & cover 2 - (MonoidMap.nonNullKey k result) - "MonoidMap.nonNullKey k result" - where - keyWithinIntersection = - k `Set.member` Set.intersection - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - result = - MonoidMap.intersectionWith f m1 m2 - -prop_intersectionWith_get_total - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_intersectionWith_get_total (applyFun2 -> f0) m1 m2 k = - (MonoidMap.get k result - === - f (MonoidMap.get k m1) (MonoidMap.get k m2)) - & cover 2 - (keyWithinIntersection) - "keyWithinIntersection" - & cover 2 - (not keyWithinIntersection) - "not keyWithinIntersection" - & cover 2 - (MonoidMap.null result) - "MonoidMap.null result" - & cover 2 - (MonoidMap.nonNull result) - "MonoidMap.nonNull result" - & cover 2 - (MonoidMap.nullKey k result) - "MonoidMap.nullKey k result" - & cover 2 - (MonoidMap.nonNullKey k result) - "MonoidMap.nonNullKey k result" - where - result = - MonoidMap.intersectionWith f m1 m2 - keyWithinIntersection = - k `Set.member` Set.intersection - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - f v1 v2 - | Null.null v1 = mempty - | Null.null v2 = mempty - | otherwise = f0 v1 v2 - -prop_intersectionWith_get_total_failure - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_intersectionWith_get_total_failure (applyFun2 -> f) m1 m2 k = - expectFailure $ - MonoidMap.get k (MonoidMap.intersectionWith f m1 m2) - === - f (MonoidMap.get k m1) (MonoidMap.get k m2) - -prop_intersectionWith_intersectionWithA - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> Property -prop_intersectionWith_intersectionWithA (applyFun2 -> f) m1 m2 = - runIdentity (MonoidMap.intersectionWithA ((fmap . fmap) Identity f) m1 m2) - === (MonoidMap.intersectionWith f m1 m2) diff --git a/src/test/Data/MonoidMap/MapSpec.hs b/src/test/Data/MonoidMap/MapSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/MapSpec.hs +++ /dev/null @@ -1,293 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.MapSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Bifunctor - ( first, second ) -import Data.Function - ( (&) ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.MonoidMap - ( MonoidMap, nonNullCount ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun, applyFun2, cover, expectFailure, (===) ) - -import qualified Data.Foldable as F -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Mapping" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_map_asList" $ - prop_map_asList - @k @v & property - it "prop_map_composition" $ - prop_map_composition - @k @v & property - it "prop_map_composition_failure" $ - prop_map_composition_failure - @k @v & property - it "prop_map_get" $ - prop_map_get - @k @v & property - it "prop_map_get_total" $ - prop_map_get_total - @k @v & property - it "prop_map_get_total_failure" $ - prop_map_get_total_failure - @k @v & property - it "prop_mapKeys_asList" $ - prop_mapKeys_asList - @k @v & property - it "prop_mapKeys_get" $ - prop_mapKeys_get - @k @v & property - it "prop_mapKeysWith_asList" $ - prop_mapKeysWith_asList - @k @v & property - it "prop_mapWithKey_asList" $ - prop_mapWithKey_asList - @k @v & property - it "prop_mapWithKey_get" $ - prop_mapWithKey_get - @k @v & property - it "prop_mapWithKey_get_total" $ - prop_mapWithKey_get_total - @k @v & property - it "prop_mapWithKey_get_total_failure" $ - prop_mapWithKey_get_total_failure - @k @v & property - --------------------------------------------------------------------------------- --- Mapping --------------------------------------------------------------------------------- - -prop_map_asList - :: Test k v - => Fun v v - -> MonoidMap k v - -> Property -prop_map_asList (applyFun -> f) m = - n === (MonoidMap.fromList . fmap (second f) . MonoidMap.toList $ m) - & cover 2 - (0 < nonNullCount n && nonNullCount n < nonNullCount m) - "0 < nonNullCount n && nonNullCount n < nonNullCount m" - where - n = MonoidMap.map f m - -prop_map_composition - :: forall k v. Test k v - => Fun v v - -> Fun v v - -> MonoidMap k v - -> Property -prop_map_composition (applyFun -> f0) (applyFun -> g0) m = - MonoidMap.map (f . g) m === MonoidMap.map f (MonoidMap.map g m) - & cover 2 - (MonoidMap.nonNull m) - "MonoidMap.nonNull m" - where - f = toNullPreservingFn f0 - g = g0 - -prop_map_composition_failure - :: forall k v. Test k v - => Fun v v - -> Fun v v - -> MonoidMap k v - -> Property -prop_map_composition_failure (applyFun -> f) (applyFun -> g) m = - expectFailure $ - MonoidMap.map (f . g) m === MonoidMap.map f (MonoidMap.map g m) - & cover 1 - (MonoidMap.map (f . g) m /= MonoidMap.map f (MonoidMap.map g m)) - "MonoidMap.map (f . g) m /= MonoidMap.map f (MonoidMap.map g m)" - -prop_map_get - :: Test k v - => Fun v v - -> k - -> MonoidMap k v - -> Property -prop_map_get (applyFun -> f) k m = - MonoidMap.get k (MonoidMap.map f m) - === - (if MonoidMap.nullKey k m then mempty else f (MonoidMap.get k m)) - & cover 2 - (MonoidMap.nullKey k m) - "MonoidMap.nullKey k m" - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - -prop_map_get_total - :: forall k v. Test k v - => Fun v v - -> k - -> MonoidMap k v - -> Property -prop_map_get_total (applyFun -> f0) k m = - MonoidMap.get k (MonoidMap.map f m) === f (MonoidMap.get k m) - & cover 2 - (MonoidMap.nullKey k m) - "MonoidMap.nullKey k m" - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - where - f = toNullPreservingFn f0 - -prop_map_get_total_failure - :: Test k v - => Fun v v - -> k - -> MonoidMap k v - -> Property -prop_map_get_total_failure (applyFun -> f) k m = - expectFailure $ - MonoidMap.get k (MonoidMap.map f m) === f (MonoidMap.get k m) - -prop_mapKeys_asList - :: Test k v - => Fun k k - -> MonoidMap k v - -> Property -prop_mapKeys_asList (applyFun -> f) m = - n === (MonoidMap.fromList . fmap (first f) . MonoidMap.toList $ m) - & cover 2 - (0 < nonNullCount n && nonNullCount n < nonNullCount m) - "0 < nonNullCount n && nonNullCount n < nonNullCount m" - where - n = MonoidMap.mapKeys f m - -prop_mapKeys_get - :: Test k v - => Fun k k - -> k - -> MonoidMap k v - -> Property -prop_mapKeys_get (applyFun -> f) k m = - MonoidMap.get k (MonoidMap.mapKeys f m) - === - F.foldMap - (`MonoidMap.get` m) - (Set.filter ((==) k . f) (MonoidMap.nonNullKeys m)) - & cover 2 - (MonoidMap.nullKey k (MonoidMap.mapKeys f m)) - "MonoidMap.nullKey k (MonoidMap.mapKeys f m)" - & cover 2 - (MonoidMap.nonNullKey k (MonoidMap.mapKeys f m)) - "MonoidMap.nonNullKey k (MonoidMap.mapKeys f m)" - -prop_mapKeysWith_asList - :: Test k v - => Fun (v, v) v - -> Fun k k - -> MonoidMap k v - -> Property -prop_mapKeysWith_asList (applyFun2 -> c) (applyFun -> f) m = - n === (MonoidMap.fromListWith c . fmap (first f) . MonoidMap.toList $ m) - & cover 2 - (0 < nonNullCount n && nonNullCount n < nonNullCount m) - "0 < nonNullCount n && nonNullCount n < nonNullCount m" - where - n = MonoidMap.mapKeysWith c f m - -prop_mapWithKey_asList - :: Test k v - => Fun (k, v) v - -> MonoidMap k v - -> Property -prop_mapWithKey_asList (applyFun2 -> f) m = - n === - ( MonoidMap.fromList - . fmap (\(k, v) -> (k, (f k v))) - . MonoidMap.toList - $ m - ) - & cover 2 - (0 < nonNullCount n && nonNullCount n < nonNullCount m) - "0 < nonNullCount n && nonNullCount n < nonNullCount m" - where - n = MonoidMap.mapWithKey f m - -prop_mapWithKey_get - :: Test k v - => Fun (k, v) v - -> k - -> MonoidMap k v - -> Property -prop_mapWithKey_get (applyFun2 -> f) k m = - MonoidMap.get k (MonoidMap.mapWithKey f m) - === - (if MonoidMap.nullKey k m then mempty else f k (MonoidMap.get k m)) - & cover 2 - (MonoidMap.nullKey k m) - "MonoidMap.nullKey k m" - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - -prop_mapWithKey_get_total - :: forall k v. Test k v - => Fun (k, v) v - -> k - -> MonoidMap k v - -> Property -prop_mapWithKey_get_total (applyFun2 -> f0) k m = - MonoidMap.get k (MonoidMap.mapWithKey f m) === f k (MonoidMap.get k m) - & cover 2 - (MonoidMap.nullKey k m) - "MonoidMap.nullKey k m" - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - where - f = toNullPreservingFn . f0 - -prop_mapWithKey_get_total_failure - :: Test k v - => Fun (k, v) v - -> k - -> MonoidMap k v - -> Property -prop_mapWithKey_get_total_failure (applyFun2 -> f) k m = - expectFailure $ - MonoidMap.get k (MonoidMap.mapWithKey f m) === f k (MonoidMap.get k m) - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - --- | Creates a function that never maps null values to non-null values. --- -toNullPreservingFn :: MonoidNull v => (v -> v) -> (v -> v) -toNullPreservingFn f v - | Null.null v = v - | otherwise = f v diff --git a/src/test/Data/MonoidMap/MembershipSpec.hs b/src/test/Data/MonoidMap/MembershipSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/MembershipSpec.hs +++ /dev/null @@ -1,99 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.MembershipSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -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 - ( Property, cover, (===) ) - -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Membership" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_nullify_get" $ - prop_nullify_get - @k @v & property - it "prop_nullify_nonNullKey" $ - prop_nullify_nonNullKey - @k @v & property - it "prop_nullify_nonNullKeys" $ - prop_nullify_nonNullKeys - @k @v & property - it "prop_nonNullKeys_get" $ - prop_nonNullKeys_get - @k @v & property - -prop_nullify_get - :: Test k v => MonoidMap k v -> k -> Property -prop_nullify_get m k = - MonoidMap.get k (MonoidMap.nullify k m) === mempty - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - -prop_nullify_nonNullKey - :: Test k v => MonoidMap k v -> k -> Property -prop_nullify_nonNullKey m k = - MonoidMap.nonNullKey k (MonoidMap.nullify k m) === False - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - -prop_nullify_nonNullKeys - :: Test k v => MonoidMap k v -> k -> Property -prop_nullify_nonNullKeys m k = - Set.member k (MonoidMap.nonNullKeys (MonoidMap.nullify k m)) === False - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - & cover 2 - (not (MonoidMap.nonNullKey k m)) - "not (MonoidMap.nonNullKey k m)" - -prop_nonNullKeys_get - :: Test k v => MonoidMap k v -> Property -prop_nonNullKeys_get m = - fmap - (\k -> (k, MonoidMap.get k m)) - (Set.toList (MonoidMap.nonNullKeys m)) - === MonoidMap.toList m - & cover 2 - (MonoidMap.null m) - "MonoidMap.null m" - & cover 2 - (not (MonoidMap.null m)) - "not (MonoidMap.null m)" diff --git a/src/test/Data/MonoidMap/PartitionSpec.hs b/src/test/Data/MonoidMap/PartitionSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/PartitionSpec.hs +++ /dev/null @@ -1,166 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.PartitionSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -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 - ( Fun (..), Property, applyFun, applyFun2, cover, (===) ) - -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Partitioning" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_partition_filter" $ - prop_partition_filter - @k @v & property - it "prop_partition_append" $ - prop_partition_append - @k @v & property - it "prop_partition_disjoint" $ - prop_partition_disjoint - @k @v & property - it "prop_partitionKeys_filterKeys" $ - prop_partitionKeys_filterKeys - @k @v & property - it "prop_partitionKeys_append" $ - prop_partitionKeys_append - @k @v & property - it "prop_partitionKeys_disjoint" $ - prop_partitionKeys_disjoint - @k @v & property - it "prop_partitionWithKey_filterWithKey" $ - prop_partitionWithKey_filterWithKey - @k @v & property - it "prop_partitionWithKey_append" $ - prop_partitionWithKey_append - @k @v & property - it "prop_partitionWithKey_disjoint" $ - prop_partitionWithKey_disjoint - @k @v & property - -prop_partition_filter - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -prop_partition_filter (applyFun -> f) m = - MonoidMap.partition f m === (m1, m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - m1 = MonoidMap.filter f m - m2 = MonoidMap.filter (not . f) m - -prop_partition_append - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -prop_partition_append (applyFun -> f) m = - m1 <> m2 === m - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partition f m - -prop_partition_disjoint - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -prop_partition_disjoint (applyFun -> f) m = - Set.disjoint - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partition f m - -prop_partitionKeys_filterKeys - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -prop_partitionKeys_filterKeys (applyFun -> f) m = - MonoidMap.partitionKeys f m === (m1, m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - m1 = MonoidMap.filterKeys f m - m2 = MonoidMap.filterKeys (not . f) m - -prop_partitionKeys_append - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -prop_partitionKeys_append (applyFun -> f) m = - m1 <> m2 === m - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partitionKeys f m - -prop_partitionKeys_disjoint - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -prop_partitionKeys_disjoint (applyFun -> f) m = - Set.disjoint - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partitionKeys f m - -prop_partitionWithKey_filterWithKey - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -prop_partitionWithKey_filterWithKey (applyFun2 -> f) m = - MonoidMap.partitionWithKey f m === (m1, m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - m1 = MonoidMap.filterWithKey f m - m2 = MonoidMap.filterWithKey ((fmap . fmap) not f) m - -prop_partitionWithKey_append - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -prop_partitionWithKey_append (applyFun2 -> f) m = - m1 <> m2 === m - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partitionWithKey f m - -prop_partitionWithKey_disjoint - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -prop_partitionWithKey_disjoint (applyFun2 -> f) m = - Set.disjoint - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - & cover 2 - (MonoidMap.nonNull m1 && MonoidMap.nonNull m2) - "MonoidMap.nonNull m1 && MonoidMap.nonNull m2" - where - (m1, m2) = MonoidMap.partitionWithKey f m diff --git a/src/test/Data/MonoidMap/PrefixSpec.hs b/src/test/Data/MonoidMap/PrefixSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/PrefixSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.PrefixSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Maybe - ( isJust ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Data.Semigroup.Cancellative - ( LeftReductive (..) ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesLeftReductive - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Property, cover, (===) ) - -import qualified Test.QuickCheck as QC - -spec :: Spec -spec = describe "Prefixes" $ do - - forM_ testTypesLeftReductive $ - \(TestType p) -> specFor (Proxy @Key) p - -specFor - :: forall k v. (Test k v, LeftReductive v) => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - it "prop_stripPrefix_isJust" $ - prop_stripPrefix_isJust - @k @v & property - it "prop_stripPrefix_mappend" $ - prop_stripPrefix_mappend - @k @v & property - -prop_stripPrefix_isJust - :: (Test k v, LeftReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_stripPrefix_isJust m1 m2 = - isJust (stripPrefix m1 m2) === m1 `isPrefixOf` m2 - & cover 1 - (m1 `isPrefixOf` m2) - "m1 `isPrefixOf` m2" - -prop_stripPrefix_mappend - :: (Test k v, LeftReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_stripPrefix_mappend m1 m2 = QC.property $ - all - (\r -> m1 <> r == m2) - (stripPrefix m1 m2) - & cover 1 - (isJust (stripPrefix m1 m2)) - "isJust (stripPrefix m1 m2)" diff --git a/src/test/Data/MonoidMap/SingletonSpec.hs b/src/test/Data/MonoidMap/SingletonSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/SingletonSpec.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.SingletonSpec - ( spec - ) where - -import Prelude - -import Data.Function - ( (&) ) -import Data.MonoidMap - ( nonNullCount ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Property, cover, (===) ) - -import Control.Monad - ( forM_ ) -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Singletons" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_singleton_get" $ - prop_singleton_get - @k @v & property - it "prop_singleton_nonNullKey" $ - prop_singleton_nonNullKey - @k @v & property - it "prop_singleton_nonNullKeys" $ - prop_singleton_nonNullKeys - @k @v & property - it "prop_singleton_null" $ - prop_singleton_null - @k @v & property - it "prop_singleton_nullify" $ - prop_singleton_nullify - @k @v & property - it "prop_singleton_nonNullCount" $ - prop_singleton_nonNullCount - @k @v & property - it "prop_singleton_toList" $ - prop_singleton_toList - @k @v & property - -prop_singleton_get - :: Test k v => k -> v -> Property -prop_singleton_get k v = - MonoidMap.get k (MonoidMap.singleton k v) === v - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_nonNullKey - :: Test k v => k -> v -> Property -prop_singleton_nonNullKey k v = - MonoidMap.nonNullKey k (MonoidMap.singleton k v) === (v /= mempty) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_nonNullKeys - :: Test k v => k -> v -> Property -prop_singleton_nonNullKeys k v = - MonoidMap.nonNullKeys (MonoidMap.singleton k v) === - (if v == mempty then Set.empty else Set.singleton k) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_null - :: Test k v => k -> v -> Property -prop_singleton_null k v = - MonoidMap.null (MonoidMap.singleton k v) === (v == mempty) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_nullify - :: Test k v => k -> v -> Property -prop_singleton_nullify k v = - MonoidMap.nullify k (MonoidMap.singleton k v) === mempty - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_nonNullCount - :: Test k v => k -> v -> Property -prop_singleton_nonNullCount k v = - nonNullCount (MonoidMap.singleton k v) === - (if v == mempty then 0 else 1) - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" - -prop_singleton_toList - :: Test k v => k -> v -> Property -prop_singleton_toList k v = - MonoidMap.toList (MonoidMap.singleton k v) === - [(k, v) | v /= mempty] - & cover 2 - (v == mempty) - "v == mempty" - & cover 2 - (v /= mempty) - "v /= mempty" diff --git a/src/test/Data/MonoidMap/SliceSpec.hs b/src/test/Data/MonoidMap/SliceSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/SliceSpec.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.SliceSpec - ( spec - , Slice (..) - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Bifunctor - ( Bifunctor (bimap) ) -import Data.Function - ( (&) ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.MonoidMap - ( MonoidMap, nonNullCount ) -import Data.Proxy - ( Proxy (..) ) -import GHC.Exts - ( IsList (..) ) -import Test.Common - ( Key, Test, TestType (TestType), makeSpec, property, testTypesMonoidNull ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Arbitrary (..), Gen, Property, choose, cover, oneof, (===) ) - -import qualified Data.MonoidMap as MonoidMap - -spec :: Spec -spec = describe "Slicing" $ do - - forM_ testTypesMonoidNull $ \(TestType p) -> specFor (Proxy @Key) p - -specFor :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - - it "prop_take_toList_fromList" $ - prop_take_toList_fromList - @k @v & property - it "prop_drop_toList_fromList" $ - prop_drop_toList_fromList - @k @v & property - it "prop_splitAt_toList_fromList" $ - prop_splitAt_toList_fromList - @k @v & property - -data Slice k v = Slice Int (MonoidMap k v) - deriving (Eq, Show) - -instance (Arbitrary k, Arbitrary v, MonoidNull v, Ord k) => - Arbitrary (Slice k v) - where - arbitrary = do - m <- genMap - i <- genIndex m - pure $ Slice i m - where - genMap :: Gen (MonoidMap k v) - genMap = arbitrary - - genIndex :: MonoidMap k v -> Gen Int - genIndex m = oneof - [ choose (negate (length m), -1) - , pure 0 - , choose (1, length m - 1) - , pure (length m) - , choose (length m + 1, 2 * length m) - ] - -prop_take_toList_fromList - :: Test k v => Slice k v -> Property -prop_take_toList_fromList (Slice i m) = - MonoidMap.take i m - === (fromList . Prelude.take i . toList) m - & cover 2 - (i == 0 && 0 < nonNullCount m) - "i == 0 && 0 < nonNullCount m" - & cover 2 - (0 < i && i < nonNullCount m) - "0 < i && i < nonNullCount m" - & cover 2 - (0 < nonNullCount m && nonNullCount m == i) - "0 < nonNullCount m && nonNullCount m == i" - & cover 2 - (0 < nonNullCount m && nonNullCount m < i) - "0 < nonNullCount m && nonNullCount m < i" - -prop_drop_toList_fromList - :: Test k v => Slice k v -> Property -prop_drop_toList_fromList (Slice i m) = - MonoidMap.drop i m - === (fromList . Prelude.drop i . toList) m - & cover 2 - (i == 0 && 0 < nonNullCount m) - "i == 0 && 0 < nonNullCount m" - & cover 2 - (0 < i && i < nonNullCount m) - "0 < i && i < nonNullCount m" - & cover 2 - (0 < nonNullCount m && nonNullCount m == i) - "0 < nonNullCount m && nonNullCount m == i" - & cover 2 - (0 < nonNullCount m && nonNullCount m < i) - "0 < nonNullCount m && nonNullCount m < i" - -prop_splitAt_toList_fromList - :: Test k v => Slice k v -> Property -prop_splitAt_toList_fromList (Slice i m) = - MonoidMap.splitAt i m - === (bimap fromList fromList . Prelude.splitAt i . toList) m - & cover 2 - (i == 0 && 0 < nonNullCount m) - "i == 0 && 0 < nonNullCount m" - & cover 2 - (0 < i && i < nonNullCount m) - "0 < i && i < nonNullCount m" - & cover 2 - (0 < nonNullCount m && nonNullCount m == i) - "0 < nonNullCount m && nonNullCount m == i" - & cover 2 - (0 < nonNullCount m && nonNullCount m < i) - "0 < nonNullCount m && nonNullCount m < i" diff --git a/src/test/Data/MonoidMap/SuffixSpec.hs b/src/test/Data/MonoidMap/SuffixSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/SuffixSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.SuffixSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Maybe - ( isJust ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Data.Semigroup.Cancellative - ( RightReductive (..) ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesRightReductive - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Property, cover, (===) ) - -import qualified Test.QuickCheck as QC - -spec :: Spec -spec = describe "Suffixes" $ do - - forM_ testTypesRightReductive $ - \(TestType p) -> specFor (Proxy @Key) p - -specFor - :: forall k v. (Test k v, RightReductive v) => Proxy k -> Proxy v -> Spec -specFor = makeSpec $ do - it "prop_stripSuffix_isJust" $ - prop_stripSuffix_isJust - @k @v & property - it "prop_stripSuffix_mappend" $ - prop_stripSuffix_mappend - @k @v & property - -prop_stripSuffix_isJust - :: (Test k v, RightReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_stripSuffix_isJust m1 m2 = - isJust (stripSuffix m1 m2) === m1 `isSuffixOf` m2 - & cover 1 - (m1 `isSuffixOf` m2) - "m1 `isSuffixOf` m2" - -prop_stripSuffix_mappend - :: (Test k v, RightReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_stripSuffix_mappend m1 m2 = QC.property $ - all - (\r -> r <> m1 == m2) - (stripSuffix m1 m2) - & cover 1 - (isJust (stripSuffix m1 m2)) - "isJust (stripSuffix m1 m2)" diff --git a/src/test/Data/MonoidMap/TraversalSpec.hs b/src/test/Data/MonoidMap/TraversalSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/TraversalSpec.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# 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/Data/MonoidMap/UnionSpec.hs b/src/test/Data/MonoidMap/UnionSpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/UnionSpec.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.UnionSpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Function - ( (&) ) -import Data.Functor.Identity - ( Identity (..) ) -import Data.Monoid.LCM - ( LCMMonoid ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (..) ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesLCMMonoid - , testTypesMonoidNull - ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Fun (..), Property, applyFun2, conjoin, cover, expectFailure, (===) ) - -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Set as Set - -spec :: Spec -spec = describe "Union" $ do - - forM_ testTypesMonoidNull $ - \(TestType p) -> specMonoidNull - (Proxy @Key) p - forM_ testTypesLCMMonoid $ - \(TestType p) -> specLCMMonoid - (Proxy @Key) p - -specMonoidNull :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specMonoidNull = makeSpec $ do - it "prop_unionWith_get" $ - prop_unionWith_get - @k @v & property - it "prop_unionWith_get_total" $ - prop_unionWith_get_total - @k @v & property - it "prop_unionWith_get_total_failure" $ - prop_unionWith_get_total_failure - @k @v & property - it "prop_unionWith_unionWithA" $ - prop_unionWith_unionWithA - @k @v & property - -specLCMMonoid - :: forall k v. (Test k v, LCMMonoid v) => Proxy k -> Proxy v -> Spec -specLCMMonoid = makeSpec $ do - it "prop_union_isSubmapOf" $ - prop_union_isSubmapOf - @k @v & property - -prop_union_isSubmapOf - :: (Test k v, LCMMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -prop_union_isSubmapOf m1 m2 = conjoin - [ m1 `MonoidMap.isSubmapOf` union_m1_m2 - , m2 `MonoidMap.isSubmapOf` union_m1_m2 - ] - & cover 2 - (m1 /= m2 && MonoidMap.nonNull (union_m1_m2)) - "m1 /= m2 && MonoidMap.nonNull (union_m1_m2)" - where - union_m1_m2 = MonoidMap.union m1 m2 - -prop_unionWith_get - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_unionWith_get (applyFun2 -> f) m1 m2 k = - (MonoidMap.get k result - === - if keyWithinUnion - then f (MonoidMap.get k m1) (MonoidMap.get k m2) - else mempty) - & cover 2 - (keyWithinUnion) - "keyWithinUnion" - & cover 2 - (not keyWithinUnion) - "not keyWithinUnion" - & cover 2 - (MonoidMap.null result) - "MonoidMap.null result" - & cover 2 - (MonoidMap.nonNull result) - "MonoidMap.nonNull result)" - & cover 2 - (MonoidMap.nullKey k result) - "MonoidMap.nullKey k result" - & cover 2 - (MonoidMap.nonNullKey k result) - "MonoidMap.nonNullKey k result" - where - keyWithinUnion = - k `Set.member` Set.union - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - result = - MonoidMap.unionWith f m1 m2 - -prop_unionWith_get_total - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_unionWith_get_total (applyFun2 -> f0) m1 m2 k = - (MonoidMap.get k result - === - f (MonoidMap.get k m1) (MonoidMap.get k m2)) - & cover 2 - (keyWithinUnion) - "keyWithinUnion" - & cover 2 - (not keyWithinUnion) - "not keyWithinUnion" - & cover 2 - (MonoidMap.null result) - "MonoidMap.null result" - & cover 2 - (MonoidMap.nonNull result) - "MonoidMap.nonNull result)" - & cover 2 - (MonoidMap.nullKey k result) - "MonoidMap.nullKey k result" - & cover 2 - (MonoidMap.nonNullKey k result) - "MonoidMap.nonNullKey k result" - where - keyWithinUnion = - k `Set.member` Set.union - (MonoidMap.nonNullKeys m1) - (MonoidMap.nonNullKeys m2) - result = - MonoidMap.unionWith f m1 m2 - f v1 v2 - | Null.null v1 && Null.null v2 = mempty - | otherwise = f0 v1 v2 - -prop_unionWith_get_total_failure - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> k - -> Property -prop_unionWith_get_total_failure (applyFun2 -> f) m1 m2 k = - expectFailure $ - MonoidMap.get k (MonoidMap.unionWith f m1 m2) - === - f (MonoidMap.get k m1) (MonoidMap.get k m2) - -prop_unionWith_unionWithA - :: Test k v - => Fun (v, v) v - -> MonoidMap k v - -> MonoidMap k v - -> Property -prop_unionWith_unionWithA (applyFun2 -> f) m1 m2 = - runIdentity (MonoidMap.unionWithA ((fmap . fmap) Identity f) m1 m2) - === (MonoidMap.unionWith f m1 m2) diff --git a/src/test/Data/MonoidMap/ValiditySpec.hs b/src/test/Data/MonoidMap/ValiditySpec.hs deleted file mode 100644 --- a/src/test/Data/MonoidMap/ValiditySpec.hs +++ /dev/null @@ -1,734 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Data.MonoidMap.ValiditySpec - ( spec - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Data - ( Proxy (Proxy) ) -import Data.Function - ( (&) ) -import Data.Functor.Identity - ( Identity ) -import Data.Group - ( Group ) -import Data.Map.Strict - ( Map ) -import Data.Maybe - ( isJust ) -import Data.Monoid.Cancellative - ( GCDMonoid - , LeftGCDMonoid - , LeftReductive - , OverlappingGCDMonoid - , Reductive - , RightGCDMonoid - , RightReductive - ) -import Data.Monoid.LCM - ( LCMMonoid ) -import Data.Monoid.Monus - ( Monus ) -import Data.MonoidMap - ( MonoidMap ) -import Data.MonoidMap.SliceSpec - ( Slice (..) ) -import Data.Set - ( Set ) -import Test.Common - ( Key - , Test - , TestType (TestType) - , makeSpec - , property - , testTypesGCDMonoid - , testTypesGroup - , testTypesLCMMonoid - , testTypesLeftGCDMonoid - , testTypesLeftReductive - , testTypesMonoidNull - , testTypesMonus - , testTypesOverlappingGCDMonoid - , testTypesReductive - , testTypesRightGCDMonoid - , testTypesRightReductive - ) -import Test.Hspec - ( Spec, it ) -import Test.QuickCheck - ( Fun - , Property - , applyFun - , applyFun2 - , applyFun3 - , conjoin - , counterexample - , cover - ) - -import qualified Data.Foldable as F -import qualified Data.Map.Strict as Map -import qualified Data.Monoid.Null as Null -import qualified Data.MonoidMap as MonoidMap - -spec :: Spec -spec = do - specForAll - testTypesMonoidNull - specValidMonoidNull - specForAll - testTypesLeftReductive - specValidLeftReductive - specForAll - testTypesRightReductive - specValidRightReductive - specForAll - testTypesReductive - specValidReductive - specForAll - testTypesLeftGCDMonoid - specValidLeftGCDMonoid - specForAll - testTypesRightGCDMonoid - specValidRightGCDMonoid - specForAll - testTypesOverlappingGCDMonoid - specValidOverlappingGCDMonoid - specForAll - testTypesGCDMonoid - specValidGCDMonoid - specForAll - testTypesLCMMonoid - specValidLCMMonoid - specForAll - testTypesMonus - specValidMonus - specForAll - testTypesGroup - specValidGroup - where - specForAll - :: [TestType c] - -> (forall k v. (Test k v, c v) => Proxy k -> Proxy v -> Spec) - -> Spec - specForAll testTypes specFn = forM_ testTypes (specFor specFn) - - specFor - :: (forall k v. (Test k v, c v) => Proxy k -> Proxy v -> Spec) - -> TestType c - -> Spec - specFor specFn (TestType (v :: Proxy v)) = - specFn (Proxy @Key) v - -specValidMonoidNull - :: forall k v. Test k v => Proxy k -> Proxy v -> Spec -specValidMonoidNull = makeSpec $ do - it "propValid_fromList" $ - propValid_fromList - @k @v & property - it "propValid_fromListWith" $ - propValid_fromListWith - @k @v & property - it "propValid_fromMap" $ - propValid_fromMap - @k @v & property - it "propValid_fromSet" $ - propValid_fromSet - @k @v & property - it "propValid_singleton" $ - propValid_singleton - @k @v & property - it "propValid_set" $ - propValid_set - @k @v & property - it "propValid_adjust" $ - propValid_adjust - @k @v & property - it "propValid_nullify" $ - propValid_nullify - @k @v & property - it "propValid_take" $ - propValid_take - @k @v & property - it "propValid_drop" $ - propValid_drop - @k @v & property - it "propValid_splitAt" $ - propValid_splitAt - @k @v & property - it "propValid_filter" $ - propValid_filter - @k @v & property - it "propValid_filterKeys" $ - propValid_filterKeys - @k @v & property - it "propValid_filterWithKey" $ - propValid_filterWithKey - @k @v & property - it "propValid_partition" $ - propValid_partition - @k @v & property - it "propValid_partitionKeys" $ - propValid_partitionKeys - @k @v & property - it "propValid_partitionWithKey" $ - propValid_partitionWithKey - @k @v & property - it "propValid_map" $ - propValid_map - @k @v & property - it "propValid_mapKeys" $ - propValid_mapKeys - @k @v & property - it "propValid_mapKeysWith" $ - propValid_mapKeysWith - @k @v & property - it "propValid_mapWithKey" $ - propValid_mapWithKey - @k @v & property - it "propValid_mapAccumL" $ - propValid_mapAccumL - @k @v & property - it "propValid_mapAccumR" $ - propValid_mapAccumR - @k @v & property - it "propValid_mapAccumLWithKey" $ - propValid_mapAccumLWithKey - @k @v & property - it "propValid_mapAccumRWithKey" $ - propValid_mapAccumRWithKey - @k @v & property - it "propValid_traverse" $ - propValid_traverse - @k @v & property - it "propValid_traverseWithKey" $ - propValid_traverseWithKey - @k @v & property - it "propValid_intersectionWith" $ - propValid_intersectionWith - @k @v & property - it "propValid_unionWith" $ - propValid_unionWith - @k @v & property - it "propValid_append" $ - propValid_append - @k @v & property - -specValidLeftReductive - :: forall k v. (Test k v, LeftReductive v) - => Proxy k - -> Proxy v - -> Spec -specValidLeftReductive = makeSpec $ do - it "propValid_stripPrefix" $ - propValid_stripPrefix - @k @v & property - -specValidRightReductive - :: forall k v. (Test k v, RightReductive v) - => Proxy k - -> Proxy v - -> Spec -specValidRightReductive = makeSpec $ do - it "propValid_stripSuffix" $ - propValid_stripSuffix - @k @v & property - -specValidReductive - :: forall k v. (Test k v, Reductive v) - => Proxy k - -> Proxy v - -> Spec -specValidReductive = makeSpec $ do - it "propValid_minusMaybe" $ - propValid_minusMaybe - @k @v & property - -specValidLeftGCDMonoid - :: forall k v. (Test k v, LeftGCDMonoid v) - => Proxy k - -> Proxy v - -> Spec -specValidLeftGCDMonoid = makeSpec $ do - it "propValid_commonPrefix" $ - propValid_commonPrefix - @k @v & property - it "propValid_stripCommonPrefix" $ - propValid_stripCommonPrefix - @k @v & property - -specValidRightGCDMonoid - :: forall k v. (Test k v, RightGCDMonoid v) - => Proxy k - -> Proxy v - -> Spec -specValidRightGCDMonoid = makeSpec $ do - it "propValid_commonSuffix" $ - propValid_commonSuffix - @k @v & property - it "propValid_stripCommonSuffix" $ - propValid_stripCommonSuffix - @k @v & property - -specValidOverlappingGCDMonoid - :: forall k v. (Test k v, OverlappingGCDMonoid v) - => Proxy k - -> Proxy v - -> Spec -specValidOverlappingGCDMonoid = makeSpec $ do - it "propValid_overlap" $ - propValid_overlap - @k @v & property - it "propValid_stripPrefixOverlap" $ - propValid_stripPrefixOverlap - @k @v & property - it "propValid_stripSuffixOverlap" $ - propValid_stripSuffixOverlap - @k @v & property - it "propValid_stripOverlap" $ - propValid_stripOverlap - @k @v & property - -specValidGCDMonoid - :: forall k v. (Test k v, GCDMonoid v) - => Proxy k - -> Proxy v - -> Spec -specValidGCDMonoid = makeSpec $ do - it "propValid_intersection" $ - propValid_intersection - @k @v & property - -specValidLCMMonoid - :: forall k v. (Test k v, LCMMonoid v) - => Proxy k - -> Proxy v - -> Spec -specValidLCMMonoid = makeSpec $ do - it "propValid_union" $ - propValid_union - @k @v & property - -specValidMonus - :: forall k v. (Test k v, Monus v) - => Proxy k - -> Proxy v - -> Spec -specValidMonus = makeSpec $ do - it "propValid_monus" $ - propValid_monus - @k @v & property - -specValidGroup - :: forall k v. (Test k v, Group v) - => Proxy k - -> Proxy v - -> Spec -specValidGroup = makeSpec $ do - it "propValid_minus" $ - propValid_minus - @k @v & property - it "propValid_invert" $ - propValid_invert - @k @v & property - it "propValid_power" $ - propValid_power - @k @v & property - -propValid - :: Test k v => MonoidMap k v -> Property -propValid m = conjoin - [ counterexample - "propValid_nonNullKeys" - (propValid_nonNullKeys) - , counterexample - "propValid_toList" - (propValid_toList) - ] - & cover 2 - (not (Null.null m)) - "not (Null.null m)" - where - propValid_nonNullKeys = - all (\k -> MonoidMap.get k m /= mempty) (MonoidMap.nonNullKeys m) - propValid_toList = - all (\(_, v) -> v /= mempty) (MonoidMap.toList m) - -propValid_fromList - :: Test k v => [(k, v)] -> Property -propValid_fromList kvs = - propValid (MonoidMap.fromList kvs) - & cover 2 - (filter (Null.null . snd) kvs /= []) - "filter (Null.null . snd) kvs /= []" - -propValid_fromListWith - :: Test k v => Fun (v, v) v -> [(k, v)] -> Property -propValid_fromListWith (applyFun2 -> f) kvs = - propValid (MonoidMap.fromListWith f kvs) - & cover 2 - (filter (Null.null . snd) kvs /= []) - "filter (Null.null . snd) kvs /= []" - -propValid_fromMap - :: Test k v => Map k v -> Property -propValid_fromMap m = - propValid (MonoidMap.fromMap m) - & cover 2 - (Map.filter Null.null m /= mempty) - "Map.filter Null.null m /= mempty" - -propValid_fromSet - :: Test k v => Fun k v -> Set k -> Property -propValid_fromSet (applyFun -> f) ks = - propValid (MonoidMap.fromSet f ks) - & cover 2 - (Map.filter Null.null (Map.fromSet f ks) /= mempty) - "Map.filter Null.null (Map.fromSet f ks) /= mempty" - -propValid_singleton - :: Test k v => k -> v -> Property -propValid_singleton k v = - propValid (MonoidMap.singleton k v) - & cover 2 - (Null.null v) - "Null.null v" - -propValid_set - :: Test k v => k -> v -> MonoidMap k v -> Property -propValid_set k v m = - propValid (MonoidMap.set k v m) - & cover 2 - (Null.null v) - "Null.null v" - -propValid_adjust - :: Test k v => Fun v v -> k -> MonoidMap k v -> Property -propValid_adjust (applyFun -> f) k m = - propValid (MonoidMap.adjust f k m) - & cover 1 - (Null.null (f (MonoidMap.get k m))) - "Null.null (f (MonoidMap.get k m))" - -propValid_nullify - :: Test k v => k -> MonoidMap k v -> Property -propValid_nullify k m = - propValid (MonoidMap.nullify k m) - & cover 2 - (MonoidMap.nonNullKey k m) - "MonoidMap.nonNullKey k m" - -propValid_take - :: Test k v => Slice k v -> Property -propValid_take (Slice i m) = - propValid (MonoidMap.take i m) - -propValid_drop - :: Test k v => Slice k v -> Property -propValid_drop (Slice i m) = - propValid (MonoidMap.drop i m) - -propValid_splitAt - :: Test k v => Slice k v -> Property -propValid_splitAt (Slice i m) = - conjoin - [ counterexample "propValid m1" (propValid m1) - , counterexample "propValid m2" (propValid m2) - ] - where - (m1, m2) = MonoidMap.splitAt i m - -propValid_filter - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -propValid_filter (applyFun -> f) m = - propValid (MonoidMap.filter f m) - -propValid_filterKeys - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -propValid_filterKeys (applyFun -> f) m = - propValid (MonoidMap.filterKeys f m) - -propValid_filterWithKey - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -propValid_filterWithKey (applyFun2 -> f) m = - propValid (MonoidMap.filterWithKey f m) - -propValid_partition - :: Test k v => Fun v Bool -> MonoidMap k v -> Property -propValid_partition (applyFun -> f) m = - conjoin - [ counterexample "propValid m1" (propValid m1) - , counterexample "propValid m2" (propValid m2) - ] - where - (m1, m2) = MonoidMap.partition f m - -propValid_partitionKeys - :: Test k v => Fun k Bool -> MonoidMap k v -> Property -propValid_partitionKeys (applyFun -> f) m = - conjoin - [ counterexample "propValid m1" (propValid m1) - , counterexample "propValid m2" (propValid m2) - ] - where - (m1, m2) = MonoidMap.partitionKeys f m - -propValid_partitionWithKey - :: Test k v => Fun (k, v) Bool -> MonoidMap k v -> Property -propValid_partitionWithKey (applyFun2 -> f) m = - conjoin - [ counterexample "propValid m1" (propValid m1) - , counterexample "propValid m2" (propValid m2) - ] - where - (m1, m2) = MonoidMap.partitionWithKey f m - -propValid_map - :: Test k v => Fun v v -> MonoidMap k v -> Property -propValid_map (applyFun -> f) m = - propValid (MonoidMap.map f m) - -propValid_mapKeys - :: Test k v => Fun k k -> MonoidMap k v -> Property -propValid_mapKeys (applyFun -> f) m = - propValid (MonoidMap.mapKeys f m) - -propValid_mapKeysWith - :: Test k v => Fun (v, v) v -> Fun k k -> MonoidMap k v -> Property -propValid_mapKeysWith (applyFun2 -> f) (applyFun -> g) m = - propValid (MonoidMap.mapKeysWith f g m) - -propValid_mapWithKey - :: Test k v => Fun (k, v) v -> MonoidMap k v -> Property -propValid_mapWithKey (applyFun2 -> f) m = - propValid (MonoidMap.mapWithKey f m) - -propValid_mapAccumL - :: forall k v s. s ~ Int - => Test k v - => Fun (s, v) (s, v) - -> s - -> MonoidMap k v - -> Property -propValid_mapAccumL (applyFun2 -> f) s m = - propValid $ snd $ MonoidMap.mapAccumL f s m - -propValid_mapAccumR - :: forall k v s. s ~ Int - => Test k v - => Fun (s, v) (s, v) - -> s - -> MonoidMap k v - -> Property -propValid_mapAccumR (applyFun2 -> f) s m = - propValid $ snd $ MonoidMap.mapAccumR f s m - -propValid_mapAccumLWithKey - :: forall k v s. s ~ Int - => Test k v - => Fun (s, k, v) (s, v) - -> s - -> MonoidMap k v - -> Property -propValid_mapAccumLWithKey (applyFun3 -> f) s m = - propValid $ snd $ MonoidMap.mapAccumLWithKey f s m - -propValid_mapAccumRWithKey - :: forall k v s. s ~ Int - => Test k v - => Fun (s, k, v) (s, v) - -> s - -> MonoidMap k v - -> Property -propValid_mapAccumRWithKey (applyFun3 -> f) s m = - propValid $ snd $ MonoidMap.mapAccumRWithKey f s m - -propValid_traverse - :: forall k v t. (Applicative t, Foldable t, Test k v) - => t ~ Identity - => Fun v (t v) - -> MonoidMap k v - -> Property -propValid_traverse (applyFun -> f) m - = conjoin - $ fmap propValid - $ F.toList @t - $ MonoidMap.traverse f m - -propValid_traverseWithKey - :: forall k v t. (Applicative t, Foldable t, Test k v) - => t ~ Identity - => Fun (k, v) (t v) - -> MonoidMap k v - -> Property -propValid_traverseWithKey (applyFun2 -> f) m - = conjoin - $ fmap propValid - $ F.toList @t - $ MonoidMap.traverseWithKey f m - -propValid_intersection - :: (Test k v, GCDMonoid v) => MonoidMap k v -> MonoidMap k v -> Property -propValid_intersection m1 m2 = - propValid (MonoidMap.intersection m1 m2) - -propValid_intersectionWith - :: Test k v => Fun (v, v) v -> MonoidMap k v -> MonoidMap k v -> Property -propValid_intersectionWith (applyFun2 -> f) m1 m2 = - propValid (MonoidMap.intersectionWith f m1 m2) - -propValid_union - :: (Test k v, LCMMonoid v) => MonoidMap k v -> MonoidMap k v -> Property -propValid_union m1 m2 = - propValid (MonoidMap.union m1 m2) - -propValid_unionWith - :: Test k v => Fun (v, v) v -> MonoidMap k v -> MonoidMap k v -> Property -propValid_unionWith (applyFun2 -> f) m1 m2 = - propValid (MonoidMap.unionWith f m1 m2) - -propValid_append - :: Test k v => MonoidMap k v -> MonoidMap k v -> Property -propValid_append m1 m2 = - propValid (MonoidMap.append m1 m2) - -propValid_minus - :: (Test k v, Group v) => MonoidMap k v -> MonoidMap k v -> Property -propValid_minus m1 m2 = - propValid (MonoidMap.minus m1 m2) - -propValid_minusMaybe - :: (Test k v, Reductive v) => MonoidMap k v -> MonoidMap k v -> Property -propValid_minusMaybe m1 m2 = - maybe (property True) propValid mr - & cover 2 (isJust mr) "isJust mr" - where - mr = MonoidMap.minusMaybe m1 m2 - -propValid_monus - :: (Test k v, Monus v) => MonoidMap k v -> MonoidMap k v -> Property -propValid_monus m1 m2 = - propValid (MonoidMap.monus m1 m2) - -propValid_invert - :: (Test k v, Group v) => MonoidMap k v -> Property -propValid_invert m = - propValid (MonoidMap.invert m) - -propValid_power - :: (Test k v, Group v) => MonoidMap k v -> Int -> Property -propValid_power m i = - propValid (MonoidMap.power m i) - -propValid_commonPrefix - :: (Test k v, LeftGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_commonPrefix m1 m2 = - propValid (MonoidMap.commonPrefix m1 m2) - -propValid_commonSuffix - :: (Test k v, RightGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_commonSuffix m1 m2 = - propValid (MonoidMap.commonSuffix m1 m2) - -propValid_stripPrefix - :: (Test k v, LeftReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripPrefix m1 m2 = - maybe (property True) propValid mr - & cover 2 (isJust mr) "isJust mr" - where - mr = MonoidMap.stripPrefix m1 m2 - -propValid_stripSuffix - :: (Test k v, RightReductive v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripSuffix m1 m2 = - maybe (property True) propValid mr - & cover 2 (isJust mr) "isJust mr" - where - mr = MonoidMap.stripSuffix m1 m2 - -propValid_stripCommonPrefix - :: (Test k v, LeftGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripCommonPrefix m1 m2 = - conjoin - [ counterexample "propValid r1" (propValid r1) - , counterexample "propValid r2" (propValid r2) - , counterexample "propValid r3" (propValid r3) - ] - where - (r1, r2, r3) = MonoidMap.stripCommonPrefix m1 m2 - -propValid_stripCommonSuffix - :: (Test k v, RightGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripCommonSuffix m1 m2 = - conjoin - [ counterexample "propValid r1" (propValid r1) - , counterexample "propValid r2" (propValid r2) - , counterexample "propValid r3" (propValid r3) - ] - where - (r1, r2, r3) = MonoidMap.stripCommonSuffix m1 m2 - -propValid_overlap - :: (Test k v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_overlap m1 m2 = - propValid (MonoidMap.overlap m1 m2) - -propValid_stripPrefixOverlap - :: (Test k v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripPrefixOverlap m1 m2 = - propValid (MonoidMap.stripPrefixOverlap m1 m2) - -propValid_stripSuffixOverlap - :: (Test k v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripSuffixOverlap m1 m2 = - propValid (MonoidMap.stripSuffixOverlap m1 m2) - -propValid_stripOverlap - :: (Test k v, OverlappingGCDMonoid v) - => MonoidMap k v - -> MonoidMap k v - -> Property -propValid_stripOverlap m1 m2 = - conjoin - [ counterexample "propValid r1" (propValid r1) - , counterexample "propValid r2" (propValid r2) - , counterexample "propValid r3" (propValid r3) - ] - where - (r1, r2, r3) = MonoidMap.stripOverlap m1 m2 diff --git a/src/test/Examples/MultiMapSpec.hs b/src/test/Examples/MultiMapSpec.hs deleted file mode 100644 --- a/src/test/Examples/MultiMapSpec.hs +++ /dev/null @@ -1,732 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use any" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Examples.MultiMapSpec - where - -import Prelude - -import Data.Function - ( (&) ) -import Data.Maybe - ( isJust, isNothing ) -import Data.Proxy - ( Proxy (..) ) -import Data.Set - ( Set ) -import Data.Typeable - ( Typeable, typeRep ) -import Examples.MultiMap.Class - ( MultiMap ) -import Examples.MultiMap.Instances.MultiMap1 - ( MultiMap1 ) -import Examples.MultiMap.Instances.MultiMap2 - ( MultiMap2 ) -import Examples.MultiMap.Instances.MultiMap3 - ( MultiMap3 ) -import Examples.MultiMap.Instances.MultiMap4 - ( MultiMap4 ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Arbitrary (..) - , Property - , Testable - , checkCoverage - , counterexample - , cover - , (.||.) - , (===) - ) -import Test.QuickCheck.Instances.Natural - () -import Test.QuickCheck.Instances.Text - () - -import qualified Data.Foldable as F -import qualified Data.Set as Set -import qualified Examples.MultiMap.Class as M -import qualified Test.QuickCheck as QC - -spec :: Spec -spec = do - - -- Uncomment the following line to see property test failures for an - -- unlawful implementation of 'MultiMap': - -- - -- specFor (Proxy @(MultiMap1 Int Int)) - - specFor (Proxy @(MultiMap2 Int Int)) - specFor (Proxy @(MultiMap3 Int Int)) - specFor (Proxy @(MultiMap4 Int Int)) - -type Test m k v = - ( Arbitrary k - , Arbitrary v - , MultiMap m k v - , Show (m k v) - , Show k - , Show v - , Typeable m - , Typeable k - , Typeable v - ) - -specFor :: forall m k v. Test m k v => Proxy (m k v) -> Spec -specFor multimapType = do - - let description = show (typeRep multimapType) - - let property :: Testable t => t -> Property - property = checkCoverage . QC.property - - describe description $ do - - describe "Validity properties" $ do - - it "prop_fromList_valid" $ - prop_fromList_valid - @m @k @v & property - it "prop_update_valid" $ - prop_update_valid - @m @k @v & property - it "prop_insert_valid" $ - prop_insert_valid - @m @k @v & property - it "prop_remove_valid" $ - prop_remove_valid - @m @k @v & property - it "prop_union_valid" $ - prop_union_valid - @m @k @v & property - it "prop_intersection_valid" $ - prop_intersection_valid - @m @k @v & property - - describe "General properties" $ do - - it "prop_fromList_filter" $ - prop_fromList_filter - @m @k @v & property - it "prop_toList_filter" $ - prop_toList_filter - @m @k @v & property - it "prop_empty_fromList" $ - prop_empty_fromList - @m @k @v & property - it "prop_lookup_filter_fold" $ - prop_lookup_filter_fold - @m @k @v & property - it "prop_null_lookup" $ - prop_null_lookup - @m @k @v & property - it "prop_nonNull_lookup" $ - prop_nonNull_lookup - @m @k @v & property - it "prop_nonNullKey_lookup" $ - prop_nonNullKey_lookup - @m @k @v & property - it "prop_nonNullKeys_nonNullKey" $ - prop_nonNullKeys_nonNullKey - @m @k @v & property - it "prop_nonNullCount_nonNullKeys" $ - prop_nonNullCount_nonNullKeys - @m @k @v & property - it "prop_isSubmapOf_lookup" $ - prop_isSubmapOf_lookup - @m @k @v & property - it "prop_update_lookup" $ - prop_update_lookup - @m @k @v & property - it "prop_insert_lookup" $ - prop_insert_lookup - @m @k @v & property - it "prop_remove_lookup" $ - prop_remove_lookup - @m @k @v & property - it "prop_union_idempotence" $ - prop_union_idempotence - @m @k @v & property - it "prop_union_identity_left" $ - prop_union_identity_left - @m @k @v & property - it "prop_union_identity_right" $ - prop_union_identity_right - @m @k @v & property - it "prop_union_commutativity" $ - prop_union_commutativity - @m @k @v & property - it "prop_union_associativity" $ - prop_union_associativity - @m @k @v & property - it "prop_union_containment_left" $ - prop_union_containment_left - @m @k @v & property - it "prop_union_containment_right" $ - prop_union_containment_right - @m @k @v & property - it "prop_union_distributivity" $ - prop_union_distributivity - @m @k @v & property - it "prop_intersection_idempotence" $ - prop_intersection_idempotence - @m @k @v & property - it "prop_intersection_identity_left" $ - prop_intersection_identity_left - @m @k @v & property - it "prop_intersection_identity_right" $ - prop_intersection_identity_right - @m @k @v & property - it "prop_intersection_commutativity" $ - prop_intersection_commutativity - @m @k @v & property - it "prop_intersection_associativity" $ - prop_intersection_associativity - @m @k @v & property - it "prop_intersection_containment_left" $ - prop_intersection_containment_left - @m @k @v & property - it "prop_intersection_containment_right" $ - prop_intersection_containment_right - @m @k @v & property - it "prop_intersection_distributivity" $ - prop_intersection_distributivity - @m @k @v & property - --------------------------------------------------------------------------------- --- Validity properties --------------------------------------------------------------------------------- - --- A multimap is valid if (and only if): --- --- - all keys included in 'nonNullKeys' are associated with non-empty sets. --- - all keys included in 'toList' are associated with non-empty sets. - -prop_valid - :: Test m k v => m k v -> Property -prop_valid m = QC.conjoin - [ counterexample - "prop_valid_nonNullKeys" - (prop_valid_nonNullKeys) - , counterexample - "prop_valid_toList" - (prop_valid_toList) - ] - & cover 1 - (M.null m) - "M.null m" - & cover 1 - (M.nonNull m) - "M.nonNull m" - where - prop_valid_nonNullKeys = - all (\k -> M.lookup k m /= Set.empty) (M.nonNullKeys m) - prop_valid_toList = - all (\(_, v) -> v /= Set.empty) (M.toList m) - --------------------------------------------------------------------------------- --- Validity of operations that produce multimaps --------------------------------------------------------------------------------- - -prop_fromList_valid - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_fromList_valid kvs = - prop_valid @m @k @v (M.fromList kvs) - -prop_update_valid - :: forall m k v. Test m k v - => k - -> Set v - -> [(k, Set v)] - -> Property -prop_update_valid k vs kvs = - prop_valid @m @k @v (M.update k vs (M.fromList kvs)) - -prop_insert_valid - :: forall m k v. Test m k v - => k - -> Set v - -> [(k, Set v)] - -> Property -prop_insert_valid k vs kvs = - prop_valid @m @k @v (M.insert k vs (M.fromList kvs)) - -prop_remove_valid - :: forall m k v. Test m k v - => k - -> Set v - -> [(k, Set v)] - -> Property -prop_remove_valid k vs kvs = - prop_valid @m @k @v (M.remove k vs (M.fromList kvs)) - -prop_union_valid - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_valid kvs1 kvs2 = - prop_valid @m @k @v (M.union (M.fromList kvs1) (M.fromList kvs2)) - -prop_intersection_valid - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_valid kvs1 kvs2 = - prop_valid @m @k @v (M.intersection (M.fromList kvs1) (M.fromList kvs2)) - --------------------------------------------------------------------------------- --- General properties --------------------------------------------------------------------------------- - -prop_fromList_filter - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_fromList_filter kvs = - M.fromList @m @k @v kvs === M.fromList (filter ((/= Set.empty) . snd) kvs) - -prop_toList_filter - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_toList_filter kvs = - M.toList m === filter ((/= Set.empty) . snd) (M.toList m) - where - m :: m k v - m = M.fromList kvs - -prop_empty_fromList - :: forall m k v. Test m k v - => Property -prop_empty_fromList = - M.empty @m @k @v === M.fromList [] - -prop_lookup_filter_fold - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> Property -prop_lookup_filter_fold k kvs = - M.lookup k m === F.foldMap snd (filter ((== k) . fst) kvs) - & cover 10 - (isJust (lookup k kvs)) - "isJust (lookup k kvs)" - & cover 10 - (isNothing (lookup k kvs)) - "isNothing (lookup k kvs)" - where - m :: m k v - m = M.fromList kvs - -prop_null_lookup - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> Property -prop_null_lookup k kvs = - M.null m ==> M.lookup k m == Set.empty - & cover 2 - (M.lookup k m == Set.empty && M.null m) - "M.lookup k m == Set.empty && M.null m" - & cover 2 - (M.lookup k m == Set.empty && M.nonNull m) - "M.lookup k m == Set.empty && M.nonNull m" - & cover 2 - (M.lookup k m /= Set.empty && M.nonNull m) - "M.lookup k m /= Set.empty && M.nonNull m" - where - m :: m k v - m = M.fromList kvs - -prop_nonNull_lookup - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> Property -prop_nonNull_lookup k kvs = - M.lookup k m /= Set.empty ==> M.nonNull m - & cover 2 - (M.lookup k m == Set.empty && M.null m) - "M.lookup k m == Set.empty && M.null m" - & cover 2 - (M.lookup k m == Set.empty && M.nonNull m) - "M.lookup k m == Set.empty && M.nonNull m" - & cover 2 - (M.lookup k m /= Set.empty && M.nonNull m) - "M.lookup k m /= Set.empty && M.nonNull m" - where - m :: m k v - m = M.fromList kvs - -prop_nonNullKey_lookup - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> Property -prop_nonNullKey_lookup k kvs = - M.nonNullKey k m === (M.lookup k m /= Set.empty) - & cover 2 - (M.lookup k m == Set.empty && M.null m) - "M.lookup k m == Set.empty && M.null m" - & cover 2 - (M.lookup k m == Set.empty && M.nonNull m) - "M.lookup k m == Set.empty && M.nonNull m" - & cover 2 - (M.lookup k m /= Set.empty && M.nonNull m) - "M.lookup k m /= Set.empty && M.nonNull m" - where - m :: m k v - m = M.fromList kvs - -prop_nonNullKeys_nonNullKey - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_nonNullKeys_nonNullKey kvs = QC.property $ - all (`M.nonNullKey` m) (M.nonNullKeys m) - & cover 2 - (M.null m) - "M.null m" - & cover 2 - (M.nonNull m) - "M.nonNull m" - where - m :: m k v - m = M.fromList kvs - -prop_nonNullCount_nonNullKeys - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_nonNullCount_nonNullKeys kvs = - M.nonNullCount m === Set.size (M.nonNullKeys m) - & cover 1 - (M.nonNullCount m == 0) - "M.nonNullCount m == 0" - & cover 1 - (M.nonNullCount m == 1) - "M.nonNullCount m == 1" - & cover 1 - (M.nonNullCount m == 2) - "M.nonNullCount m == 2" - & cover 1 - (M.nonNullCount m >= 3) - "M.nonNullCount m >= 3" - where - m :: m k v - m = M.fromList kvs - -prop_isSubmapOf_lookup - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_isSubmapOf_lookup k kvs1 kvs2 = - m1 `M.isSubmapOf` m2 - ==> - M.lookup k m1 `Set.isSubsetOf` M.lookup k m2 - & cover 1 - (m1 `M.isSubmapOf` m2) - "m1 `M.isSubmapOf` m2" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_update_lookup - :: forall m k v. Test m k v - => k - -> k - -> Set v - -> [(k, Set v)] - -> Property -prop_update_lookup k1 k2 vs kvs = - M.lookup k1 (M.update k2 vs m) === (if k1 == k2 then vs else M.lookup k1 m) - & cover 1 - (k1 == k2) - "k1 == k2" - & cover 10 - (k1 /= k2) - "k1 /= k2" - where - m :: m k v - m = M.fromList kvs - -prop_insert_lookup - :: forall m k v. Test m k v - => k - -> k - -> Set v - -> [(k, Set v)] - -> Property -prop_insert_lookup k1 k2 vs kvs = - M.lookup k1 (M.insert k2 vs m) === - (if k1 == k2 then M.lookup k1 m `Set.union` vs else M.lookup k1 m) - & cover 1 - (k1 == k2) - "k1 == k2" - & cover 10 - (k1 /= k2) - "k1 /= k2" - where - m :: m k v - m = M.fromList kvs - -prop_remove_lookup - :: forall m k v. Test m k v - => k - -> k - -> Set v - -> [(k, Set v)] - -> Property -prop_remove_lookup k1 k2 vs kvs = - M.lookup k1 (M.remove k2 vs m) === - (if k1 == k2 then M.lookup k1 m `Set.difference` vs else M.lookup k1 m) - & cover 1 - (k1 == k2) - "k1 == k2" - & cover 10 - (k1 /= k2) - "k1 /= k2" - where - m :: m k v - m = M.fromList kvs - -prop_union_idempotence - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_union_idempotence kvs = - M.union m m === m - where - m :: m k v - m = M.fromList kvs - -prop_union_identity_left - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_union_identity_left kvs = - M.union m M.empty === m - where - m :: m k v - m = M.fromList kvs - -prop_union_identity_right - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_union_identity_right kvs = - M.union M.empty m === m - where - m :: m k v - m = M.fromList kvs - -prop_union_commutativity - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_commutativity kvs1 kvs2 = - M.union m1 m2 === M.union m2 m1 - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_union_associativity - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_associativity kvs1 kvs2 kvs3 = - M.union m1 (M.union m2 m3) - === M.union (M.union m1 m2) m3 - where - m1, m2, m3 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - m3 = M.fromList kvs3 - -prop_union_containment_left - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_containment_left kvs1 kvs2 = QC.property $ - m1 `M.isSubmapOf` M.union m1 m2 - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_union_containment_right - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_containment_right kvs1 kvs2 = QC.property $ - m2 `M.isSubmapOf` M.union m1 m2 - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_union_distributivity - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_union_distributivity k kvs1 kvs2 = - M.lookup k (M.union m1 m2) === Set.union (M.lookup k m1) (M.lookup k m2) - & cover 1 - (M.nonNullKey k (M.union m1 m2)) - "M.nonNullKey k (M.union m1 m2)" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_intersection_idempotence - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_intersection_idempotence kvs = - M.intersection m m === m - where - m :: m k v - m = M.fromList kvs - -prop_intersection_identity_left - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_intersection_identity_left kvs = - M.intersection m M.empty === M.empty - where - m :: m k v - m = M.fromList kvs - -prop_intersection_identity_right - :: forall m k v. Test m k v - => [(k, Set v)] - -> Property -prop_intersection_identity_right kvs = - M.intersection M.empty m === M.empty - where - m :: m k v - m = M.fromList kvs - -prop_intersection_commutativity - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_commutativity kvs1 kvs2 = - M.intersection m1 m2 === M.intersection m2 m1 - & cover 1 - (M.nonNull (M.intersection m1 m2)) - "M.nonNull (M.intersection m1 m2)" - & cover 1 - (M.nonNull (M.intersection m2 m1)) - "M.nonNull (M.intersection m2 m1)" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_intersection_associativity - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_associativity kvs1 kvs2 kvs3 = - M.intersection m1 (M.intersection m2 m3) - === M.intersection (M.intersection m1 m2) m3 - & cover 1 - (M.nonNull (M.intersection m1 (M.intersection m2 m3))) - "M.nonNull (M.intersection m1 (M.intersection m2 m3))" - & cover 1 - (M.nonNull (M.intersection (M.intersection m1 m2) m3)) - "M.nonNull (M.intersection (M.intersection m1 m2) m3)" - where - m1, m2, m3 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - m3 = M.fromList kvs3 - -prop_intersection_containment_left - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_containment_left kvs1 kvs2 = QC.property $ - M.intersection m1 m2 `M.isSubmapOf` m1 - & cover 1 - (M.nonNull (M.intersection m1 m2)) - "M.nonNull (M.intersection m1 m2)" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_intersection_containment_right - :: forall m k v. Test m k v - => [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_containment_right kvs1 kvs2 = QC.property $ - M.intersection m1 m2 `M.isSubmapOf` m2 - & cover 1 - (M.nonNull (M.intersection m1 m2)) - "M.nonNull (M.intersection m1 m2)" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - -prop_intersection_distributivity - :: forall m k v. Test m k v - => k - -> [(k, Set v)] - -> [(k, Set v)] - -> Property -prop_intersection_distributivity k kvs1 kvs2 = - M.lookup k (M.intersection m1 m2) - === Set.intersection (M.lookup k m1) (M.lookup k m2) - & cover 1 - (M.nonNullKey k (M.intersection m1 m2)) - "M.nonNullKey k (M.intersection m1 m2)" - where - m1, m2 :: m k v - m1 = M.fromList kvs1 - m2 = M.fromList kvs2 - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -infixr 3 ==> -(==>) :: Bool -> Bool -> Property -a ==> b = not a .||. b - -_preventRedundantImportErrors :: () -_preventRedundantImportErrors = () - where - _multiMap1 :: MultiMap1 () () - _multiMap1 = M.empty diff --git a/src/test/Examples/RecoveredMapSpec.hs b/src/test/Examples/RecoveredMapSpec.hs deleted file mode 100644 --- a/src/test/Examples/RecoveredMapSpec.hs +++ /dev/null @@ -1,586 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use any" #-} -{-# HLINT ignore "Use null" #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Examples.RecoveredMapSpec - where - -import Prelude - -import Data.Function - ( on, (&) ) -import Data.List - ( nubBy ) -import Data.Monoid - ( Sum (..) ) -import Data.Proxy - ( Proxy (..) ) -import Data.Semigroup - ( Semigroup (stimes) ) -import Data.Set - ( Set ) -import Data.Text - ( Text ) -import Data.Typeable - ( Typeable, typeRep ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( Arbitrary (..) - , CoArbitrary - , Fun - , Function - , NonNegative (..) - , Property - , Testable - , applyFun - , applyFun2 - , applyFun3 - , checkCoverage - , cover - , listOf - , shrinkMapBy - , (===) - ) -import Test.QuickCheck.Classes - ( eqLaws, functorLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) -import Test.QuickCheck.Instances.Natural - () -import Test.QuickCheck.Instances.Text - () - -import qualified Data.Map.Strict as OMap -import qualified Data.Set as Set -import qualified Examples.RecoveredMap as RMap -import qualified Test.QuickCheck as QC - -spec :: Spec -spec = do - specFor (Proxy @Int) (Proxy @(Set Int)) - specFor (Proxy @Int) (Proxy @(Set Natural)) - specFor (Proxy @Int) (Proxy @(Sum Int)) - specFor (Proxy @Int) (Proxy @(Sum Natural)) - specFor (Proxy @Int) (Proxy @Text) - -specFor - :: forall k v. () => - ( Arbitrary k - , Arbitrary v - , CoArbitrary k - , CoArbitrary v - , Eq v - , Function k - , Function v - , Monoid v - , Ord k - , Show k - , Show v - , Typeable k - , Typeable v - ) - => Proxy k - -> Proxy v - -> Spec -specFor keyType valueType = do - - let description = mconcat - [ "RecoveredMap (" - , show (typeRep keyType) - , ") (" - , show (typeRep valueType) - , ")" - ] - - let property :: Testable t => t -> Property - property = checkCoverage . QC.property - - describe description $ do - - describe "Class laws" $ do - testLawsMany @(RMap.Map k v) - [ eqLaws - , monoidLaws - , semigroupLaws - , semigroupMonoidLaws - ] - testLawsMany @(RMap.Map k) - [ functorLaws - ] - - describe "Conversion to and from lists" $ do - it "prop_fromList_toList" $ - prop_fromList_toList - @k @v & property - - describe "Empty" $ do - it "prop_empty_keysSet" $ - prop_empty_keysSet - @k & property - it "prop_empty_lookup" $ - prop_empty_lookup - @k @v & property - it "prop_empty_show" $ - prop_empty_show - @k @v & property - it "prop_empty_toList" $ - prop_empty_toList - @k @v & property - - describe "Singleton" $ do - it "prop_singleton_keysSet" $ - prop_singleton_keysSet - @k @v & property - it "prop_singleton_lookup" $ - prop_singleton_lookup - @k @v & property - it "prop_singleton_show" $ - prop_singleton_show - @k @v & property - it "prop_singleton_toList" $ - prop_singleton_toList - @k @v & property - - describe "Append" $ do - it "prop_append_toList" $ - prop_append_toList - @k @v & property - - describe "Times" $ do - it "prop_stimes_toList" $ - prop_stimes_toList - @k @v & property - - describe "Delete" $ do - it "prop_delete_lookup" $ - prop_delete_lookup - @k @v & property - it "prop_delete_member" $ - prop_delete_member - @k @v & property - it "prop_delete_toList" $ - prop_delete_toList - @k @v & property - - describe "Insert" $ do - it "prop_insert_lookup" $ - prop_insert_lookup - @k @v & property - it "prop_insert_member" $ - prop_insert_member - @k @v & property - it "prop_insert_toList" $ - prop_insert_toList - @k @v & property - - describe "Map" $ do - it "prop_map" $ - prop_map - @k @v @v & property - it "prop_map_mempty" $ - prop_map_mempty - @k @v @v & property - it "prop_mapWithKey" $ - prop_mapWithKey - @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 --------------------------------------------------------------------------------- - -prop_fromList_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => [(k, v)] - -> Property -prop_fromList_toList kvs = - (===) - (RMap.toList (RMap.fromList kvs)) - (OMap.toList (OMap.fromList kvs)) - & cover 10 - (length kvs > 1 && length (nubBy ((==) `on` fst) kvs) /= length kvs) - "length kvs > 1 && length (nubBy ((==) `on` fst) kvs) /= length kvs" - & cover 10 - (length kvs > 1 && length (nubBy ((==) `on` fst) kvs) == length kvs) - "length kvs > 1 && length (nubBy ((==) `on` fst) kvs) == length kvs" - --------------------------------------------------------------------------------- --- Empty --------------------------------------------------------------------------------- - -prop_empty_keysSet - :: forall k. (Eq k, Show k) - => Property -prop_empty_keysSet = - (===) - (RMap.keysSet (RMap.empty @k)) - (OMap.keysSet (OMap.empty @k)) - -prop_empty_lookup - :: forall k v. (Ord k, Eq v, Show v) - => k - -> Property -prop_empty_lookup k = - (===) - (RMap.lookup k (RMap.empty @k @v)) - (OMap.lookup k (OMap.empty @k @v)) - -prop_empty_show - :: forall k v. (Show k, Show v) - => Property -prop_empty_show = - (===) - (show (RMap.empty @k @v)) - (show (OMap.empty @k @v)) - -prop_empty_toList - :: forall k v. (Eq k, Show k, Eq v, Show v) - => Property -prop_empty_toList = - (===) - (RMap.toList (RMap.empty @k @v)) - (OMap.toList (OMap.empty @k @v)) - --------------------------------------------------------------------------------- --- Singleton --------------------------------------------------------------------------------- - -prop_singleton_keysSet - :: forall k v. (Ord k, Show k) - => k - -> v - -> Property -prop_singleton_keysSet k v = - (===) - (RMap.keysSet (RMap.singleton k v)) - (OMap.keysSet (OMap.singleton k v)) - -prop_singleton_lookup - :: forall k v. (Ord k, Eq v, Show v) - => k - -> v - -> Property -prop_singleton_lookup k v = - (===) - (RMap.lookup k (RMap.singleton k v)) - (OMap.lookup k (OMap.singleton k v)) - -prop_singleton_show - :: forall k v. (Ord k, Show k, Show v) - => k - -> v - -> Property -prop_singleton_show k v = - (===) - (show (RMap.singleton k v)) - (show (OMap.singleton k v)) - -prop_singleton_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => k - -> v - -> Property -prop_singleton_toList k v = - (===) - (RMap.toList (RMap.singleton k v)) - (OMap.toList (OMap.singleton k v)) - --------------------------------------------------------------------------------- --- Append --------------------------------------------------------------------------------- - -prop_append_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => [(k, v)] - -> [(k, v)] - -> Property -prop_append_toList kvs1 kvs2 = - (===) - (RMap.toList (RMap.fromList kvs1 <> RMap.fromList kvs2)) - (OMap.toList (OMap.fromList kvs1 <> OMap.fromList kvs2)) - & cover 10 - (ks1 `Set.disjoint` ks2) - "ks1 `Set.disjoint` ks2" - & cover 10 - (not (ks1 `Set.disjoint` ks2)) - "not (ks1 `Set.disjoint` ks2)" - where - ks1 = Set.fromList (fst <$> kvs1) - ks2 = Set.fromList (fst <$> kvs2) - --------------------------------------------------------------------------------- --- Times --------------------------------------------------------------------------------- - -prop_stimes_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => [(k, v)] - -> NonNegative Int - -> Property -prop_stimes_toList kvs (NonNegative n) = - (===) - (RMap.toList (stimes n (RMap.fromList kvs))) - (OMap.toList (stimes n (OMap.fromList kvs))) - & cover 1 - (n == 0) - "n == 0" - & cover 1 - (n == 1) - "n == 1" - & cover 10 - (n >= 2) - "n >= 2" - --------------------------------------------------------------------------------- --- Delete --------------------------------------------------------------------------------- - -prop_delete_lookup - :: forall k v. (Ord k, Eq v, Show v) - => [(k, v)] - -> k - -> Property -prop_delete_lookup kvs k = - (===) - (RMap.lookup k (RMap.delete k (RMap.fromList kvs))) - (OMap.lookup k (OMap.delete k (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - -prop_delete_member - :: forall k v. (Ord k, Eq v) - => [(k, v)] - -> k - -> Property -prop_delete_member kvs k = - (===) - (RMap.member k (RMap.delete k (RMap.fromList kvs))) - (OMap.member k (OMap.delete k (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - -prop_delete_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => [(k, v)] - -> k - -> Property -prop_delete_toList kvs k = - (===) - (RMap.toList (RMap.delete k (RMap.fromList kvs))) - (OMap.toList (OMap.delete k (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - --------------------------------------------------------------------------------- --- Insert --------------------------------------------------------------------------------- - -prop_insert_lookup - :: forall k v. (Ord k, Eq v, Show v) - => [(k, v)] - -> k - -> v - -> Property -prop_insert_lookup kvs k v = - (===) - (RMap.lookup k (RMap.insert k v (RMap.fromList kvs))) - (OMap.lookup k (OMap.insert k v (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - -prop_insert_member - :: forall k v. (Ord k, Eq v) - => [(k, v)] - -> k - -> v - -> Property -prop_insert_member kvs k v = - (===) - (RMap.member k (RMap.insert k v (RMap.fromList kvs))) - (OMap.member k (OMap.insert k v (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - -prop_insert_toList - :: forall k v. (Ord k, Show k, Eq v, Show v) - => [(k, v)] - -> k - -> v - -> Property -prop_insert_toList kvs k v = - (===) - (RMap.toList (RMap.insert k v (RMap.fromList kvs))) - (OMap.toList (OMap.insert k v (OMap.fromList kvs))) - & cover 10 - (filter ((== k) . fst) kvs == []) - "filter ((== k) . fst) kvs == []" - & cover 10 - (filter ((== k) . fst) kvs /= []) - "filter ((== k) . fst) kvs /= []" - --------------------------------------------------------------------------------- --- Map --------------------------------------------------------------------------------- - -prop_map - :: (Ord k, Show k, Eq v2, Show v2) - => [(k, v1)] - -> Fun v1 v2 - -> Property -prop_map kvs (applyFun -> f) = - (===) - (RMap.toList (RMap.map f (RMap.fromList kvs))) - (OMap.toList (OMap.map f (OMap.fromList kvs))) - -prop_map_mempty - :: forall k v1 v2. (Ord k, Show k, Eq v2, Monoid v2, Show v2) - => [(k, v1)] - -> Property -prop_map_mempty kvs = - (===) - (RMap.toList (RMap.map (const (mempty @v2)) (RMap.fromList kvs))) - (OMap.toList (OMap.map (const (mempty @v2)) (OMap.fromList kvs))) - -prop_mapWithKey - :: (Ord k, Show k, Eq v2, Show v2) - => [(k, v1)] - -> Fun (k, v1) v2 - -> Property -prop_mapWithKey kvs (applyFun2 -> f) = - (===) - (RMap.toList (RMap.mapWithKey f (RMap.fromList kvs))) - (OMap.toList (OMap.mapWithKey f (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 --------------------------------------------------------------------------------- - -instance (Arbitrary k, Ord k, Arbitrary v) => - Arbitrary (RMap.Map k v) - where - arbitrary = RMap.fromList <$> listOf ((,) <$> arbitrary <*> arbitrary) - shrink = shrinkMapBy RMap.fromList RMap.toList shrink diff --git a/src/test/Spec.hs b/src/test/Spec.hs deleted file mode 100644 --- a/src/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/SpecHook.hs b/src/test/SpecHook.hs deleted file mode 100644 --- a/src/test/SpecHook.hs +++ /dev/null @@ -1,6 +0,0 @@ -module SpecHook where - -import Test.Hspec - -hook :: Spec -> Spec -hook = parallel diff --git a/src/test/Test/Combinators/NonZero.hs b/src/test/Test/Combinators/NonZero.hs deleted file mode 100644 --- a/src/test/Test/Combinators/NonZero.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Test.Combinators.NonZero - ( NonZero - , genNonZero - , getNonZero - , maybeNonZero - , shrinkNonZero - ) - where - -import Prelude - -import Data.Group - ( Group ) -import Data.Maybe - ( mapMaybe ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.Semigroup.Cancellative - ( Commutative ) -import Test.QuickCheck - ( Gen, suchThatMap ) - --- | A combinator for non-zero values. -newtype NonZero a = NonZero a - deriving newtype (Eq, Num, Read, Show) - deriving newtype (Semigroup, Commutative, Monoid, MonoidNull, Group) - -genNonZero :: (Eq a, Num a) => Gen a -> Gen (NonZero a) -genNonZero genA = suchThatMap genA maybeNonZero - -getNonZero :: NonZero a -> a -getNonZero (NonZero a) = a - -maybeNonZero :: (Eq a, Num a) => a -> Maybe (NonZero a) -maybeNonZero p - | p == 0 = Nothing - | otherwise = Just (NonZero p) - -shrinkNonZero :: (Eq a, Num a) => (a -> [a]) -> NonZero a -> [NonZero a] -shrinkNonZero shrinkA = mapMaybe maybeNonZero . shrinkA . getNonZero diff --git a/src/test/Test/Common.hs b/src/test/Test/Common.hs deleted file mode 100644 --- a/src/test/Test/Common.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use camelCase" -} -{- HLINT ignore "Use null" -} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Test.Common - ( Key - , Test - , TestType (..) - , testTypesMonoidNull - , testTypesGroup - , testTypesMonus - , testTypesLeftReductive - , testTypesRightReductive - , testTypesReductive - , testTypesLeftGCDMonoid - , testTypesRightGCDMonoid - , testTypesOverlappingGCDMonoid - , testTypesGCDMonoid - , testTypesLCMMonoid - , TestValue - , makeSpec - , property - ) where - -import Prelude - -import Data.Group - ( Group ) -import Data.Kind - ( Constraint, Type ) -import Data.Monoid - ( Dual, Product, Sum ) -import Data.Monoid.GCD - ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) -import Data.Monoid.LCM - ( LCMMonoid ) -import Data.Monoid.Monus - ( Monus ) -import Data.Monoid.Null - ( MonoidNull ) -import Data.MonoidMap - ( MonoidMap ) -import Data.Proxy - ( Proxy (Proxy) ) -import Data.Semigroup.Cancellative - ( LeftReductive, Reductive, RightReductive ) -import Data.Set - ( Set ) -import Data.Text - ( Text ) -import Data.Typeable - ( Typeable, typeRep ) -import GHC.Exts - ( IsList (..) ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe ) -import Test.QuickCheck - ( Arbitrary (..) - , CoArbitrary (..) - , Function (..) - , Property - , Testable - , checkCoverage - , choose - , coarbitraryIntegral - , coarbitraryShow - , frequency - , functionIntegral - , functionShow - , listOf - , scale - , shrinkMapBy - ) -import Test.QuickCheck.Instances.Natural - () - -import qualified Data.MonoidMap as MonoidMap -import qualified Data.Text as Text -import qualified Test.QuickCheck as QC - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -instance (Arbitrary k, Ord k, Arbitrary v, MonoidNull v) => - Arbitrary (MonoidMap k v) - where - arbitrary = - fromList <$> scale (`mod` 16) (listOf ((,) <$> arbitrary <*> arbitrary)) - shrink = - shrinkMapBy MonoidMap.fromMap MonoidMap.toMap shrink - -instance Arbitrary Text where - arbitrary = Text.pack <$> listOf genChar - where - genChar = frequency - [ (64, pure 'a') - , (16, pure 'b') - , ( 4, pure 'c') - , ( 1, pure 'd') - ] - -instance CoArbitrary Text where - coarbitrary = coarbitraryShow - -instance Function Text where - function = functionShow - --------------------------------------------------------------------------------- --- Test keys --------------------------------------------------------------------------------- - -newtype Key = Key Int - deriving (Enum, Eq, Integral, Num, Ord, Real, Show) - -instance Arbitrary Key where - arbitrary = Key <$> choose (0, 15) - shrink (Key k) = Key <$> shrink k - -instance CoArbitrary Key where - coarbitrary = coarbitraryIntegral - -instance Function Key where - function = functionIntegral - --------------------------------------------------------------------------------- --- Test constraints --------------------------------------------------------------------------------- - -type Test k v = (TestKey k, TestValue v) - -type TestKey k = - ( Arbitrary k - , CoArbitrary k - , Function k - , Ord k - , Show k - , Typeable k - ) - -type TestValue v = - ( Arbitrary v - , CoArbitrary v - , Eq v - , Function v - , MonoidNull v - , Show v - , Typeable v - ) - --------------------------------------------------------------------------------- --- Test types (for different type class constraints) --------------------------------------------------------------------------------- - -data TestType (c :: Type -> Constraint) = - forall v. (TestValue v, c v) => TestType (Proxy v) - -testTypesMonoidNull :: [TestType MonoidNull] -testTypesMonoidNull = - [ TestType (Proxy @(Dual Text)) - , TestType (Proxy @(Dual [Int])) - , TestType (Proxy @(Dual [Natural])) - , TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Int)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Int)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @(Text)) - , TestType (Proxy @[Int]) - , TestType (Proxy @[Natural]) - ] - -testTypesGroup :: [TestType Group] -testTypesGroup = - [ TestType (Proxy @(Sum Int)) - ] - -testTypesMonus :: [TestType Monus] -testTypesMonus = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - ] - -testTypesLeftReductive :: [TestType LeftReductive] -testTypesLeftReductive = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Int)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Int)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @[Int]) - , TestType (Proxy @[Natural]) - , TestType (Proxy @(Text)) - , TestType (Proxy @(Dual [Int])) - , TestType (Proxy @(Dual [Natural])) - , TestType (Proxy @(Dual Text)) - ] - -testTypesRightReductive :: [TestType RightReductive] -testTypesRightReductive = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Int)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Int)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @[Int]) - , TestType (Proxy @[Natural]) - , TestType (Proxy @(Text)) - , TestType (Proxy @(Dual [Int])) - , TestType (Proxy @(Dual [Natural])) - , TestType (Proxy @(Dual Text)) - ] - -testTypesReductive :: [TestType Reductive] -testTypesReductive = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Int)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Int)) - , TestType (Proxy @(Product Natural)) - ] - -testTypesLeftGCDMonoid :: [TestType LeftGCDMonoid] -testTypesLeftGCDMonoid = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @(Text)) - , TestType (Proxy @(Dual Text)) - ] - -testTypesRightGCDMonoid :: [TestType RightGCDMonoid] -testTypesRightGCDMonoid = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @(Text)) - , TestType (Proxy @(Dual Text)) - ] - -testTypesOverlappingGCDMonoid :: [TestType OverlappingGCDMonoid] -testTypesOverlappingGCDMonoid = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - , TestType (Proxy @(Text)) - , TestType (Proxy @(Dual Text)) - ] - -testTypesGCDMonoid :: [TestType GCDMonoid] -testTypesGCDMonoid = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - ] - -testTypesLCMMonoid :: [TestType LCMMonoid] -testTypesLCMMonoid = - [ TestType (Proxy @(Set Int)) - , TestType (Proxy @(Set Natural)) - , TestType (Proxy @(Sum Natural)) - , TestType (Proxy @(Product Natural)) - ] - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -makeSpec :: forall k v. Test k v => Spec -> Proxy k -> Proxy v -> Spec -makeSpec spec _k _v = describe (show $ typeRep (Proxy @(MonoidMap k v))) spec - -property :: Testable t => t -> Property -property = checkCoverage . QC.property diff --git a/src/test/Test/Hspec/Unit.hs b/src/test/Test/Hspec/Unit.hs deleted file mode 100644 --- a/src/test/Test/Hspec/Unit.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- -module Test.Hspec.Unit where - -import Prelude - -import Data.Functor - ( (<&>) ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( counterexample, property ) -import Text.Show.Pretty - ( ppShow ) - -import qualified Data.Foldable as F - -class IsUnitTestDatum d f r | d -> f, d -> r where - params :: d -> [String] - resultActual :: f -> d -> r - resultExpected :: d -> r - -data UnitTestDatum1 p1 r = UnitTestDatum1 p1 r -data UnitTestDatum2 p1 p2 r = UnitTestDatum2 p1 p2 r -data UnitTestDatum3 p1 p2 p3 r = UnitTestDatum3 p1 p2 p3 r -data UnitTestDatum4 p1 p2 p3 p4 r = UnitTestDatum4 p1 p2 p3 p4 r - -type UnitTestData1 p1 r = [UnitTestDatum1 p1 r] -type UnitTestData2 p1 p2 r = [UnitTestDatum2 p1 p2 r] -type UnitTestData3 p1 p2 p3 r = [UnitTestDatum3 p1 p2 p3 r] -type UnitTestData4 p1 p2 p3 p4 r = [UnitTestDatum4 p1 p2 p3 p4 r] - -unitTestDatum1 :: (p1, r) -> UnitTestDatum1 p1 r -unitTestDatum1 (p1, r) = UnitTestDatum1 p1 r -unitTestDatum2 :: (p1, p2, r) -> UnitTestDatum2 p1 p2 r -unitTestDatum2 (p1, p2, r) = UnitTestDatum2 p1 p2 r -unitTestDatum3 :: (p1, p2, p3, r) -> UnitTestDatum3 p1 p2 p3 r -unitTestDatum3 (p1, p2, p3, r) = UnitTestDatum3 p1 p2 p3 r -unitTestDatum4 :: (p1, p2, p3, p4, r) -> UnitTestDatum4 p1 p2 p3 p4 r -unitTestDatum4 (p1, p2, p3, p4, r) = UnitTestDatum4 p1 p2 p3 p4 r - -unitTestData1 :: [(p1, r)] -> UnitTestData1 p1 r -unitTestData1 = fmap unitTestDatum1 -unitTestData2 :: [(p1, p2, r)] -> UnitTestData2 p1 p2 r -unitTestData2 = fmap unitTestDatum2 -unitTestData3 :: [(p1, p2, p3, r)] -> UnitTestData3 p1 p2 p3 r -unitTestData3 = fmap unitTestDatum3 -unitTestData4 :: [(p1, p2, p3, p4, r)] -> UnitTestData4 p1 p2 p3 p4 r -unitTestData4 = fmap unitTestDatum4 - -instance Show p1 => - IsUnitTestDatum (UnitTestDatum1 p1 r) (p1 -> r) r - where - params (UnitTestDatum1 p1 _) = [show p1] - resultActual f (UnitTestDatum1 p1 _) = f p1 - resultExpected (UnitTestDatum1 _ r) = r - -instance (Show p1, Show p2) => - IsUnitTestDatum (UnitTestDatum2 p1 p2 r) (p1 -> p2 -> r) r - where - params (UnitTestDatum2 p1 p2 _) = [show p1, show p2] - resultActual f (UnitTestDatum2 p1 p2 _) = f p1 p2 - resultExpected (UnitTestDatum2 _ _ r) = r - -instance (Show p1, Show p2, Show p3) => - IsUnitTestDatum (UnitTestDatum3 p1 p2 p3 r) (p1 -> p2 -> p3 -> r) r - where - params (UnitTestDatum3 p1 p2 p3 _) = [show p1, show p2, show p3] - resultActual f (UnitTestDatum3 p1 p2 p3 _) = f p1 p2 p3 - resultExpected (UnitTestDatum3 _ _ _ r) = r - -instance (Show p1, Show p2, Show p3, Show p4) => - IsUnitTestDatum (UnitTestDatum4 p1 p2 p3 p4 r) (p1 -> p2 -> p3 -> p4 -> r) r - where - params (UnitTestDatum4 p1 p2 p3 p4 _) = [show p1, show p2, show p3, show p4] - resultActual f (UnitTestDatum4 p1 p2 p3 p4 _) = f p1 p2 p3 p4 - resultExpected (UnitTestDatum4 _ _ _ _ r) = r - -unitTestSpec - :: forall d f r. (IsUnitTestDatum d f r, Eq r, Show r) - => String - -> String - -> f - -> [d] - -> Spec -unitTestSpec specDescription functionName function = - describe specDescription . mapM_ unitTest - where - unitTest :: d -> Spec - unitTest d = it description - $ property - $ counterexample counterexampleText - $ resultExpected d == resultActual function d - where - counterexampleText = unlines - [ "" - , "expected" - , "/=" - , "actual" - , "" - , showWrap (resultExpected d) - , "/=" - , showWrap (resultActual function d) - ] - description = unwords - [ functionName - , unwords (params d <&> \s -> "(" <> s <> ")") - ] - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -showWrap :: Show a => a -> String -showWrap x - | singleLineMaxLengthExceeded = - multiLine - | otherwise = - singleLine - where - multiLine = ppShow x - singleLine = show x - singleLineMaxLength = 80 - singleLineMaxLengthExceeded = F.length singleLine > singleLineMaxLength diff --git a/src/test/Test/QuickCheck/Classes/Hspec.hs b/src/test/Test/QuickCheck/Classes/Hspec.hs deleted file mode 100644 --- a/src/test/Test/QuickCheck/Classes/Hspec.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - --- | --- Copyright: © 2022–2025 Jonathan Knowles --- License: Apache-2.0 --- --- Provides testing functions to check that type class instances obey laws. --- -module Test.QuickCheck.Classes.Hspec - ( testLaws - , testLawsMany - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Proxy - ( Proxy (..) ) -import Data.Typeable - ( Typeable, typeRep ) -import Test.Hspec - ( Spec, describe, it, parallel ) -import Test.QuickCheck.Classes - ( Laws (..) ) - --- | Constructs a test to check that the given type class instance obeys the --- given set of laws. --- --- Example usage: --- --- >>> testLaws @Natural ordLaws --- >>> testLaws @(Map Int) functorLaws --- -testLaws - :: forall a. Typeable a - => (Proxy a -> Laws) - -> Spec -testLaws getLaws = - parallel $ describe description $ - forM_ (lawsProperties laws) $ uncurry it - where - description = mconcat - [ "Testing " - , lawsTypeclass laws - , " laws for type " - , show (typeRep $ Proxy @a) - ] - laws = getLaws $ Proxy @a - --- | Calls `testLaws` with multiple sets of laws. --- --- Example usage: --- --- >>> testLawsMany @Natural [eqLaws, ordLaws] --- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws] --- -testLawsMany - :: forall a. Typeable a - => [Proxy a -> Laws] - -> Spec -testLawsMany getLawsMany = - testLaws @a `mapM_` getLawsMany