diff --git a/Data/EnumMapMap/Base.hs b/Data/EnumMapMap/Base.hs --- a/Data/EnumMapMap/Base.hs +++ b/Data/EnumMapMap/Base.hs @@ -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 diff --git a/Data/EnumMapSet/Base.hs b/Data/EnumMapSet/Base.hs --- a/Data/EnumMapSet/Base.hs +++ b/Data/EnumMapSet/Base.hs @@ -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 diff --git a/enummapmap.cabal b/enummapmap.cabal --- a/enummapmap.cabal +++ b/enummapmap.cabal @@ -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 diff --git a/test/EnumMapMapVsIntMap.hs b/test/EnumMapMapVsIntMap.hs --- a/test/EnumMapMapVsIntMap.hs +++ b/test/EnumMapMapVsIntMap.hs @@ -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 diff --git a/test/EnumMapSetVsIntSet.hs b/test/EnumMapSetVsIntSet.hs --- a/test/EnumMapSetVsIntSet.hs +++ b/test/EnumMapSetVsIntSet.hs @@ -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) diff --git a/test/UnitBoth.hs b/test/UnitBoth.hs --- a/test/UnitBoth.hs +++ b/test/UnitBoth.hs @@ -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 diff --git a/test/UnitEnumMapMap.hs b/test/UnitEnumMapMap.hs --- a/test/UnitEnumMapMap.hs +++ b/test/UnitEnumMapMap.hs @@ -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 diff --git a/test/UnitEnumMapSet.hs b/test/UnitEnumMapSet.hs --- a/test/UnitEnumMapSet.hs +++ b/test/UnitEnumMapSet.hs @@ -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