enummapmap 0.6.0 → 0.7.0
raw patch · 8 files changed
+280/−144 lines, 8 filesdep +contravariantdep +lens
Dependencies added: contravariant, lens
Files
- Data/EnumMapMap/Base.hs +74/−27
- Data/EnumMapSet/Base.hs +11/−0
- enummapmap.cabal +8/−1
- test/EnumMapMapVsIntMap.hs +29/−31
- test/EnumMapSetVsIntSet.hs +13/−12
- test/UnitBoth.hs +21/−0
- test/UnitEnumMapMap.hs +114/−73
- test/UnitEnumMapSet.hs +10/−0
Data/EnumMapMap/Base.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE- BangPatterns,- DeriveDataTypeable,- FlexibleContexts,- FlexibleInstances,- GeneralizedNewtypeDeriving,- MagicHash,- MultiParamTypeClasses,- OverlappingInstances,- StandaloneDeriving,- TypeFamilies,- TypeOperators,- UndecidableInstances- #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- |@@ -81,15 +80,23 @@ null, init, head, tail) -import Control.Applicative (Applicative(pure,(<*>)),(<$>))+import Control.Applicative (Applicative(pure,(<*>)), (<$>)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import Data.Default-import qualified Data.Foldable as FOLD+import qualified Data.Foldable as Fold+import Control.Lens.At (At, Contains, IxValue,+ at, contains, containsLookup)+import Control.Lens.Combinators ((<&>))+import Control.Lens.Each (Index, Each, each)+import qualified Control.Lens.Fold as Lens+import Control.Lens.Getter (Contravariant)+import qualified Control.Lens.Indexed as Lens+import qualified Control.Lens.Setter as Lens import Data.Maybe (fromMaybe) import Data.SafeCopy import Data.Semigroup-import Data.Traversable (Traversable(traverse))+import Data.Traversable (Traversable(traverse), sequenceA) import Data.Typeable import GHC.Exts (Word(..), Int(..), uncheckedShiftRL#, uncheckedShiftL#)@@ -452,7 +459,7 @@ SubKey (k :& t1) (k :& t2) v where type Result (k :& t1) (k :& t2) v = Result t1 t2 v - member !(key' :& nxt) (KCC emm) = key `seq` go emm+ member (key' :& nxt) (KCC emm) = key `seq` go emm where go t = case t of Bin _ m l r -> case zero key m of@@ -466,7 +473,7 @@ singleton (key :& nxt) = KCC . Tip (fromEnum key) . singleton nxt - lookup !(key' :& nxt) (KCC emm) = key `seq` go emm+ lookup (key' :& nxt) (KCC emm) = key `seq` go emm where go (Bin _ m l r) | zero key m = go l@@ -486,7 +493,7 @@ where go = insertWithKey (\_ -> f k) nxt val - delete !(key :& nxt) (KCC emm) =+ delete (key :& nxt) (KCC emm) = KCC $ alter_ (delete nxt) (fromEnum key) emm instance (Enum k, IsKey t1, IsKey t2, SubKeyS t1 t2) =>@@ -827,21 +834,21 @@ -- Foldable -instance (FOLD.Foldable (EnumMapMap t), Enum k, Eq k, IsKey t, HasSKey t) =>- FOLD.Foldable (EnumMapMap (k :& t)) where+instance (Fold.Foldable (EnumMapMap t), Enum k, Eq k, IsKey t, HasSKey t) =>+ Fold.Foldable (EnumMapMap (k :& t)) where fold (KCC emm) = go emm where go Nil = mempty- go (Tip _ v) = FOLD.fold v+ go (Tip _ v) = Fold.fold v go (Bin _ _ l r) = go l `mappend` go r foldr = foldr foldMap f (KCC emm) = go emm where go Nil = mempty- go (Tip _ v) = FOLD.foldMap f v+ go (Tip _ v) = Fold.foldMap f v go (Bin _ _ l r) = go l `mappend` go r -instance (IsKey k, FOLD.Foldable (EnumMapMap k)) =>+instance (IsKey k, Fold.Foldable (EnumMapMap k)) => Traversable (EnumMapMap k) where traverse f = traverseWithKey (\_ -> f) @@ -867,8 +874,6 @@ safePut b errorTypeName _ = "(:&)" --- We only define this for (k :& t) here because the more general version--- causes overlaps between EnumMapMap and EnumMapSet. instance (SafeCopy k, SafeCopy (NestedPair k v), IsKey k, Result k k v ~ v, SubKey k k v, MkNestedPair k v) =>@@ -876,6 +881,48 @@ getCopy = contain $ fmap fromNestedPairList safeGet putCopy = contain . safePut . toNestedPairList errorTypeName _ = "EnumMapMap"++-- Control.Lens++type instance Index (EnumMapMap k v) = k++instance (Applicative f,+ Fold.Foldable (EnumMapMap k),+ IsKey (Index (EnumMapMap k a)),+ IsKey (Index (EnumMapMap k b))) =>+ Each f (EnumMapMap k a) (EnumMapMap k b) a b where+ each f m = sequenceA $ mapWithKey f' m+ where f' = Lens.indexed f++instance (Contravariant f, Functor f, IsKey k, SubKey k k v) =>+ Contains f (EnumMapMap k v) where+ contains = containsLookup lookup+ {-# INLINE contains #-}++type instance IxValue (EnumMapMap k v) = Result k k v++instance (IsKey k, SubKey k k v) =>+ At (EnumMapMap k v) where+ at k f m = Lens.indexed f k mv <&>+ \r -> case r of+ Nothing -> maybe m (const (delete k m)) mv+ Just v' -> insert k v' m+ where mv = lookup k m++instance (IsKey k, Fold.Foldable (EnumMapMap k)) =>+ Lens.FunctorWithIndex k (EnumMapMap k) where+ imap = Lens.iover Lens.itraversed+ {-# INLINE imap #-}++instance (IsKey k, Fold.Foldable (EnumMapMap k)) =>+ Lens.FoldableWithIndex k (EnumMapMap k) where+ ifoldMap = Lens.ifoldMapOf Lens.itraversed+ {-# INLINE ifoldMap #-}++instance (IsKey k, Fold.Foldable (EnumMapMap k)) =>+ Lens.TraversableWithIndex k (EnumMapMap k) where+ itraverse = traverseWithKey+ {-# INLINE itraverse #-} {-------------------------------------------------------------------- Nat conversion
Data/EnumMapSet/Base.hs view
@@ -73,6 +73,9 @@ import Prelude hiding (lookup, map, filter, foldr, foldl, null, init, head, tail, all) +import Control.Lens.At (Contains, contains)+import Control.Lens.Combinators ((<&>))+import qualified Control.Lens.Indexed as Lens import Data.Bits import qualified Data.List as List import Data.Maybe (fromMaybe)@@ -525,6 +528,14 @@ getCopy = contain $ fmap fromList safeGet putCopy = contain . safePut . toList errorTypeName _ = "EnumMapSet"++-- Lens++instance (Functor f, EMM.IsKey k, EMM.SubKey k k (), EMM.Result k k () ~ ()) =>+ Contains f (EnumMapSet k) where+ contains k f s = Lens.indexed f k (member k s) <&> \b ->+ if b then insert k s else delete k s+ {-# INLINE contains #-} {--------------------------------------------------------------------- Helper functions
enummapmap.cabal view
@@ -1,5 +1,5 @@ name: enummapmap-version: 0.6.0+version: 0.7.0 synopsis: Map of maps using Enum types as keys description: This package provides 'maps of maps' using Enum types as keys. The code is based upon Data.IntMap in@@ -22,9 +22,11 @@ Data.EnumMapSet other-modules: Data.EnumMapMap.Base, Data.EnumMapSet.Base build-depends: base >= 4.0 && < 5,+ contravariant >= 0.4.4, data-default, deepseq >= 1.2 && < 1.4, ghc-prim,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, semigroups >= 0.8 ghc-options: -Wall -O2@@ -43,6 +45,7 @@ hspec-expectations, cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, semigroups >= 0.8, enummapmap@@ -77,6 +80,7 @@ hspec-expectations, cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, semigroups >= 0.8, enummapmap@@ -111,6 +115,7 @@ hspec-expectations, cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, containers >= 0.4.2, enummapmap@@ -144,6 +149,7 @@ cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, enummapmap@@ -163,6 +169,7 @@ cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ lens >= 3.10 && < 4, safecopy >= 0.8 && < 0.9, enummapmap
test/EnumMapMapVsIntMap.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This uses QuickCheck to try to check that an 'EnumMapMap' -- behaves in the same way as an 'IntMap'. It checks up to 4 levels of@@ -11,6 +12,7 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ((==>)) +import Control.Arrow (first) import Control.Monad(liftM) import qualified Data.IntSet as IS import Data.EnumMapSet (S(..))@@ -42,7 +44,7 @@ -- type TestSet4 = EnumMapSet (Int :& Int :& Int :& S Int) list2l1 :: [(Int, Int)] -> [(K Int, Int)]-list2l1 = map (\(a, b) -> (K a, b))+list2l1 = map $ first K list2l2 :: Int -> [(Int, Int)] -> [(Int :& K Int, Int)] list2l2 k1 = map (\(a, b) -> (a :& K k1, b))@@ -82,7 +84,7 @@ -> [(Int, Int)] -> Bool runProp f g list =- (f $ IM.fromList list) == (g $ EMM.fromList $ list2l1 list)+ f (IM.fromList list) == g (EMM.fromList $ list2l1 list) runPropDuo :: Eq t => (IM.IntMap Int -> IM.IntMap Int -> t)@@ -91,8 +93,8 @@ -> [(Int, Int)] -> Bool runPropDuo f g list1 list2 =- (f (IM.fromList list1) $ IM.fromList list2)- == (g (EMM.fromList $ list2l1 list1) $ EMM.fromList $ list2l1 list2)+ f (IM.fromList list1) (IM.fromList list2) ==+ g (EMM.fromList $ list2l1 list1) (EMM.fromList $ list2l1 list2) runProp2 :: Eq t => (IM.IntMap Int -> t)@@ -101,7 +103,7 @@ -> [(Int, Int)] -> Bool runProp2 f g k1 list =- (f $ IM.fromList list) == (g $ EMM.fromList $ list2l2 k1 list)+ f (IM.fromList list) == g (EMM.fromList $ list2l2 k1 list) runPropDuo2 :: Eq t => (IM.IntMap Int -> IM.IntMap Int -> t)@@ -111,9 +113,9 @@ -> [(Int, Int)] -> Bool runPropDuo2 f g k1 list1 list2 =- (f (IM.fromList list1) $ IM.fromList list2)- == (g (EMM.fromList $ list2l2 k1 list1) $- EMM.fromList $ list2l2 k1 list2)+ f (IM.fromList list1) (IM.fromList list2)+ == g (EMM.fromList $ list2l2 k1 list1)+ (EMM.fromList $ list2l2 k1 list2) runProp3 :: Eq t => (IM.IntMap Int -> t)@@ -123,7 +125,7 @@ -> [(Int, Int)] -> Bool runProp3 f g k1 k2 list =- (f $ IM.fromList list) == (g $ EMM.fromList $ list2l3 k1 k2 list)+ f (IM.fromList list) == g (EMM.fromList $ list2l3 k1 k2 list) runPropDuo3 :: Eq t => (IM.IntMap Int -> IM.IntMap Int -> t)@@ -134,9 +136,9 @@ -> [(Int, Int)] -> Bool runPropDuo3 f g k1 k2 list1 list2 =- (f (IM.fromList list1) $ IM.fromList list2)- == (g (EMM.fromList $ list2l3 k1 k2 list1) $- EMM.fromList $ list2l3 k1 k2 list2)+ f (IM.fromList list1) (IM.fromList list2)+ == g (EMM.fromList $ list2l3 k1 k2 list1)+ (EMM.fromList $ list2l3 k1 k2 list2) runProp4 :: Eq t => (IM.IntMap Int -> t)@@ -147,7 +149,7 @@ -> [(Int, Int)] -> Bool runProp4 f g k1 k2 k3 list =- (f $ IM.fromList list) == (g $ EMM.fromList $ list2l4 k1 k2 k3 list)+ f (IM.fromList list) == g (EMM.fromList $ list2l4 k1 k2 k3 list) runPropDuo4 :: Eq t => (IM.IntMap Int -> IM.IntMap Int -> t)@@ -159,9 +161,9 @@ -> [(Int, Int)] -> Bool runPropDuo4 f g k1 k2 k3 list1 list2 =- (f (IM.fromList list1) $ IM.fromList list2)- == (g (EMM.fromList $ list2l4 k1 k2 k3 list1) $- EMM.fromList $ list2l4 k1 k2 k3 list2)+ f (IM.fromList list1) (IM.fromList list2)+ == g (EMM.fromList $ list2l4 k1 k2 k3 list1)+ (EMM.fromList $ list2l4 k1 k2 k3 list2) -- | Run functions on an 'IntMap' and an 'EnumMapMap' created from 'list' and check -- that the resulting 'IntMap' and 'EnumMapMap' are equal@@ -361,12 +363,8 @@ describe "alter" $ do let f b n v = case v of- Just v' -> case b of- True -> Just v'- False -> Nothing- Nothing -> case b of- True -> Just n- False -> Nothing+ Just v' -> if b then Just v' else Nothing+ Nothing -> if b then Just n else Nothing prop "Level 1" $ \i b n -> runPropL (IM.alter (f b n) i) $ EMM.alter (f b n) (K i)@@ -386,7 +384,7 @@ runProp3 (IM.foldr (:) []) (EMM.foldr (:) []) describe "foldrWithKey" $ do- let f a b c = [a + b] ++ c+ let f a b c = a + b :c prop "Level 1" $ runProp (IM.foldrWithKey f []) (EMM.foldrWithKey (\(K k) -> f k) [])@@ -472,10 +470,10 @@ describe "findMin" $ do let go f (a, b) = (f a, b) prop "Level 1" $ \list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp IM.findMin (go unKey1 . EMM.findMin) list prop "Level 2" $ \k1 list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp2 IM.findMin (go unKey2 . EMM.findMin) k1 list prop "Level 3" $ \k1 k2 list -> (not $ L.null list) ==>@@ -508,19 +506,19 @@ goi _ Nothing = Nothing goi f (Just ((k, v), im)) = Just ((k, v), f $ IM.toList im) prop "Level 1" $ \list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp (goi list2l1 . IM.minViewWithKey) (goe unKey1 . EMM.minViewWithKey) list prop "Level 2" $ \k1 list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp2 (goi (list2l2 k1) . IM.minViewWithKey) (goe unKey2 . EMM.minViewWithKey) k1 list prop "Level 3" $ \k1 k2 list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp3 (goi (list2l3 k1 k2) . IM.minViewWithKey) (goe unKey3 . EMM.minViewWithKey) k1 k2 list prop "Level 4" $ \k1 k2 k3 list ->- (not $ L.null list) ==>+ not (L.null list) ==> runProp4 (goi (list2l4 k1 k2 k3) . IM.minViewWithKey) (goe unKey4 . EMM.minViewWithKey) k1 k2 k3 list
test/EnumMapSetVsIntSet.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This uses QuickCheck to try to check that an 'EnumMapSet'@@ -40,7 +41,7 @@ -> [Int] -> Bool runProp f g list =- (f $ IS.fromList list) == (g $ EMS.fromList $ list2l1 list)+ f (IS.fromList list) == g (EMS.fromList $ list2l1 list) runPropDuo1 :: Eq t => (IS.IntSet -> IS.IntSet -> t)@@ -49,8 +50,8 @@ -> [Int] -> Bool runPropDuo1 f g list1 list2- = (f (IS.fromList list1) $ IS.fromList list2)- == (g (EMS.fromList $ list2l1 list1) $ EMS.fromList $ list2l1 list2)+ = f (IS.fromList list1) (IS.fromList list2)+ == g (EMS.fromList $ list2l1 list1) (EMS.fromList $ list2l1 list2) runProp2 :: Eq t => (IS.IntSet -> t)@@ -59,7 +60,7 @@ -> [Int] -> Bool runProp2 f g k1 list- = (f $ IS.fromList list) == (g $ EMS.fromList $ list2l2 k1 list)+ = f (IS.fromList list) == g (EMS.fromList $ list2l2 k1 list) runPropDuo2 :: Eq t => (IS.IntSet -> IS.IntSet -> t)@@ -69,9 +70,9 @@ -> [Int] -> Bool runPropDuo2 f g k1 list1 list2- = (f (IS.fromList list1) $ IS.fromList list2)- == (g (EMS.fromList $ list2l2 k1 list1) $- EMS.fromList $ list2l2 k1 list2)+ = f (IS.fromList list1) (IS.fromList list2)+ == g (EMS.fromList $ list2l2 k1 list1)+ (EMS.fromList $ list2l2 k1 list2) runProp3 :: Eq t => (IS.IntSet -> t)@@ -80,7 +81,7 @@ -> [Int] -> Bool runProp3 f g k1 k2 list- = (f $ IS.fromList list) == (g $ EMS.fromList $ list2l3 k1 k2 list)+ = f (IS.fromList list) == g (EMS.fromList $ list2l3 k1 k2 list) runPropDuo3 :: Eq t => (IS.IntSet -> IS.IntSet -> t)@@ -90,9 +91,9 @@ -> [Int] -> Bool runPropDuo3 f g k1 k2 list1 list2- = (f (IS.fromList list1) $ IS.fromList list2)- == (g (EMS.fromList $ list2l3 k1 k2 list1) $- EMS.fromList $ list2l3 k1 k2 list2)+ = f (IS.fromList list1) (IS.fromList list2)+ == g (EMS.fromList $ list2l3 k1 k2 list1)+ (EMS.fromList $ list2l3 k1 k2 list2) runPropL :: (IS.IntSet -> IS.IntSet) -> (TestSet1 -> TestSet1)
test/UnitBoth.hs view
@@ -14,6 +14,7 @@ import Test.Hspec import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf) +import Control.Lens ((^.), at, contains) import Control.Monad (liftM, liftM2) import Data.SafeCopy import Data.Serialize.Get (runGet)@@ -74,10 +75,30 @@ testEq emm = op == Right emm where op = runGet safeGet $ runPut $ safePut emm+ prop "Leaves data intact" testEq+ describe "EnumMapSet SafeCopy Instance" $ do let testEq :: TestEms2 -> Bool testEq ems = op == Right ems where op = runGet safeGet $ runPut $ safePut ems+ prop "Leaves data intact" testEq++ describe "EnumMapSet Lens" $ do+ let testContains2 :: ID1 -> ID2 -> TestEms2 -> Bool+ testContains2 i1 i2 ems = EMS.member (i2 :& S i1) ems ==+ ems ^.contains (i2 :& S i1)+ prop "Contains works, Level 2" testContains2++ describe "EnumMapMap Lens instance" $ do+ let testAt2 :: ID1 -> ID2 -> TestEmm2 -> Bool+ testAt2 i1 i2 emm =+ emm ^.at (i2 :& K i1) == EMM.lookup (i2 :& K i1) emm+ testContains2 :: ID1 -> ID2 -> TestEmm2 -> Bool+ testContains2 i1 i2 emm =+ emm ^.contains (i2 :& K i1) == EMM.member (i2 :& K i1) emm+ prop "Lens.At instance returns same result as lookup Level 2" testAt2+ prop "Lens.Contains instance returns same result as member Level 2"+ testContains2
test/UnitEnumMapMap.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE- CPP,- DeriveDataTypeable,- FlexibleContexts,- FlexibleInstances,- GeneralizedNewtypeDeriving,- ScopedTypeVariables,- TypeFamilies,- TypeOperators,- UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} +import Control.Arrow (first)+import Control.Lens ((^.), at, contains, iall, imap) import Control.Exception import Control.Monad (liftM, liftM2) import qualified Data.Foldable as Foldable@@ -93,9 +94,9 @@ alls = [1, 2..1000] l1tens :: EnumMapMap I Int-l1tens = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip [1..7] tens+l1tens = EMM.fromList $ map (first K) $ zip [1..7] tens l1IDtens :: TestEmm1-l1IDtens = EMM.fromList $ map (\(key, v) -> (K $ ID1 key, v)) $ zip [1..7] tens+l1IDtens = EMM.fromList $ map (first (K . ID1)) $ zip [1..7] tens l2tens :: EnumMapMap (Int :& I) Int l2tens = EMM.fromList $ zip (do k1 <- [1, 2]@@ -103,16 +104,16 @@ return $ k1 :& K k2) $ cycle tens l1odds :: EnumMapMap (K Int) Int-l1odds = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip odds odds+l1odds = EMM.fromList $ map (first K) $ zip odds odds l1fewOdds :: EnumMapMap (K Int) Int-l1fewOdds = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip fewOdds fewOdds+l1fewOdds = EMM.fromList $ map (first K) $ zip fewOdds fewOdds l2odds :: EnumMapMap (Int :& K Int) Int l2odds = EMM.fromList $ zip (do k1 <- fewOdds k2 <- fewOdds return $ k1 :& K k2) $ cycle odds l1evens :: EnumMapMap (K Int) Int-l1evens = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip evens evens+l1evens = EMM.fromList $ map (first K) $ zip evens evens l1alls :: EnumMapMap (K Int) Int l1alls = EMM.fromList $ zip (map K alls) alls@@ -122,7 +123,7 @@ -> [(TestKey3, Int)] -> Bool checkSubs f l1 l2 =- False == (EMM.emptySubTrees $ f emm1 emm2)+ not $ EMM.emptySubTrees (f emm1 emm2) where emm1 = EMM.fromList l1 emm2 = EMM.fromList l2@@ -131,7 +132,7 @@ -> [(TestKey3, Int)] -> Bool checkSubs1 f l1 =- False == (EMM.emptySubTrees $ f emm1)+ not $ EMM.emptySubTrees (f emm1) where emm1 = EMM.fromList l1 @@ -140,15 +141,15 @@ hspec $ do describe "empty" $ do it "creates an empty EnumMapMap" $- (EMM.null $ (EMM.empty :: EnumMapMap (Int :& Int :& K Int) Bool))+ EMM.null (EMM.empty :: EnumMapMap (Int :& Int :& K Int) Bool) it "has a size of 0" $- 0 @=? (EMM.size $ (EMM.empty :: EnumMapMap (Int :& K Int) Bool))+ 0 @=? EMM.size (EMM.empty :: EnumMapMap (Int :& K Int) Bool) describe "fromList" $ do it "is the inverse of toList on 1 level" $- (EMM.fromList $ EMM.toList l1odds) @?= l1odds+ EMM.fromList (EMM.toList l1odds) @?= l1odds it "is the inverse of toList on 2 levels" $- (EMM.fromList $ EMM.toList l2odds) @?= l2odds+ EMM.fromList (EMM.toList l2odds) @?= l2odds describe "lookup" $ do let emm3 :: TestEmm3@@ -162,24 +163,23 @@ key2 :: ID3 :& K ID2 key2 = ID3 1 :& (K $ ID2 2) it "First level of level 2" $- (EMM.lookup (K 1) emm2) @?= (Just $ EMM.fromList [(K 2, 5)])+ EMM.lookup (K 1) emm2 @?= Just (EMM.fromList [(K 2, 5)]) it "1 level of level 3" $- (EMM.lookup key1 emm3) @?= (Just $- EMM.fromList [(ID2 2 :& (K $ ID1 3), 4)])+ EMM.lookup key1 emm3 @?= Just (EMM.fromList [(ID2 2 :& (K $ ID1 3), 4)]) it "2 levels of level 3" $- (EMM.lookup key2 emm3) @?= (Just $ EMM.fromList [(K $ ID1 3, 4)])+ EMM.lookup key2 emm3 @?= Just (EMM.fromList [(K $ ID1 3, 4)]) it "looks up a value" $- (EMM.lookup key3 emm3) @?= Just 4+ EMM.lookup key3 emm3 @?= Just 4 describe "singleton" $ do let emm2 :: EnumMapMap (ID1 :& K ID2) String emm2 = EMM.fromList [(ID1 1 :& (K $ ID2 2), "a")] it "creates an EnumMapMap with one value" $- (EMM.singleton (ID1 1 :& (K $ ID2 2)) "a") @?= emm2+ EMM.singleton (ID1 1 :& (K $ ID2 2)) "a" @?= emm2 it "creates an EnumMapMap with a sub EnumMapMap" $- (EMM.singleton (K $ ID1 1) $ EMM.singleton (K $ ID2 2) "a") @?= emm2+ EMM.singleton (K $ ID1 1) (EMM.singleton (K $ ID2 2) "a") @?= emm2 - describe "insert" $ do+ describe "insert" $ describe "Level 1" $ do it "creates a value in an empty EMM" $ EMM.insert (k 1) 1 EMM.empty @?=@@ -277,141 +277,143 @@ EMM.insertWithKey f (2 :& k 4) 3 emm @?= EMM.fromList [((2 :: Int) :& K 3, 1), ((2 :: Int) :& K 4, 48)] - describe "delete" $ do+ describe "delete" $ describe "leaves no empty subtrees" $ do prop "Full key" $ \(key :: ID3 :& ID2 :& K ID1) l ->- not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)+ not $ EMM.emptySubTrees $ EMM.delete key (EMM.fromList l :: TestEmm3) prop "2 dimensional key" $ \(key :: ID3 :& K ID2) l ->- not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)+ not $ EMM.emptySubTrees $ EMM.delete key (EMM.fromList l :: TestEmm3) prop "1 dimensional key" $ \(key :: K ID3) l ->- not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)+ not $ EMM.emptySubTrees $ EMM.delete key (EMM.fromList l :: TestEmm3) describe "alter" $ do let f b1 b2 n v = case v of Nothing -> if b1 then Just n else Nothing- Just v' -> case b1 of- True -> Just $ if b2 then v' else n- False -> Nothing+ Just v' -> if b1+ then Just $ if b2 then v' else n+ else Nothing prop "leaves no empty subtrees" $ \key l b1 b2 n ->- not $ EMM.emptySubTrees $ EMM.alter (f b1 b2 n) key $+ not $ EMM.emptySubTrees $ EMM.alter (f b1 b2 n) key (EMM.fromList l :: TestEmm3) describe "foldrWithKey" $ do describe "Level 1" $ do it "folds across all values in an EnumMapMap" $- EMM.foldrWithKey (\_ -> (+)) 0 l1tens @?= 1111111+ EMM.foldrWithKey (const (+)) 0 l1tens @?= 1111111 it "folds across all keys in an EnumMapMap" $ EMM.foldrWithKey (\(K k1) _ -> (+) k1) 0 l1tens @?= 28 describe "Level 2" $ do it "folds across all values in an EnumMapMap" $- EMM.foldrWithKey (\_ -> (+)) 0 l2tens @?= 2222222+ EMM.foldrWithKey (const (+)) 0 l2tens @?= 2222222 it "folds across all keys in an EnumMapMap" $ EMM.foldrWithKey (\(k1 :& K k2) _ -> (+) (k1 * k2)) 0 l2tens @?= 84 describe "mapMaybe" $ do let f v- | v > 2 = Just $ v+ | v > 2 = Just v | otherwise = Nothing prop "No empty subtrees" $ checkSubs1 (EMM.mapMaybe f) describe "mapMaybeWithKey" $ do let f _ v- | v > 2 = Just $ v+ | v > 2 = Just v | otherwise = Nothing prop "No empty subtrees" $ checkSubs1 (EMM.mapMaybeWithKey f) describe "union" $ do- describe "Level 1" $ do+ describe "Level 1" $ it "includes every key from each EnumMapMap" $- (EMM.union l1odds l1evens) @?= l1alls+ EMM.union l1odds l1evens @?= l1alls -- Just in case... prop "Leaves no empty subtrees" $ checkSubs EMM.union - describe "difference" $ do+ describe "difference" $ prop "Leaves no empty subtrees" $ checkSubs EMM.difference describe "differenceWithKey" $ do let f (k1 :& k2 :& K k3) v1 v2 =- Just $ v1 + v2 + (fromEnum k1) + (fromEnum k2) + (fromEnum k3)+ Just $ v1 + v2 + fromEnum k1 + fromEnum k2 + fromEnum k3 prop "Leaves no empty subtrees" $ checkSubs (EMM.differenceWithKey f) - describe "intersection" $ do+ describe "intersection" $ prop "Leaves no empty subtrees" $ checkSubs EMM.intersection describe "intersectionWithKey" $ do let f (k1 :& k2 :& K k3) v1 v2 =- v1 + v2 + (fromEnum k1) + (fromEnum k2) + (fromEnum k3)+ v1 + v2 + fromEnum k1 + fromEnum k2 + fromEnum k3 prop "Leaves no empty subtrees" $ checkSubs (EMM.intersectionWithKey f) describe "joinKey $ splitKey z t == t" $ do let go21 :: [(Int :& K Int, Int)] -> Bool- go21 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d1 emm)+ go21 l = emm == EMM.joinKey (EMM.splitKey EMM.d1 emm) where emm = EMM.fromList l prop "Level 2, depth = 1" go21 let go31 :: [(Int :& Int :& K Int, Int)] -> Bool- go31 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d1 emm)+ go31 l = emm == EMM.joinKey (EMM.splitKey EMM.d1 emm) where emm = EMM.fromList l prop "Level 3, depth = 1" go31 let go32 :: [(Int :& Int :& K Int, Int)] -> Bool- go32 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d2 emm)+ go32 l = emm == EMM.joinKey (EMM.splitKey EMM.d2 emm) where emm = EMM.fromList l prop "Level 3, depth = 2" go32 - describe "keysSet" $ do+ describe "keysSet" $ describe "produces same result as keys" $ do let gol1 :: [(K Int, Int)] -> Bool- gol1 list = EMM.keys emm == (map EMM.toK $ EMS.toList $ EMM.keysSet emm)+ gol1 list = EMM.keys emm == map EMM.toK (EMS.toList $ EMM.keysSet emm) where emm = EMM.fromList list prop "Level 1" gol1 describe "intersectSet" $ do it "leaves correct values" $- (EMM.intersectSet l1odds $ EMS.fromList [s 1, s 2, s 3])- @?= EMM.fromList [(k 1, 1), (k 3, 3)]+ EMM.intersectSet l1odds (EMS.fromList [s 1, s 2, s 3])+ @?= EMM.fromList [(k 1, 1), (k 3, 3)] it "leaves correct subtree" $- (EMM.intersectSet l2odds $ EMS.fromList [s 1])- @?= EMM.fromList [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)]+ EMM.intersectSet l2odds (EMS.fromList [s 1])+ @?= EMM.fromList+ [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)] -- TODO: check for empty subtrees describe "differenceSet" $ do it "works correctly" $- (EMM.differenceSet l1fewOdds $ EMS.fromList [s 3, s 4, s 5])- @?= EMM.fromList [(k 1, 1)]+ EMM.differenceSet l1fewOdds (EMS.fromList [s 3, s 4, s 5])+ @?= EMM.fromList [(k 1, 1)] it "leaves correct subtree" $- (EMM.differenceSet l2odds $ EMS.fromList [s 3, s 4, s 5])- @?= EMM.fromList [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)]+ EMM.differenceSet l2odds (EMS.fromList [s 3, s 4, s 5])+ @?= EMM.fromList+ [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)] - describe "findMin" $ do- it "throws an error when it is passed an empty EnumMapMap" $ do+ describe "findMin" $+ it "throws an error when it is passed an empty EnumMapMap" $ evaluate (EMM.findMin (EMM.empty :: EnumMapMap (K Int) Int)) `shouldThrow` anyErrorCall - describe "deleteFindMin" $ do- it "throws an error when it is passed an empty EnumMapMap" $ do+ describe "deleteFindMin" $+ it "throws an error when it is passed an empty EnumMapMap" $ evaluate (EMM.deleteFindMin (EMM.empty :: EnumMapMap (K Int) Int)) `shouldThrow` anyErrorCall describe "Monoid/Semigroup instances" $ do let uvsm :: TestEmm3 -> TestEmm3 -> Bool uvsm emm1 emm2 =- ((EMM.map Sum emm1) <> (EMM.map Sum emm2)) ==- ( EMM.map Sum $ EMM.unionWith (+) emm1 emm2)+ (EMM.map Sum emm1 <> EMM.map Sum emm2) ==+ EMM.map Sum (EMM.unionWith (+) emm1 emm2) prop "mappend works like unionWith mappend" uvsm let lvsi :: TestEmm3 -> TestEmm3 -> Bool lvsi emm1 emm2- = ((EMM.map First emm1) <> (EMM.map First emm2)) ==- (EMM.map First $ EMM.union emm1 emm2)+ = (EMM.map First emm1 <> EMM.map First emm2) ==+ EMM.map First (emm1 `EMM.union` emm2) prop "(<>) First works like union" lvsi let bvsu :: [TestEmm2B] -> Bool bvsu emms =- (mconcat $ map (EMM.map All) emms) ==- (EMM.map All $ EMM.unionsWith (&&) emms)+ mconcat (map (EMM.map All) emms) ==+ EMM.map All (EMM.unionsWith (&&) emms) prop "unionsWith (&&) works like mconcat All" bvsu describe "Foldable instance" $ do@@ -432,9 +434,9 @@ describe "Typeable Instance" $ do it "TypeOf is unique when ID types differ" $- ((typeOf l1IDtens) == (typeOf l1tens)) @?= False+ (typeOf l1IDtens == typeOf l1tens) @?= False it "TypeOf is unique when different levels" $- ((typeOf l2tens) == (typeOf l1tens)) @?= False+ (typeOf l2tens == typeOf l1tens) @?= False describe "SafeCopy instance" $ do let testEq :: TestEmm3 -> Bool@@ -442,3 +444,42 @@ where op = runGet safeGet $ runPut $ safePut emm prop "Leaves data intact" testEq++ describe "Lens instances" $ do+ let testAt1 :: ID1 -> TestEmm1 -> Bool+ testAt1 i emm = emm ^.at (K i) == EMM.lookup (K i) emm++ testAt2 :: ID1 -> ID2 -> TestEmm2 -> Bool+ testAt2 i1 i2 emm =+ emm ^.at (i2 :& K i1) == EMM.lookup (i2 :& K i1) emm++ testContains1 :: ID1 -> TestEmm1 -> Bool+ testContains1 i emm = emm ^.contains (K i) == EMM.member (K i) emm++ testContains2 :: ID1 -> ID2 -> TestEmm2 -> Bool+ testContains2 i1 i2 emm =+ emm ^.contains (i2 :& K i1) == EMM.member (i2 :& K i1) emm++ testImap1 :: TestEmm1 -> Bool+ testImap1 emm = EMM.mapWithKey g emm == imap g emm+ where+ g (K (ID1 k1)) v = k1 + v++ testImap2 :: TestEmm2 -> Bool+ testImap2 emm = EMM.mapWithKey g emm == imap g emm+ where+ g (ID2 k2 :& K (ID1 k1)) v = k2 + k1 + v++ testIall :: TestEmm1 -> Bool+ testIall emm = Foldable.all (\(K (ID1 k1)) -> k1 > 0) (EMM.keys emm) ==+ iall (\(K (ID1 k1)) _ -> k1 > 0) emm++ prop "Lens.At instance returns same result as lookup Level 1" testAt1+ prop "Lens.At instance returns same result as lookup Level 2" testAt2+ prop "Lens.Contains instance returns same result as member Level 1"+ testContains1+ prop "Lens.Contains instance returns same result as member Level 2"+ testContains2+ prop "Lens.FunctorWithIndex Level 1" testImap1+ prop "Lens.FunctorWithIndex Level 2" testImap2+ prop "Lens.FoldableWithIndex Level 1" testIall
test/UnitEnumMapSet.hs view
@@ -16,6 +16,7 @@ import Test.HUnit import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf) +import Control.Lens ((^.), contains) import Control.Monad (liftM, liftM2) import qualified Data.List as List import Data.SafeCopy@@ -103,3 +104,12 @@ where op = runGet safeGet $ runPut $ safePut ems prop "Leaves data intact" testEq++ describe "Lens" $ do+ let testContains1 :: ID1 -> TestEms1 -> Bool+ testContains1 i ems = EMS.member (S i) ems == ems ^.contains (S i)+ let testContains2 :: ID1 -> ID2 -> TestEms2 -> Bool+ testContains2 i1 i2 ems = EMS.member (i2 :& S i1) ems ==+ ems ^.contains (i2 :& S i1)+ prop "Contains works, Level 1" testContains1+ prop "Contains works, Level 2" testContains2