Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

We’re showing branches in this repository, but you can also compare across forks.

base fork: bovinespirit/enummapmap
base: 00587bfbc4
...
head fork: bovinespirit/enummapmap
compare: 0.5.0
  • 14 commits
  • 11 files changed
  • 0 commit comments
  • 2 contributors
86 Data/EnumMapMap/Base.hs
View
@@ -69,7 +69,10 @@ import Prelude hiding (lookup,
import Control.DeepSeq (NFData(rnf))
import Data.Bits
-import Data.Monoid (Monoid(..))
+import Data.Default
+import qualified Data.Foldable as FOLD
+import Data.Maybe (fromMaybe)
+import Data.Semigroup
import GHC.Exts (Word(..), Int(..),
uncheckedShiftRL#, uncheckedShiftL#)
@@ -326,12 +329,27 @@ class (Eq k) => IsKey k where
-- | Build an 'EnumMapMap' from an 'EnumMapSet' and a function which for each
-- key computes it's value
fromSet :: HasSKey k => (k -> v) -> EnumMapMap (Skey k) () -> EnumMapMap k v
+ -- | The minimal key and value of the 'EnumMapMap'.
+ --
+ -- > findMin empty -- ERROR, no minimal key
+ -- > findMin $ fromList [(K 1, "a", K 3, "b")] == (K 1, a)
+ findMin :: EnumMapMap k v -> (k, v)
+ -- | Retrieves the minimal (key,value) pair of the EnumMapMap, and the
+ -- EnumMapMap stripped of that element, or 'Nothing' if passed an empty map.
+ minViewWithKey :: EnumMapMap k v -> Maybe ((k, v), EnumMapMap k v)
+ deleteFindMin :: EnumMapMap k v -> ((k, v), EnumMapMap k v)
+ deleteFindMin =
+ fromMaybe(error "deleteFindMin: empty EnumMapMap has no minimal\
+ \ element") . minViewWithKey
-- | The (left-biased) union of two 'EnumMapMap's.
-- It prefers the first 'EnumMapMap' when duplicate keys are encountered.
union :: EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v
-- | The union of a list of maps.
unions :: [EnumMapMap k v] -> EnumMapMap k v
unions = foldlStrict union empty
+ -- | The union of a list of maps with a combining function
+ unionsWith :: (v -> v -> v) -> [EnumMapMap k v] -> EnumMapMap k v
+ unionsWith f = foldlStrict (unionWith f) empty
-- | The union with a combining function.
unionWith :: (v -> v -> v)
-> EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v
@@ -426,7 +444,7 @@ instance (Enum k, IsKey t1, IsKey t2, SubKeyS t1 t2) =>
tip k1 $ differenceSet x1 x2
instance (Eq k, Enum k, IsKey t, HasSKey t) => IsKey (k :& t) where
- data EnumMapMap (k :& t) v = KCC (EMM k (EnumMapMap t v))
+ newtype EnumMapMap (k :& t) v = KCC (EMM k (EnumMapMap t v))
emptySubTrees e@(KCC emm) =
case emm of
@@ -480,6 +498,38 @@ instance (Eq k, Enum k, IsKey t, HasSKey t) => IsKey (k :& t) where
where
go k = fromSet (\nxt -> f $! k :& nxt)
+ findMin (KCC emm) =
+ case emm of
+ Nil -> error "findMin: no minimal element"
+ Tip k v -> (toEnum k :& t, v')
+ where (t, v') = findMin v
+ Bin _ m l r
+ | m < 0 -> go r
+ | otherwise -> go l
+ where go (Tip k v) = (toEnum k :& t, v')
+ where (t, v') = findMin v
+ go (Bin _ _ l' _) = go l'
+ go Nil = error "findMin: Nil"
+
+ minViewWithKey (KCC emm) =
+ goat emm >>= \(r, emm') -> return (r, KCC $ emm')
+ where
+ goat t =
+ case t of
+ Nil -> Nothing
+ Bin p m l r | m < 0 ->
+ case go r of
+ (result, r') ->
+ Just (result, binD p m l r')
+ _ -> Just (go t)
+ go (Bin p m l r) = case go l of
+ (result, l') -> (result, binD p m l' r)
+ go (Tip k y) = case minViewWithKey y of
+ Just ((t, v), y') ->
+ (((toEnum k) :& t, v), tip k y')
+ Nothing -> error "minViewWithKey: Nothing"
+ go Nil = error "minViewWithKey Nil"
+
union (KCC emm1) (KCC emm2) = KCC $ mergeWithKey' binD go id id emm1 emm2
where
go = \(Tip k1 x1) (Tip _ x2) -> tip k1 $ union x1 x2
@@ -662,10 +712,17 @@ instance (IsKey k) => Functor (EnumMapMap k)
where
fmap = map
-instance (IsKey k) => Monoid (EnumMapMap k v) where
+-- | This instance differs from the 'Monoid' instance in 'IntMap'. Where the keys
+-- are the same the values are combined using 'mappend'.
+instance (IsKey k, Semigroup v) => Monoid (EnumMapMap k v) where
mempty = empty
- mappend = union
- mconcat = unions
+ mappend = unionWith (<>)
+ mconcat = unionsWith (<>)
+
+instance (IsKey k, Semigroup v) =>
+ Semigroup (EnumMapMap k v) where
+ (<>) = unionWith (<>)
+ times1p _ a = a
instance (Show v, Show (EnumMapMap t v)) => Show (EnumMapMap (k :& t) v) where
show (KCC emm) = show emm
@@ -682,6 +739,23 @@ instance (NFData k, NFData t) => NFData (k :& t)
where
rnf (k :& t) = rnf k `seq` rnf t
+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 (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 (Bin _ _ l r) = go l `mappend` go r
+
+instance (IsKey k) => Default (EnumMapMap k v) where
+ def = empty
+
{--------------------------------------------------------------------
Nat conversion
--------------------------------------------------------------------}
@@ -697,6 +771,8 @@ intFromNat = fromIntegral
shiftRL, shiftLL :: Nat -> Int -> Nat
shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)
shiftLL (W# x) (I# i) = W# (uncheckedShiftL# x i)
+{-# INLINE shiftRL #-}
+{-# INLINE shiftLL #-}
{--------------------------------------------------------------------
Join
48 Data/EnumMapMap/Lazy.hs
View
@@ -34,7 +34,7 @@ module Data.EnumMapMap.Lazy (
emptySubTrees,
-- * Key types
- (:&)(..), K(..),
+ (:&)(..), K(..), IsKey, SubKey, Result,
d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,
-- * Map Type
EnumMapMap,
@@ -59,6 +59,7 @@ module Data.EnumMapMap.Lazy (
unionWith,
unionWithKey,
unions,
+ unionsWith,
-- ** Difference
difference,
differenceWith,
@@ -82,6 +83,10 @@ module Data.EnumMapMap.Lazy (
elems,
keysSet,
fromSet,
+ -- * Min/Max
+ findMin,
+ minViewWithKey,
+ deleteFindMin,
-- * Split/Join Keys
toK,
toS,
@@ -94,6 +99,8 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null,init)
import Control.DeepSeq (NFData(rnf))
import Data.Bits
+import qualified Data.Foldable as FOLD
+import Data.Semigroup
import Data.EnumMapMap.Base
import qualified Data.EnumMapSet.Base as EMS
@@ -107,7 +114,7 @@ newtype K k = K k
deriving (Show, Eq)
instance (Enum k, Eq k) => IsKey (K k) where
- data EnumMapMap (K k) v = KEC (EMM k v)
+ newtype EnumMapMap (K k) v = KEC (EMM k v)
emptySubTrees e@(KEC emm) =
case emm of
@@ -183,6 +190,30 @@ instance (Enum k, Eq k) => IsKey (K k) where
computeBm !acc Nil = acc
fromSet f (EMS.KSC emm) = KEC $ fromSet_ (f . K . toEnum) emm
+ findMin (KEC emm) =
+ case emm of
+ Nil -> error "findMin: no minimal element"
+ Tip k v -> (K $ toEnum k, v)
+ Bin _ m l r
+ | m < 0 -> go r
+ | otherwise -> go l
+ where go (Tip k v) = (K $ toEnum k, v)
+ go (Bin _ _ l' _) = go l'
+ go Nil = error "findMin: Nil"
+ minViewWithKey (KEC emm) =
+ goat emm >>= \(r, emm') -> return (r, KEC $ emm')
+ where
+ goat t =
+ case t of Nil -> Nothing
+ Bin p m l r | m < 0 ->
+ case go r of
+ (result, r') ->
+ Just (result, bin p m l r')
+ _ -> Just (go t)
+ go (Bin p m l r) = case go l of
+ (result, l') -> (result, bin p m l' r)
+ go (Tip k y) = ((K $ toEnum k, y), Nil)
+ go Nil = error "minViewWithKey Nil"
union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2
unionWithKey f (KEC emm1) (KEC emm2) =
KEC $ mergeWithKey' Bin go id id emm1 emm2
@@ -229,6 +260,19 @@ instance (NFData k) => NFData (K k)
where
rnf (K k) = rnf k
+instance (Eq k, Enum k) => FOLD.Foldable (EnumMapMap (K k)) where
+ fold (KEC emm) = go emm
+ where
+ go Nil = mempty
+ go (Tip _ v) = v
+ go (Bin _ _ l r) = go l `mappend` go r
+ foldr = foldr
+ foldMap f (KEC emm) = go emm
+ where
+ go Nil = mempty
+ go (Tip _ v) = f v
+ go (Bin _ _ l r) = go l `mappend` go r
+
instance HasSKey (K k) where
type Skey (K k) = EMS.S k
toS (K !k) = EMS.S k
51 Data/EnumMapMap/Strict.hs
View
@@ -34,7 +34,7 @@ module Data.EnumMapMap.Strict (
emptySubTrees,
-- * Key types
- (:&)(..), K(..),
+ (:&)(..), K(..), IsKey, SubKey, Result,
d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,
-- * Map Type
EnumMapMap,
@@ -59,6 +59,7 @@ module Data.EnumMapMap.Strict (
unionWith,
unionWithKey,
unions,
+ unionsWith,
-- ** Difference
difference,
differenceWith,
@@ -69,8 +70,7 @@ module Data.EnumMapMap.Strict (
intersectionWith,
intersectionWithKey,
intersectSet,
- -- * Traversal
- -- ** Map
+ -- * Map
map,
mapWithKey,
-- * Folds
@@ -83,6 +83,10 @@ module Data.EnumMapMap.Strict (
elems,
keysSet,
fromSet,
+ -- * Min/Max
+ findMin,
+ minViewWithKey,
+ deleteFindMin,
-- * Split/Join Keys
toK,
toS,
@@ -95,6 +99,8 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null, init)
import Control.DeepSeq (NFData(rnf))
import Data.Bits
+import qualified Data.Foldable as FOLD
+import Data.Semigroup
import Data.EnumMapMap.Base
import qualified Data.EnumMapSet.Base as EMS
@@ -108,7 +114,7 @@ newtype K k = K k
deriving (Show, Eq)
instance (Enum k, Eq k) => IsKey (K k) where
- data EnumMapMap (K k) v = KEC (EMM k v)
+ newtype EnumMapMap (K k) v = KEC (EMM k v)
emptySubTrees e@(KEC emm) =
case emm of
@@ -182,6 +188,30 @@ instance (Enum k, Eq k) => IsKey (K k) where
computeBm !acc (Tip kx _) = acc .|. EMS.bitmapOf kx
computeBm !acc Nil = acc
fromSet f (EMS.KSC emm) = KEC $ fromSet_ (f . K . toEnum) emm
+ findMin (KEC emm) =
+ case emm of
+ Nil -> error "findMin: no minimal element"
+ Tip k v -> (K $ toEnum k, v)
+ Bin _ m l r
+ | m < 0 -> go r
+ | otherwise -> go l
+ where go (Tip k v) = (K $ toEnum k, v)
+ go (Bin _ _ l' _) = go l'
+ go Nil = error "findMin: Nil"
+ minViewWithKey (KEC emm) =
+ goat emm >>= \(r, emm') -> return (r, KEC $ emm')
+ where
+ goat t =
+ case t of Nil -> Nothing
+ Bin p m l r | m < 0 ->
+ case go r of
+ (result, r') ->
+ Just (result, bin p m l r')
+ _ -> Just (go t)
+ go (Bin p m l r) = case go l of
+ (result, l') -> (result, bin p m l' r)
+ go (Tip k y) = ((K $ toEnum k, y), Nil)
+ go Nil = error "minViewWithKey Nil"
union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2
unionWithKey f (KEC emm1) (KEC emm2) =
KEC $ mergeWithKey' Bin go id id emm1 emm2
@@ -230,6 +260,19 @@ instance (NFData k) => NFData (K k)
where
rnf (K k) = rnf k
+instance (Eq k, Enum k) => FOLD.Foldable (EnumMapMap (K k)) where
+ fold (KEC emm) = go emm
+ where
+ go Nil = mempty
+ go (Tip _ v) = v
+ go (Bin _ _ l r) = go l `mappend` go r
+ foldr = foldr
+ foldMap f (KEC emm) = go emm
+ where
+ go Nil = mempty
+ go (Tip _ v) = f v
+ go (Bin _ _ l r) = go l `mappend` go r
+
instance HasSKey (K k) where
type Skey (K k) = EMS.S k
toS (K !k) = EMS.S k
7 Data/EnumMapSet.hs
View
@@ -45,10 +45,15 @@ module Data.EnumMapSet (
EMS.map,
-- * Folds
EMS.foldr,
+ EMS.all,
-- * Lists
toList,
fromList,
- keys
+ keys,
+ -- * Min/Max
+ findMin,
+ minView,
+ deleteFindMin
) where
import Data.EnumMapSet.Base as EMS
69 Data/EnumMapSet/Base.hs
View
@@ -39,10 +39,15 @@ module Data.EnumMapSet.Base (
map,
-- * Folds
foldr,
+ all,
-- * Lists
toList,
fromList,
keys,
+ -- * Min/Max
+ findMin,
+ minView,
+ deleteFindMin,
-- * Internals
EMS(..),
EnumMapMap(KSC),
@@ -52,15 +57,12 @@ module Data.EnumMapSet.Base (
prefixOf
) where
-import Prelude hiding (lookup,
- map,
- filter,
- foldr, foldl,
- null, init,
- head, tail)
+import Prelude hiding (lookup, map, filter, foldr, foldl,
+ null, init, head, tail, all)
import Data.Bits
import qualified Data.List as List
+import Data.Maybe (fromMaybe)
import GHC.Exts (Word(..), Int(..))
import GHC.Prim (indexInt8OffAddr#)
#include "MachDeps.h"
@@ -98,7 +100,7 @@ data EMS k = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask
deriving (Show)
instance (Enum k, Eq k) => IsKey (S k) where
- data EnumMapMap (S k) v = KSC (EMS k)
+ newtype EnumMapMap (S k) v = KSC (EMS k)
emptySubTrees e@(KSC emm) =
case emm of
@@ -137,6 +139,35 @@ instance (Enum k, Eq k) => IsKey (S k) where
go init' (Bin _ _ l r) = go (go init' r) l
f' !k t = f (S $ toEnum k) undefined t
+ findMin (KSC ems) =
+ case ems of
+ Nil -> error "findMin: no minimal element"
+ Tip k bm -> (S $ toEnum $ k + lowestBitSet bm, undefined)
+ Bin _ m l r
+ | m < 0 -> go r
+ | otherwise -> go l
+ where go (Tip k bm) = (S $ toEnum $ k + lowestBitSet bm, undefined)
+ go (Bin _ _ l' _) = go l'
+ go Nil = error "findMin: Nil"
+
+ minViewWithKey (KSC ems) =
+ goat ems >>= (\(k, r) -> return ((S $ toEnum k, undefined), KSC r))
+ where
+ goat t =
+ case t of Nil -> Nothing
+ Bin p m l r | m < 0 ->
+ case go r of
+ (result, r') ->
+ Just (result, bin p m l r')
+ _ -> Just (go t)
+ go (Bin p m l r) = case go l of
+ (result, l') -> (result, bin p m l' r)
+ go (Tip kx bm) = case lowestBitSet bm of
+ bi -> (kx + bi,
+ tip kx (bm .&. complement
+ (bitmapOfSuffix bi)))
+ go Nil = error "minView Nil"
+
union (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2
where
go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
@@ -316,6 +347,12 @@ foldr f = EMM.foldrWithKey go
where
go k _ z = f k z
+all :: (IsKey k) => (k -> Bool) -> EnumMapSet k -> Bool
+all f = foldr go True
+ where
+ go _ False = False
+ go k True = f k
+
-- | @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
--
-- It's worth noting that the size of the result may be smaller if,
@@ -324,6 +361,17 @@ map :: (IsKey k1, IsKey k2, EMM.SubKey k2 k2 (), EMM.Result k2 k2 () ~ ()) =>
(k1 -> k2) -> EnumMapSet k1 -> EnumMapSet k2
map f = fromList . List.map f . toList
+findMin :: (IsKey k) => EnumMapSet k -> k
+findMin = fst . EMM.findMin
+
+minView :: (IsKey k) => EnumMapSet k -> Maybe (k, EnumMapSet k)
+minView ems = EMM.minViewWithKey ems >>= \((k, _), ems') -> return (k, ems')
+
+deleteFindMin :: (IsKey k) => EnumMapSet k -> (k, EnumMapSet k)
+deleteFindMin =
+ fromMaybe (error "deleteFindMin: empty EnumMapSet has no minimal element")
+ . minView
+
union :: (IsKey k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k
union = EMM.union
@@ -436,6 +484,9 @@ instance (Enum k) => EMM.SubKey (S k) (S k) () where
insertWith = undefined
insertWithKey = undefined
+instance (Show v) => Show (EnumMapMap (S k) v) where
+ show (KSC ems) = show ems
+
{---------------------------------------------------------------------
Helper functions
---------------------------------------------------------------------}
@@ -574,3 +625,7 @@ foldrBits prefix f z bitmap = go (revNat bitmap) z
| otherwise = case lowestBitMask bm of
bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of
bi -> bi `seq` go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)
+
+lowestBitSet :: Nat -> Int
+lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x)
+{-# INLINE lowestBitSet #-}
11 README.md
View
@@ -57,11 +57,18 @@ There is also 'EnumMapSet'. The terminating key type is S instead of K.
_Caveats_
EnumMapMap has grown quite an unwieldy, or at least verbose, API. See the unit
-tests for details. Run the benchmarking suite to see how EnumMapMap compares to
-IntMap for speed.
+tests for the full horror. Run the benchmarking suite to see how EnumMapMap
+compares to IntMap for speed.
+
+Because the keys are polymorphic you may have to specify types:
+```haskell
+treeKey = (2 :: OrchardID) :& (K $ 3 :: TreeID)
+```
TODO:
+- Investigate removing K and S using [Ordered Overlapping Type Family Instances]
+ (https://typesandkinds.wordpress.com/2012/12/22/ordered-overlapping-type-family-instances/)
- Finish operations on subtrees: alter
- Check that Strict really is strict and Lazy really is lazy.
- More functions - mapMaybe, update, mergeWithKey, foldr'
27 enummapmap.cabal
View
@@ -1,5 +1,5 @@
name: enummapmap
-version: 0.4.0
+version: 0.5.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,8 +22,10 @@ Library
Data.EnumMapSet
other-modules: Data.EnumMapMap.Base, Data.EnumMapSet.Base
build-depends: base >= 4.0 && < 5,
+ data-default,
deepseq >= 1.2 && < 1.4,
- ghc-prim
+ ghc-prim,
+ semigroups >= 0.8
ghc-options: -Wall -O2
default-language: Haskell2010
@@ -37,7 +39,9 @@ Test-Suite test-enummapmap-lazy
HUnit,
QuickCheck >= 2,
hspec >= 1.3,
+ hspec-expectations,
deepseq >= 1.2 && < 1.4,
+ semigroups >= 0.8,
enummapmap
cpp-options: -DTESTING -DLAZY
@@ -52,6 +56,7 @@ Test-Suite test-enummapmap-intmap-lazy
QuickCheck >= 2,
hspec >= 1.3,
deepseq >= 1.2 && < 1.4,
+ semigroups >= 0.8,
containers >= 0.4.2,
enummapmap
cpp-options: -DTESTING -DLAZY
@@ -66,7 +71,9 @@ Test-Suite test-enummapmap-strict
HUnit,
QuickCheck >= 2,
hspec >= 1.3,
+ hspec-expectations,
deepseq >= 1.2 && < 1.4,
+ semigroups >= 0.8,
enummapmap
cpp-options: -DTESTING -DSTRICT
@@ -81,10 +88,26 @@ Test-Suite test-enummapmap-intmap-strict
QuickCheck >= 2,
hspec >= 1.3,
deepseq >= 1.2 && < 1.4,
+ semigroups >= 0.8,
containers >= 0.4.2,
enummapmap
cpp-options: -DTESTING -DSTRICT
+Test-Suite test-enummapset
+ type: exitcode-stdio-1.0
+ main-is: UnitEnumMapSet.hs
+ hs-source-dirs: test
+ ghc-options: -Wall -O2
+ default-language: Haskell2010
+ build-depends: base >= 4.0 && < 5,
+ HUnit,
+ QuickCheck >= 2,
+ hspec >= 1.3,
+ hspec-expectations,
+ deepseq >= 1.2 && < 1.4,
+ containers >= 0.4.2,
+ enummapmap
+
Test-Suite test-enummapset-intset
type: exitcode-stdio-1.0
main-is: EnumMapSetVsIntSet.hs
105 test/EnumMapMapVsIntMap.hs
View
@@ -6,13 +6,18 @@
-- 'EnumMapMap' one by one for each function. It does not check that empty
-- EnumMapMaps are removed.
-import Test.Hspec.Monadic
+import Test.Hspec
+
import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck ()
+import Test.QuickCheck ((==>))
import qualified Data.IntSet as IS
import Data.EnumMapSet (S(..))
import qualified Data.EnumMapSet as EMS
+import Data.Foldable (foldMap, fold)
+import qualified Data.List as L
+import Data.Semigroup
+
#ifdef LAZY
import qualified Data.IntMap as IM
@@ -58,6 +63,15 @@ set2l3 s1 s2 = map (\s -> s :& s1 :& S s2)
set2l4 :: Int -> Int -> Int -> [Int] -> [Int :& Int :& Int :& S Int]
set2l4 s1 s2 s3 = map (\s -> s :& s1 :& s2 :& S s3)
+unKey1 :: K k -> k
+unKey1 (K k) = k
+unKey2 :: k1 :& K k2 -> k1
+unKey2 (k :& K _) = k
+unKey3 :: k1 :& k2 :& K k3 -> k1
+unKey3 (k :& _ :& K _) = k
+unKey4 :: k1 :& k2 :& k3 :& K k4 -> k1
+unKey4 (k :& _ :& _ :& K _) = k
+
-- | Run functions on an 'IntMap' and an 'EnumMapMap' created from list and check
-- that the results are equal
runProp :: Eq t =>
@@ -381,17 +395,68 @@ main = hspec $ do
describe "mapWithKey" $ do
let f k a = k + a
prop "Level 1" $
- runPropL (IM.mapWithKey f) (EMM.mapWithKey
- (\(K k) -> f k))
+ runPropL (IM.mapWithKey f) (EMM.mapWithKey (f . unKey1))
prop "Level 2" $
- runPropL2 (IM.mapWithKey f) (EMM.mapWithKey
- (\(k :& K _) -> f k))
+ runPropL2 (IM.mapWithKey f) (EMM.mapWithKey (f . unKey2))
prop "Level 3" $
- runPropL3 (IM.mapWithKey f) (EMM.mapWithKey
- (\(k :& _ :& K _) -> f k))
+ runPropL3 (IM.mapWithKey f) (EMM.mapWithKey (f . unKey3))
prop "Level 4" $
- runPropL4 (IM.mapWithKey f) (EMM.mapWithKey
- (\(k :& _ :& _ :& K _) -> f k))
+ runPropL4 (IM.mapWithKey f) (EMM.mapWithKey (f . unKey4))
+
+ describe "findMin" $ do
+ let go f (a, b) = (f a, b)
+ prop "Level 1" $ \list ->
+ (not $ L.null list) ==>
+ runProp (IM.findMin) (go unKey1 . EMM.findMin) list
+ prop "Level 2" $ \k1 list ->
+ (not $ L.null list) ==>
+ runProp2 (IM.findMin) (go unKey2 . EMM.findMin) k1 list
+ prop "Level 3" $ \k1 k2 list ->
+ (not $ L.null list) ==>
+ runProp3 (IM.findMin) (go unKey3 . EMM.findMin) k1 k2 list
+ prop "Level 4" $ \k1 k2 k3 list ->
+ (not $ L.null list) ==>
+ runProp4 (IM.findMin) (go unKey4 . EMM.findMin) k1 k2 k3 list
+
+ describe "minViewWithKey" $ do
+ let goe _ Nothing = Nothing
+ goe f (Just ((k, v), emm)) = Just ((f k, v), EMM.toList emm)
+ goi _ Nothing = Nothing
+ goi f (Just ((k, v), im)) = Just ((k, v), f $ IM.toList im)
+ prop "Level 1" $
+ runProp (goi list2l1 . IM.minViewWithKey)
+ (goe unKey1 . EMM.minViewWithKey)
+ prop "Level 2" $ \k1 ->
+ runProp2 (goi (list2l2 k1) . IM.minViewWithKey)
+ (goe unKey2 . EMM.minViewWithKey) k1
+ prop "Level 3" $ \k1 k2 ->
+ runProp3 (goi (list2l3 k1 k2) . IM.minViewWithKey)
+ (goe unKey3 . EMM.minViewWithKey) k1 k2
+ prop "Level 4" $ \k1 k2 k3 ->
+ runProp4 (goi (list2l4 k1 k2 k3) . IM.minViewWithKey)
+ (goe unKey4 . EMM.minViewWithKey) k1 k2 k3
+
+ describe "deleteFindMin" $ do
+ let goe _ Nothing = Nothing
+ goe f (Just ((k, v), emm)) = Just ((f k, v), EMM.toList emm)
+ goi _ Nothing = Nothing
+ goi f (Just ((k, v), im)) = Just ((k, v), f $ IM.toList im)
+ prop "Level 1" $ \list ->
+ (not $ L.null list) ==>
+ runProp (goi list2l1 . IM.minViewWithKey)
+ (goe unKey1 . EMM.minViewWithKey) list
+ prop "Level 2" $ \k1 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) ==>
+ 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) ==>
+ runProp4 (goi (list2l4 k1 k2 k3) . IM.minViewWithKey)
+ (goe unKey4 . EMM.minViewWithKey) k1 k2 k3 list
describe "union" $ do
prop "Level 1" $
@@ -480,3 +545,23 @@ main = hspec $ do
prop "Level 4" $ \ s1 s2 s3 ->
runProp4 (set2l4 s1 s2 s3 . IS.toList . IM.keysSet)
(EMS.toList . EMM.keysSet) s1 s2 s3
+
+ describe "foldable instance" $ do
+ describe "foldMap" $ do
+ prop "Level 1" $
+ runProp (foldMap (All . (> 5))) (foldMap (All . (> 5)))
+ prop "Level 2" $
+ runProp2 (foldMap (All . (> 5))) (foldMap (All . (> 5)))
+ prop "Level 3" $
+ runProp3 (foldMap (All . (> 5))) (foldMap (All . (> 5)))
+ prop "Level 4" $
+ runProp4 (foldMap (All . (> 5))) (foldMap (All . (> 5)))
+ describe "fold" $ do
+ prop "Level 1" $
+ runProp (fold . IM.map Sum) (fold . EMM.map Sum)
+ prop "Level 2" $
+ runProp2 (fold . IM.map Sum) (fold . EMM.map Sum)
+ prop "Level 3" $
+ runProp3 (fold . IM.map Sum) (fold . EMM.map Sum)
+ prop "Level 4" $
+ runProp4 (fold . IM.map Sum) (fold . EMM.map Sum)
37 test/EnumMapSetVsIntSet.hs
View
@@ -4,11 +4,12 @@
-- | This uses QuickCheck to try to check that an 'EnumMapSet'
-- behaves in the same way as an 'IntSet'.
-import Test.Hspec.Monadic
+import Test.Hspec
import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck ()
+import Test.QuickCheck ((==>))
import qualified Data.IntSet as IS
+import qualified Data.List as L
import Data.EnumMapSet(EnumMapSet, (:&)(..), S(..))
import qualified Data.EnumMapSet as EMS
@@ -26,6 +27,13 @@ list2l2 k1 = map (\k -> k :& S k1)
list2l3 :: Int -> Int -> [Int] -> [Int :& Int :& S Int]
list2l3 k1 k2 = map (\k -> k :& k1 :& S k2)
+unKey1 :: S k -> k
+unKey1 (S k) = k
+unKey2 :: k1 :& S k2 -> k1
+unKey2 (k :& S _) = k
+unKey3 :: k1 :& k2 :& S k3 -> k1
+unKey3 (k :& _ :& S _) = k
+
runProp :: Eq t =>
(IS.IntSet -> t)
-> (TestSet1 -> t)
@@ -176,6 +184,31 @@ main = hspec $ do
runPropL3 (IS.map f)
(EMS.map (\(k :& k2 :& S k1) -> f k :& k2 :& S k1))
+ describe "findMin" $ do
+ prop "Level 1" $ \list ->
+ (not $ L.null list) ==>
+ runProp (IS.findMin) (unKey1 . EMS.findMin) list
+ prop "Level 2" $ \k1 list ->
+ (not $ L.null list) ==>
+ runProp2 (IS.findMin) (unKey2 . EMS.findMin) k1 list
+ prop "Level 3" $ \k1 k2 list ->
+ (not $ L.null list) ==>
+ runProp3 (IS.findMin) (unKey3 . EMS.findMin) k1 k2 list
+
+ describe "minView" $ do
+ let goe _ Nothing = Nothing
+ goe f (Just (k, ems)) = Just (f k, EMS.toList ems)
+ goi _ Nothing = Nothing
+ goi f (Just (k, is)) = Just (k, f $ IS.toList is)
+ prop "Level 1" $
+ runProp (goi list2l1 . IS.minView) (goe unKey1 . EMS.minView)
+ prop "Level 2" $ \k1 ->
+ runProp2 (goi (list2l2 k1) . IS.minView)
+ (goe unKey2 . EMS.minView) k1
+ prop "Level 3" $ \k1 k2 ->
+ runProp3 (goi (list2l3 k1 k2) . IS.minView)
+ (goe unKey3 . EMS.minView) k1 k2
+
describe "union" $ do
prop "Level 1" $
runPropDuoL1 IS.union EMS.union
54 test/UnitEnumMapMap.hs
View
@@ -1,12 +1,23 @@
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE
+ CPP,
+ FlexibleContexts,
+ FlexibleInstances,
+ GeneralizedNewtypeDeriving,
+ ScopedTypeVariables,
+ TypeFamilies,
+ TypeOperators,
+ UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+import Control.Exception
import Control.Monad (liftM, liftM2)
+import Data.Semigroup
+import Test.Hspec.Expectations
import Test.Hspec.HUnit ()
-import Test.Hspec.Monadic
+import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.HUnit
-import Test.QuickCheck (Arbitrary, arbitrary, shrink)
+import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf)
import qualified Data.EnumMapSet as EMS
#ifdef LAZY
@@ -25,6 +36,14 @@ instance (Arbitrary a, Arbitrary b) => Arbitrary (a :& b) where
instance (Arbitrary a) => Arbitrary (K a) where
arbitrary = liftM K arbitrary
+instance (Arbitrary k, Arbitrary v,
+ EMM.IsKey k, EMM.SubKey k k v, EMM.Result k k v ~ v) =>
+ Arbitrary (EnumMapMap k v) where
+ arbitrary = fmap EMM.fromList $ listOf $ do
+ key <- arbitrary
+ val <- arbitrary
+ return (key, val)
+
newtype ID1 = ID1 Int
deriving (Show, Enum, Arbitrary, Eq, Num)
newtype ID2 = ID2 Int
@@ -36,6 +55,7 @@ type TestKey1 = K ID1
type TestEmm1 = EnumMapMap TestKey1 Int
type TestKey2 = ID2 :& K ID1
type TestEmm2 = EnumMapMap TestKey2 Int
+type TestEmm2B = EnumMapMap TestKey2 Bool
type TestKey3 = ID3 :& ID2 :& K ID1
type TestEmm3 = EnumMapMap TestKey3 Int
@@ -334,3 +354,31 @@ main =
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)]
+
+ describe "findMin" $ do
+ it "throws an error when it is passed an empty EnumMapMap" $ do
+ 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
+ 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)
+ 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)
+ prop "(<>) First works like union" lvsi
+ let bvsu :: [TestEmm2B] -> Bool
+ bvsu emms =
+ (mconcat $ map (EMM.map All) emms) ==
+ (EMM.map All $ EMM.unionsWith (&&) emms)
+ prop "unionsWith (&&) works like mconcat All" bvsu
+
32 test/UnitEnumMapSet.hs
View
@@ -0,0 +1,32 @@
+{-# LANGUAGE CPP, TypeOperators #-}
+
+import Test.Hspec.Expectations
+import Test.Hspec.HUnit ()
+import Test.Hspec.QuickCheck (prop)
+import Test.Hspec
+
+import Data.EnumMapSet (EnumMapSet, (:&)(..), S(..))
+import qualified Data.EnumMapSet as EMS
+import qualified Data.List as List
+
+main :: IO ()
+main =
+ hspec $ do
+ describe "all" $ do
+ let f :: S Int -> Bool
+ f (S s) = s > 0
+ it "returns True for an empty EnumMapSet" $
+ EMS.all (const False) (EMS.empty :: EnumMapSet (Int :& S Int))
+ `shouldBe` True
+ it "returns False when given all False" $
+ EMS.all (const False) (EMS.fromList [S 1, S (2 :: Int)])
+ `shouldBe` False
+ it "returns False when given one False" $
+ EMS.all f (EMS.fromList [S 5, S 2, S (-1),S 1000])
+ `shouldBe` False
+ let prop_list :: [Int] -> Bool
+ prop_list list =
+ let list' = map S list in
+ EMS.all f (EMS.fromList list') == List.all f list'
+ prop "is equivalent to List.all" prop_list
+

No commit comments for this range

Something went wrong with that request. Please try again.