diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,8 @@ ## Unreleased changes +## 0.1.5 + ## 0.1.4 ## 0.1.3 diff --git a/appendmap.cabal b/appendmap.cabal --- a/appendmap.cabal +++ b/appendmap.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: da3c92d32d8763def130a63fd3d7770833e6f5a30a50b0a56e8d011019a440ec +-- hash: 3bb3e55562b1f29834565ea4cbe850f15c1e6069067b7876d0a414c62e1da4b7 name: appendmap -version: 0.1.4 +version: 0.1.5 synopsis: Map with a Semigroup and Monoid instances delegating to Semigroup of the elements description: Please see the README on GitHub at category: Data Structures @@ -50,7 +50,8 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - appendmap + QuickCheck + , appendmap , base >=4.7 && <5 , containers , hspec diff --git a/src/Data/Map/Append/Lazy.hs b/src/Data/Map/Append/Lazy.hs --- a/src/Data/Map/Append/Lazy.hs +++ b/src/Data/Map/Append/Lazy.hs @@ -1,16 +1,25 @@ +{-| A wrapper for 'Map' with a 'Semigroup' and 'Monoid' instances that delegate to + the individual keys. +-} module Data.Map.Append.Lazy where -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map import Data.Monoid hiding ((<>)) import Data.Semigroup import qualified Data.List.NonEmpty as NE +-- | Map wrapper with 'Semigroup' and 'Monoid' instances that delegate to the +-- keys. It satisfies the following property: +-- +-- > lookup k (m1 <> m2) === lookup k m1 <> lookup k m2 +-- > where +-- > lookup key = Map.lookup key . unAppendMap newtype AppendMap k v = AppendMap { unAppendMap :: Map k v - } + } deriving (Ord, Eq, Show) instance (Ord k, Semigroup v) => Semigroup (AppendMap k v) where AppendMap a <> AppendMap b = AppendMap $ Map.unionWith (<>) a b diff --git a/src/Data/Map/Append/Strict.hs b/src/Data/Map/Append/Strict.hs --- a/src/Data/Map/Append/Strict.hs +++ b/src/Data/Map/Append/Strict.hs @@ -1,3 +1,6 @@ +{-| A wrapper for 'Map' with a 'Semigroup' and 'Monoid' instances that delegate to + the individual keys. +-} module Data.Map.Append.Strict where import Data.Map.Strict (Map) @@ -8,9 +11,15 @@ import qualified Data.List.NonEmpty as NE +-- | Map wrapper with 'Semigroup' and 'Monoid' instances that delegate to the +-- keys. It satisfies the following property: +-- +-- > lookup k (m1 <> m2) === lookup k m1 <> lookup k m2 +-- > where +-- > lookup key = Map.lookup key . unAppendMap newtype AppendMap k v = AppendMap { unAppendMap :: Map k v - } + } deriving (Ord, Eq, Show) instance (Ord k, Semigroup v) => Semigroup (AppendMap k v) where AppendMap a <> AppendMap b = AppendMap $ Map.unionWith (<>) a b diff --git a/src/Data/Map/Counter.hs b/src/Data/Map/Counter.hs --- a/src/Data/Map/Counter.hs +++ b/src/Data/Map/Counter.hs @@ -1,3 +1,4 @@ +-- | A 'Semigroup'-based counter type. module Data.Map.Counter where import Data.Map.Append.Strict @@ -6,10 +7,16 @@ import Data.Monoid +-- | A 'Semigroup'-based counter type. +-- +-- > let counts = mkCounter 1 <> mkCounter 2 <> mkCounter 1 :: Counter Int +-- > getCounts counts === Map.fromList [(1, 2), (2, 1)] type Counter key = AppendMap key (Sum Int) +-- | Counter that has a single occurrence for a single item. mkCounter :: Ord key => key -> Counter key mkCounter key = AppendMap $ Map.singleton key (Sum 1) +-- | Get counts as a map. getCounts :: Counter key -> Map key Int -getCounts = Map.map getSum . unAppendMap +getCounts = fmap getSum . unAppendMap diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} import qualified Data.Map.Append.Lazy as Lazy import qualified Data.Map.Lazy as Lazy @@ -10,21 +11,31 @@ import qualified Data.Map.Counter as Counter +import Data.Maybe + import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set + import Test.Hspec +import Test.QuickCheck data AppendMap appendmap map = AppendMap - { mapFromList :: [(Int, String)] -> map Int String - , mapEmpty :: map Int String - , appendMap :: forall k v. map k v -> appendmap k v - , unAppendMap :: forall k v. appendmap k v -> map k v + { mapFromList :: !(forall v. [(Int, v)] -> map Int v) + , mapKeys :: !(forall v. map Int v -> Set Int) + , mapLookup :: !(forall v. Int -> map Int v -> Maybe v) + , mapEmpty :: !(map Int String) + , appendMap :: !(forall k v. map k v -> appendmap k v) + , unAppendMap :: !(forall k v. appendmap k v -> map k v) } lazy :: AppendMap Lazy.AppendMap Lazy.Map lazy = AppendMap { mapFromList = Lazy.fromList + , mapKeys = Lazy.keysSet + , mapLookup = Lazy.lookup , mapEmpty = Lazy.empty , appendMap = Lazy.AppendMap , unAppendMap = Lazy.unAppendMap @@ -34,6 +45,8 @@ strict = AppendMap { mapFromList = Strict.fromList + , mapKeys = Strict.keysSet + , mapLookup = Strict.lookup , mapEmpty = Strict.empty , appendMap = Strict.AppendMap , unAppendMap = Strict.unAppendMap @@ -42,6 +55,7 @@ appendMapSpec :: ( Show (map Int String) , Eq (map Int String) + , Arbitrary (map Int String) , Semigroup (appendmap Int String) , Monoid (appendmap Int String) ) @@ -54,6 +68,21 @@ let two = appendMap $ mapFromList [(1, "world"), (3, "again")] unAppendMap (one <> two) `shouldBe` mapFromList [(1, "helloworld"), (2, "goodbye"), (3, "again")] + it "is distributive against mconcat" $ + property $ \(maps :: [map Int String]) -> + let appended = unAppendMap $ mconcat $ map appendMap maps + individuallyAppended = + mapFromList + [ (k, mconcat $ mapMaybe (mapLookup k) maps) + | k <- Set.toList $ Set.unions $ map mapKeys maps + ] + in appended === individuallyAppended + it "is distributive over lookup" $ + property $ \(m1' :: map Int String) (m2' :: map Int String) (k :: Int) -> + let lookup key = mapLookup key . unAppendMap + m1 = appendMap m1' + m2 = appendMap m2' + in lookup k (m1 <> m2) === lookup k m1 <> lookup k m2 counterSpec :: Spec counterSpec =