@@ -0,0 +1,151 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE DeriveDataTypeable #-}
8+{-# LANGUAGE StandaloneDeriving #-}
9+
10+-- | This module provides a 'Data.HashMap' variant which uses the value's
11+-- 'Monoid' instance to accumulate conflicting entries when merging
12+-- 'Map's.
13+--
14+-- While some functions mirroring those of 'Data.HashMap' are provided
15+-- here for convenience, more specialized needs will likely want to use
16+-- either the @Newtype@ or @Wrapped@ instances to manipulate the
17+-- underlying 'Map'.
18+
19+module Data.HashMap.Monoidal
20+ ( MonoidalHashMap
21+ -- * Often-needed functions
22+ , singleton
23+ , size
24+ , member
25+ , notMember
26+ , lookup
27+ , elems
28+ , keys
29+ ) where
30+
31+import Prelude hiding (lookup)
32+import Data.Monoid
33+import Data.Foldable (Foldable)
34+import Data.Traversable (Traversable)
35+import Control.Applicative (Applicative, pure)
36+import Data.Data (Data)
37+import Data.Typeable (Typeable)
38+
39+#if MIN_VERSION_base(4,7,0)
40+import GHC.Exts (IsList(..))
41+#endif
42+
43+import Control.DeepSeq
44+import qualified Data.HashMap.Strict as M
45+import Data.Hashable (Hashable)
46+import Control.Lens
47+import Control.Newtype
48+
49+-- | A 'HashMap' with monoidal accumulation
50+newtype MonoidalHashMap k a = MM (M.HashMap k a)
51+ deriving (Show, Read, Functor, Eq, NFData,
52+ Foldable, Traversable,
53+ Data, Typeable)
54+
55+type instance Index (MonoidalHashMap k a) = k
56+type instance IxValue (MonoidalHashMap k a) = a
57+instance (Eq k, Hashable k) => Ixed (MonoidalHashMap k a) where
58+ ix k f (MM m) = case M.lookup k m of
59+ Just v -> f v <&> \v' -> MM (M.insert k v' m)
60+ Nothing -> pure (MM m)
61+ {-# INLINE ix #-}
62+
63+instance (Eq k, Hashable k) => At (MonoidalHashMap k a) where
64+ at k f (MM m) = f mv <&> \r -> case r of
65+ Nothing -> maybe (MM m) (const (MM $ M.delete k m)) mv
66+ Just v' -> MM $ M.insert k v' m
67+ where mv = M.lookup k m
68+ {-# INLINE at #-}
69+
70+instance Each (MonoidalHashMap k a) (MonoidalHashMap k b) a b
71+
72+instance (Eq k, Hashable k) => FunctorWithIndex k (MonoidalHashMap k)
73+instance (Eq k, Hashable k) => FoldableWithIndex k (MonoidalHashMap k)
74+instance (Eq k, Hashable k) => TraversableWithIndex k (MonoidalHashMap k) where
75+ itraverse f (MM m) = fmap MM $ itraverse f m
76+ {-# INLINE itraverse #-}
77+
78+instance AsEmpty (MonoidalHashMap k a) where
79+ _Empty = nearly (MM M.empty) (M.null . unpack)
80+ {-# INLINE _Empty #-}
81+
82+instance Wrapped (MonoidalHashMap k a) where
83+ type Unwrapped (MonoidalHashMap k a) = M.HashMap k a
84+ _Wrapped' = iso unpack pack
85+ {-# INLINE _Wrapped' #-}
86+
87+instance (Eq k, Hashable k, Monoid a) => Monoid (MonoidalHashMap k a) where
88+ mempty = MM mempty
89+ {-# INLINE mempty #-}
90+ MM a `mappend` MM b = MM $ M.unionWith mappend a b
91+ {-# INLINE mappend #-}
92+
93+instance Newtype (MonoidalHashMap k a) (M.HashMap k a) where
94+ pack = MM
95+ {-# INLINE pack #-}
96+ unpack (MM a) = a
97+ {-# INLINE unpack #-}
98+
99+#if MIN_VERSION_base(4,7,0)
100+instance (Eq k, Hashable k) => IsList (MonoidalHashMap k a) where
101+ type Item (MonoidalHashMap k a) = (k, a)
102+ fromList = MM . M.fromList
103+ {-# INLINE fromList #-}
104+ toList = M.toList . unpack
105+ {-# INLINE toList #-}
106+#endif
107+
108+-- | /O(1)/. A map with a single element.
109+singleton :: (Eq k, Hashable k) => k -> a -> MonoidalHashMap k a
110+singleton k a = MM $ M.singleton k a
111+{-# INLINE singleton #-}
112+
113+-- | /O(1)/. The number of elements in the map.
114+size :: MonoidalHashMap k a -> Int
115+size = M.size . unpack
116+{-# INLINE size #-}
117+
118+-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
119+member :: (Eq k, Hashable k) => k -> MonoidalHashMap k a -> Bool
120+member k = M.member k . unpack
121+{-# INLINE member #-}
122+
123+-- | /O(log n)/. Is the key not a member of the map? See also 'member'.
124+notMember :: (Eq k, Hashable k) => k -> MonoidalHashMap k a -> Bool
125+notMember k = not . M.member k . unpack
126+{-# INLINE notMember #-}
127+
128+-- | /O(log n)/ Return the value to which the specified key is mapped,
129+-- or 'Nothing' if this map contains no mapping for the key.
130+lookup :: (Eq k, Hashable k) => k -> MonoidalHashMap k v -> Maybe v
131+lookup k = M.lookup k . unpack
132+{-# INLINE lookup #-}
133+
134+-- | /O(log n)/. Delete a key and its value from the map. When the key is not
135+-- a member of the map, the original map is returned.
136+delete :: (Eq k, Hashable k) => k -> MonoidalHashMap k a -> MonoidalHashMap k a
137+delete k = _Wrapping' MM %~ M.delete k
138+{-# INLINE delete #-}
139+
140+-- | /O(n)/.
141+-- Return all elements of the map in the ascending order of their keys.
142+-- Subject to list fusion.
143+elems :: MonoidalHashMap k a -> [a]
144+elems = M.elems . unpack
145+{-# INLINE elems #-}
146+
147+-- | /O(n)/. Return all keys of the map in ascending order. Subject to list
148+-- fusion.
149+keys :: MonoidalHashMap k a -> [k]
150+keys = M.keys . unpack
151+{-# INLINE keys #-}