@@ -0,0 +1,57 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE DeriveDataTypeable #-}
7+
8+module Data.Map.Monoidal ( MonoidalMap ) where
9+
10+import Data.Monoid
11+import Data.Foldable (Foldable)
12+import Data.Traversable (Traversable)
13+import Control.Applicative (Applicative, pure)
14+import Data.Data (Data)
15+import Data.Typeable (Typeable)
16+
17+#if MIN_VERSION_base(4,7,0)
18+import GHC.Exts (IsList(..))
19+#endif
20+
21+import Control.DeepSeq
22+import qualified Data.Map as M
23+import Control.Lens
24+import Control.Newtype
25+
26+-- | A 'Map' with monoidal accumulation
27+newtype MonoidalMap k a = MM (M.Map k a)
28+ deriving (Show, Read, Functor, Eq, Ord, NFData,
29+ Foldable, Traversable,
30+ Data, Typeable)
31+
32+type instance Index (MonoidalMap k a) = k
33+type instance IxValue (MonoidalMap k a) = a
34+instance Ord k => Ixed (MonoidalMap k a) where
35+ ix k f (MM m) = case M.lookup k m of
36+ Just v -> f v <&> \v' -> MM (M.insert k v' m)
37+ Nothing -> pure (MM m)
38+ {-# INLINE ix #-}
39+
40+instance (Ord k, Monoid a) => Monoid (MonoidalMap k a) where
41+ mempty = MM mempty
42+ {-# INLINE mempty #-}
43+ MM a `mappend` MM b = MM $ M.unionWith mappend a b
44+ {-# INLINE mappend #-}
45+
46+instance Newtype (MonoidalMap k a) (M.Map k a) where
47+ pack = MM
48+ {-# INLINE pack #-}
49+ unpack (MM a) = a
50+ {-# INLINE unpack #-}
51+
52+#if MIN_VERSION_base(4,7,0)
53+instance Ord k => IsList (MonoidalMap k a) where
54+ type Item (MonoidalMap k a) = (k, a)
55+ fromList = MM . M.fromList
56+ toList = M.toList . unpack
57+#endif