Drop Semigroup/Monoid instances for Map; add SemigroupMap

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)
 

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)

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

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)