diff --git a/CHANGELOG.md b/CHANGELOG.md index 18ec125..5fc7a37 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,9 +6,11 @@ Notable changes to this project are documented in this file. The format is based Breaking changes: - Added support for PureScript 0.14 and dropped support for all previous versions (#35, #43) +- Drop `Map`'s `Semigroup` and `Monoid` instances and provide unbiased instances via `SemigroupMap` newtype (#38) New features: - Added `Apply` instance for `Map` (#16) +- Added `Alt` and `Plus` instances for `Map` (#38) - Added `catMaybes` for maps and sets (#25) - Added `toMap` and `fromMap` to `Data.Set` (#31) diff --git a/src/Data/Map.purs b/src/Data/Map.purs index 78755f4..bda8bd1 100644 --- a/src/Data/Map.purs +++ b/src/Data/Map.purs @@ -1,14 +1,65 @@ module Data.Map ( module Data.Map.Internal , keys + , SemigroupMap(..) ) where import Prelude +import Control.Alt (class Alt) +import Control.Plus (class Plus) +import Data.Eq (class Eq1) +import Data.Foldable (class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Newtype (class Newtype) +import Data.Ord (class Ord1) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) import Data.Set (Set, fromMap) -- | The set of keys of the given map. -- | See also `Data.Set.fromMap`. keys :: forall k v. Map k v -> Set k keys = fromMap <<< void + +-- | `SemigroupMap k v` provides a `Semigroup` instance for `Map k v` whose +-- | definition depends on the `Semigroup` instance for the `v` type. +-- | You should only use this type when you need `Data.Map` to have +-- | a `Semigroup` instance. +-- | +-- | ```purescript +-- | let +-- | s :: forall key value. key -> value -> SemigroupMap key value +-- | s k v = SemigroupMap (singleton k v) +-- | +-- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") +-- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) +-- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 2)) +-- | ``` +newtype SemigroupMap k v = SemigroupMap (Map k v) + +derive newtype instance eq1SemigroupMap :: Eq k => Eq1 (SemigroupMap k) +derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) +derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) +derive newtype instance ordSemigroupMap :: (Ord k, Ord v) => Ord (SemigroupMap k v) +derive instance newtypeSemigroupMap :: Newtype (SemigroupMap k v) _ +derive newtype instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) + +instance semigroupSemigroupMap :: (Ord k, Semigroup v) => Semigroup (SemigroupMap k v) where + append (SemigroupMap l) (SemigroupMap r) = SemigroupMap (unionWith append l r) + +instance monoidSemigroupMap :: (Ord k, Semigroup v) => Monoid (SemigroupMap k v) where + mempty = SemigroupMap empty + +derive newtype instance altSemigroupMap :: Ord k => Alt (SemigroupMap k) +derive newtype instance plusSemigroupMap :: Ord k => Plus (SemigroupMap k) +derive newtype instance functorSemigroupMap :: Functor (SemigroupMap k) +derive newtype instance functorWithIndexSemigroupMap :: FunctorWithIndex k (SemigroupMap k) +derive newtype instance applySemigroupMap :: Ord k => Apply (SemigroupMap k) +derive newtype instance bindSemigroupMap :: Ord k => Bind (SemigroupMap k) +derive newtype instance foldableSemigroupMap :: Foldable (SemigroupMap k) +derive newtype instance foldableWithIndexSemigroupMap :: FoldableWithIndex k (SemigroupMap k) +derive newtype instance traversableSemigroupMap :: Traversable (SemigroupMap k) +derive newtype instance traversableWithIndexSemigroupMap :: TraversableWithIndex k (SemigroupMap k) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 39b7ed8..bdbe700 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -49,6 +49,8 @@ module Data.Map.Internal import Prelude +import Control.Alt (class Alt) +import Control.Plus (class Plus) import Data.Eq (class Eq1) import Data.Foldable (foldl, foldMap, foldr, class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) @@ -90,11 +92,11 @@ instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" -instance semigroupMap :: Ord k => Semigroup (Map k v) where - append = union +instance altMap :: Ord k => Alt (Map k) where + alt = union -instance monoidMap :: Ord k => Monoid (Map k v) where - mempty = empty +instance plusMap :: Ord k => Plus (Map k) where + empty = empty instance functorMap :: Functor (Map k) where map _ Leaf = Leaf @@ -122,9 +124,6 @@ instance foldableWithIndexMap :: FoldableWithIndex k (Map k) where foldrWithIndex f z m = foldr (uncurry f) z $ asList $ toUnfoldable m foldMapWithIndex f m = foldMap (uncurry f) $ asList $ toUnfoldable m -asList :: forall k v. List (Tuple k v) -> List (Tuple k v) -asList = identity - instance traversableMap :: Traversable (Map k) where traverse f Leaf = pure Leaf traverse f (Two left k v right) = @@ -158,6 +157,9 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right +asList :: forall k v. List (Tuple k v) -> List (Tuple k v) +asList = identity + -- | Render a `Map` as a `String` showTree :: forall k v. Show k => Show v => Map k v -> String showTree Leaf = "Leaf" @@ -322,7 +324,10 @@ findMin = go Nothing -- | == ["zero", "one", "two"] -- | ``` foldSubmap :: forall k v m. Ord k => Monoid m => Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m -foldSubmap kmin kmax f = +foldSubmap = foldSubmapBy (<>) mempty + +foldSubmapBy :: forall k v m. Ord k => (m -> m -> m) -> m -> Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m +foldSubmapBy appendFn memptyValue kmin kmax f = let tooSmall = case kmin of @@ -367,17 +372,17 @@ foldSubmap kmin kmax f = -- function because of strictness. go = case _ of Leaf -> - mempty + memptyValue Two left k v right -> - (if tooSmall k then mempty else go left) - <> (if inBounds k then f k v else mempty) - <> (if tooLarge k then mempty else go right) + (if tooSmall k then memptyValue else go left) + `appendFn` (if inBounds k then f k v else memptyValue) + `appendFn` (if tooLarge k then memptyValue else go right) Three left k1 v1 mid k2 v2 right -> - (if tooSmall k1 then mempty else go left) - <> (if inBounds k1 then f k1 v1 else mempty) - <> (if tooSmall k2 || tooLarge k1 then mempty else go mid) - <> (if inBounds k2 then f k2 v2 else mempty) - <> (if tooLarge k2 then mempty else go right) + (if tooSmall k1 then memptyValue else go left) + `appendFn` (if inBounds k1 then f k1 v1 else memptyValue) + `appendFn` (if tooSmall k2 || tooLarge k1 then memptyValue else go mid) + `appendFn` (if inBounds k2 then f k2 v2 else memptyValue) + `appendFn` (if tooLarge k2 then memptyValue else go right) in go @@ -408,7 +413,7 @@ foldSubmap kmin kmax f = -- | else not (member key m') -- | ``` submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v -submap kmin kmax = foldSubmap kmin kmax singleton +submap kmin kmax = foldSubmapBy union empty kmin kmax singleton -- | Test if a key is a member of a map member :: forall k v. Ord k => k -> Map k v -> Boolean diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index b203666..34da8df 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -14,6 +14,8 @@ import Data.List.NonEmpty as NEL import Data.Map as M import Data.Map.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Semigroup.First (First(..)) +import Data.Semigroup.Last (Last(..)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) import Effect.Console (log) @@ -162,7 +164,7 @@ mapTests = do log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)" quickCheck $ \(list :: List (Tuple SmallKey Int)) -> - let nubbedList = nubBy ((==) `on` fst) list + let nubbedList = nubBy (compare `on` fst) list f x = M.toUnfoldable (M.fromFoldable x) in sort (f nubbedList) == sort nubbedList show nubbedList @@ -254,7 +256,7 @@ mapTests = do log "size" quickCheck $ \xs -> - let xs' = nubBy ((==) `on` fst) xs + let xs' = nubBy (compare `on` fst) xs in M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int)) log "lookupLE result is correct" @@ -399,3 +401,27 @@ mapTests = do let result = M.catMaybes maybeMap let expected = M.delete 1 m result === expected + + log "SemigroupMap's Semigroup instance is based on value's Semigroup instance" + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key leftStr + let right = smSingleton key rightStr + let result = left <> right + let expected = smSingleton key $ leftStr <> rightStr + result == expected + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key $ First leftStr + let right = smSingleton key $ First rightStr + let result = left <> right + result == left + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key $ Last leftStr + let right = smSingleton key $ Last rightStr + let result = left <> right + result == right + +smSingleton :: forall key value. key -> value -> M.SemigroupMap key value +smSingleton k v = M.SemigroupMap (M.singleton k v)