diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.1.2.0 + +- Improved the performance of `fromMap`, particularly for maps that + contain no `mempty` values. This also benefits `fromList`, `fromListWith` + and `fromSet`, which are defined in terms of `fromMap`. + # 0.1.1.0 - Added functions `nullifyKeysIn` and `nullifyKeysNotIn` to `MonoidMap`. diff --git a/components/monoidmap-benchmark/Main.hs b/components/monoidmap-benchmark/Main.hs --- a/components/monoidmap-benchmark/Main.hs +++ b/components/monoidmap-benchmark/Main.hs @@ -2,40 +2,51 @@ -- Copyright: © 2022–2026 Jonathan Knowles -- License: Apache-2.0 -- --- Benchmark for the `MonoidMap` type. +-- Benchmark for the 'MonoidMap' type and its functions. -- --- 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`. +-- When a 'MonoidMap' function has a direct counterpart in 'Map' (such as the +-- 'fromList' function), we benchmark 'Map' against 'RecoveredMap': a newtype +-- wrapper around 'MonoidMap' with functions that have the same semantics as +-- those of 'Map', so that both sides of each comparison behave identically. -- +-- When a 'MonoidMap' function has no direct counterpart in 'Map' (such as the +-- 'fromMap' function), we benchmark the 'MonoidMap' function directly. +-- module Main where import Control.DeepSeq - ( rnf ) + ( NFData, rnf ) import Control.Exception ( evaluate ) +import Data.Bool + ( Bool (False, True) ) import Data.Eq - ( Eq ) + ( Eq ((==)) ) import Data.Function - ( flip, ($) ) + ( const, flip, ($) ) import Data.Int ( Int ) import Data.List - ( foldl', zip ) + ( filter, foldl', zip ) import Data.Maybe ( Maybe, fromMaybe ) +import Data.Monoid + ( Monoid (mempty), Sum (Sum) ) import Data.Ord ( Ord ) import Data.Semigroup ( Semigroup ((<>)), stimes ) +import Data.String + ( String ) import Prelude - ( Integer, Num, (^), (+) ) + ( Integer, Num, even, odd, (^), (+) ) import System.IO ( IO ) import Test.Tasty.Bench - ( bench, bgroup, defaultMain, nf ) + ( Benchmark, bcompare, bench, bgroup, defaultMain, nf ) import qualified Data.Map.Strict as OMap +import qualified Data.MonoidMap.Internal as MMap import qualified Data.MonoidMap.Internal.RecoveredMap as RMap main :: IO () @@ -49,11 +60,60 @@ rm_even = fromList elems_even :: RMap.Map Int Int rm_odd = fromList elems_odd :: RMap.Map Int Int + -- Maps in which different subsets of keys have 'null' values: + om_null_none = mapWithNullIf (const False) :: OMap.Map Int (Sum Int) + om_null_min = mapWithNullIf (== minNatural) :: OMap.Map Int (Sum Int) + om_null_max = mapWithNullIf (== maxNatural) :: OMap.Map Int (Sum Int) + om_null_even = mapWithNullIf even :: OMap.Map Int (Sum Int) + om_null_odd = mapWithNullIf odd :: OMap.Map Int (Sum Int) + om_null_all = mapWithNullIf (const True) :: OMap.Map Int (Sum Int) + evaluate $ rnf [om_natural, om_even, om_odd] evaluate $ rnf [rm_natural, rm_even, rm_odd] + evaluate $ rnf + [ om_null_none + , om_null_min + , om_null_max + , om_null_even + , om_null_odd + , om_null_all + ] + let fromMapCases = + [ ("no nulls", om_null_none) + , ("one null (min key)", om_null_min) + , ("one null (max key)", om_null_max) + , ("even nulls", om_null_even) + , ("odd nulls", om_null_odd) + , ("all nulls", om_null_all) + ] + defaultMain - [ bgroup "delete" + [ compareImplementations + ("fromMap", MMap.fromMap) fromMapCases + [ ( "fromMap_filter" + , MMap.fromMap_filter + ) + , ( "fromMap_filter_if_any_null" + , MMap.fromMap_filter_if_any_null + ) + , ( "fromMap_mapMaybe" + , MMap.fromMap_mapMaybe + ) + ] + , compareImplementations + ("fromMapWith", MMap.fromMapWith double) fromMapCases + [ ( "fromMapWith_mapMaybe" + , MMap.fromMapWith_mapMaybe double + ) + , ( "fromMapWith_map_filter" + , MMap.fromMapWith_map_filter double + ) + , ( "fromMapWith_map_filter_if_any_null" + , MMap.fromMapWith_map_filter_if_any_null double + ) + ] + , bgroup "delete" [ bgroup "absent" [ bench "Data.Map.Strict" $ nf (deleteMany evens) om_odd @@ -141,9 +201,12 @@ ] ] where - bound :: Int - bound = 2 ^ (16 :: Int) + minNatural :: Int + minNatural = 1 + maxNatural :: Int + maxNatural = 2 ^ (16 :: Int) + elems_natural :: [(Int, Int)] elems_natural = zip naturals naturals @@ -154,16 +217,62 @@ elems_odd = zip odds odds naturals :: [Int] - naturals = [1 .. bound] + naturals = [minNatural .. maxNatural] evens :: [Int] - evens = [2, 4 .. bound] + evens = filter even naturals odds :: [Int] - odds = [1, 3 .. bound] + odds = filter odd naturals ten_power_24 :: Integer ten_power_24 = 1_000_000_000_000_000_000_000_000 + + -- A map from keys [minNatural .. maxNatural], with a null value for each + -- key that satisfies the given predicate, and a non-null value otherwise. + mapWithNullIf :: (Int -> Bool) -> OMap.Map Int (Sum Int) + mapWithNullIf hasNullValue = OMap.fromList + [ (k, if hasNullValue k then mempty else Sum 1) + | k <- [minNatural .. maxNatural] + ] + + -- A simple function that replaces every value with a new value, while: + -- - preserving existing null values; and + -- - not introducing any new null values. + double :: Semigroup m => m -> m + double m = m <> m + +-- | Compares implementations of a public function with the public function +-- itself, for each of the given cases. +-- +-- For each case, the time taken by each implementation is reported relative +-- to the time taken by the public function. +-- +compareImplementations + :: NFData r + => (String, i -> r) + -- ^ The public function, with its name (also used as the group name). + -> [(String, i)] + -- ^ Cases (inputs) to benchmark, each with a label. + -> [(String, i -> r)] + -- ^ Implementations of the public function, each with a name. + -> Benchmark +compareImplementations (publicName, public) cases implementations = + bgroup publicName + [ bgroup label $ + bench publicName (nf public input) : + [ bcompare (relativeToPublic label) $ bench name $ nf f input + | (name, f) <- implementations + ] + | (label, input) <- cases + ] + where + -- Matches the benchmark of the public function for the given case (and + -- nothing else): + relativeToPublic label = + "$NF == \"" <> publicName <> "\"" + <> " && $(NF-1) == \"" <> label <> "\"" + <> " && $(NF-2) == \"" <> publicName <> "\"" class Ord k => Map m k v where fromList :: [(k, v)] -> m k v diff --git a/components/monoidmap-internal/Data/MonoidMap/Internal.hs b/components/monoidmap-internal/Data/MonoidMap/Internal.hs --- a/components/monoidmap-internal/Data/MonoidMap/Internal.hs +++ b/components/monoidmap-internal/Data/MonoidMap/Internal.hs @@ -4,6 +4,7 @@ {- HLINT ignore "Avoid lambda" -} {- HLINT ignore "Avoid lambda using `infix`" -} {- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Use camelCase" -} -- | -- Copyright: © 2022–2026 Jonathan Knowles @@ -28,6 +29,14 @@ , fromSet , singleton + -- ** Construction (Internal) + , fromMap_filter + , fromMap_filter_if_any_null + , fromMap_mapMaybe + , fromMapWith_mapMaybe + , fromMapWith_map_filter + , fromMapWith_map_filter_if_any_null + -- ** Deconstruction , toList , toMap @@ -518,8 +527,25 @@ -- complexity that is linear in the size of the map. -- fromMap :: MonoidNull v => Map k v -> MonoidMap k v -fromMap = MonoidMap . Map.mapMaybe maybeNonNull +fromMap = fromMap_filter_if_any_null +{-# INLINABLE fromMap #-} +fromMap_filter :: MonoidNull v => Map k v -> MonoidMap k v +fromMap_filter = coerce . Map.filter (\(!v) -> not (C.null v)) +{-# INLINABLE fromMap_filter #-} + +fromMap_filter_if_any_null :: MonoidNull v => Map k v -> MonoidMap k v +fromMap_filter_if_any_null m + | F.any (\(!v) -> C.null v) m = + coerce $ Map.filter (\(!v) -> not (C.null v)) m + | otherwise = + coerce m +{-# INLINABLE fromMap_filter_if_any_null #-} + +fromMap_mapMaybe :: MonoidNull v => Map k v -> MonoidMap k v +fromMap_mapMaybe = MonoidMap . Map.mapMaybe maybeNonNull +{-# INLINABLE fromMap_mapMaybe #-} + -- | \(O(n)\). Constructs a 'MonoidMap' from an ordinary 'Map', applying -- the given function to all values. -- @@ -535,7 +561,23 @@ -- @since 0.0.4.0 -- fromMapWith :: MonoidNull v2 => (v1 -> v2) -> Map k v1 -> MonoidMap k v2 -fromMapWith f = MonoidMap . Map.mapMaybe (maybeNonNull . f) +fromMapWith = fromMapWith_mapMaybe +{-# INLINABLE fromMapWith #-} + +fromMapWith_mapMaybe + :: MonoidNull v2 => (v1 -> v2) -> Map k v1 -> MonoidMap k v2 +fromMapWith_mapMaybe f = MonoidMap . Map.mapMaybe (maybeNonNull . f) +{-# INLINABLE fromMapWith_mapMaybe #-} + +fromMapWith_map_filter + :: MonoidNull v2 => (v1 -> v2) -> Map k v1 -> MonoidMap k v2 +fromMapWith_map_filter f = fromMap_filter . Map.map f +{-# INLINABLE fromMapWith_map_filter #-} + +fromMapWith_map_filter_if_any_null + :: MonoidNull v2 => (v1 -> v2) -> Map k v1 -> MonoidMap k v2 +fromMapWith_map_filter_if_any_null f = fromMap_filter_if_any_null . Map.map f +{-# INLINABLE fromMapWith_map_filter_if_any_null #-} -- | \(O(n)\). Constructs a 'MonoidMap' from a 'Set' and a function from -- keys to values. diff --git a/components/monoidmap-test/Data/MonoidMap/Internal/ValiditySpec.hs b/components/monoidmap-test/Data/MonoidMap/Internal/ValiditySpec.hs --- a/components/monoidmap-test/Data/MonoidMap/Internal/ValiditySpec.hs +++ b/components/monoidmap-test/Data/MonoidMap/Internal/ValiditySpec.hs @@ -141,6 +141,9 @@ it "propValid_fromMap" $ propValid_fromMap @k @v & property + it "propValid_fromMapWith" $ + propValid_fromMapWith + @k @v & property it "propValid_fromSet" $ propValid_fromSet @k @v & property @@ -386,6 +389,14 @@ & cover 2 (Map.filter Null.null m /= mempty) "Map.filter Null.null m /= mempty" + +propValid_fromMapWith + :: Test k v => Fun v v -> Map k v -> Property +propValid_fromMapWith (applyFun -> f) m = + propValid (MonoidMap.fromMapWith f m) + & cover 2 + (Map.filter Null.null (Map.map f m) /= mempty) + "Map.filter Null.null (Map.map f m) /= mempty" propValid_fromSet :: Test k v => Fun k v -> Set k -> Property diff --git a/monoidmap-internal.cabal b/monoidmap-internal.cabal --- a/monoidmap-internal.cabal +++ b/monoidmap-internal.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: monoidmap-internal -version: 0.1.1.0 +version: 0.1.2.0 homepage: https://github.com/jonathanknowles/monoidmap/tree/HEAD/packages/monoidmap-internal bug-reports: https://github.com/jonathanknowles/monoidmap/issues license: Apache-2.0 @@ -112,6 +112,9 @@ components/monoidmap-benchmark main-is: Main.hs + -- Report allocation and memory statistics for each benchmark: + ghc-options: + "-with-rtsopts=-T" test-suite monoidmap-test import: