diff --git a/Data/EnumMapMap/Base.hs b/Data/EnumMapMap/Base.hs --- a/Data/EnumMapMap/Base.hs +++ b/Data/EnumMapMap/Base.hs @@ -38,9 +38,16 @@ foldrWithKey_, foldlStrict, -- ** IntMap internals + Prefix, + Mask, + Nat, Key, + intFromNat, + shiftRL, + shiftLL, bin, tip, + shorter, nomatch, match, join, @@ -57,7 +64,8 @@ import Control.DeepSeq (NFData(rnf)) import Data.Bits import Data.Monoid (Monoid(..)) -import GHC.Exts (Word(..), Int(..), shiftRL#) +import GHC.Exts (Word(..), Int(..), + uncheckedShiftRL#, uncheckedShiftL#) data EMM k v = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(EMM k v) !(EMM k v) @@ -212,7 +220,7 @@ -- > lookup (2 :& K 1) emm == Nothing -- lookup :: k -> EnumMapMap k v -> Maybe v - -- | Insert a new Key\/Value pair into the 'EnumMapMap'. + -- | Insert a new key\/value pair into the 'EnumMapMap'. insert :: k -> v -> EnumMapMap k v -> EnumMapMap k v -- | Insert with a combining function. insertWith :: (v -> v -> v) @@ -232,7 +240,10 @@ map f = mapWithKey (\_ -> f) -- | Map a function over all key\/value pairs in the 'EnumMapMap'. mapWithKey :: (k -> v -> t) -> EnumMapMap k v -> EnumMapMap k t - -- | Fold the keys and values in the map using the given right-associative + -- | Fold the values in the 'EnumMapMap' using the given right-associative + -- binary operator + foldr :: (v -> t -> t) -> t -> EnumMapMap k v -> t + -- | Fold the keys and values in the 'EnumMapMap' using the given right-associative -- binary operator. foldrWithKey :: (k -> v -> t -> t) -> t -> EnumMapMap k v -> t -- | Convert the 'EnumMapMap' to a list of key\/value pairs. @@ -366,6 +377,8 @@ where go k = mapWithKey (\nxt -> f $ k :& nxt) + foldr f init (KCC emm) = foldrWithKey_ (\_ val z -> foldr f z val) init emm + foldrWithKey f init (KCC emm) = foldrWithKey_ go init emm where go k val z = foldrWithKey (\nxt -> f $ k :& nxt) z val @@ -581,9 +594,9 @@ intFromNat = fromIntegral {-# INLINE intFromNat #-} -shiftRL :: Nat -> Int -> Nat -shiftRL (W# x) (I# i) - = W# (shiftRL# x i) +shiftRL, shiftLL :: Nat -> Int -> Nat +shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i) +shiftLL (W# x) (I# i) = W# (uncheckedShiftL# x i) {-------------------------------------------------------------------- Join diff --git a/Data/EnumMapMap/Lazy.hs b/Data/EnumMapMap/Lazy.hs --- a/Data/EnumMapMap/Lazy.hs +++ b/Data/EnumMapMap/Lazy.hs @@ -57,6 +57,7 @@ map, mapWithKey, -- * Folds + foldr, foldrWithKey, -- * Lists toList, @@ -186,6 +187,14 @@ key = fromEnum key' mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> f $ K k) emm + foldr f init (KEC emm) = + case emm of Bin _ m l r | m < 0 -> go (go init l) r -- put negative numbers before + | otherwise -> go (go init r) l + _ -> go init emm + where + go z' Nil = z' + go z' (Tip _ x) = f x z' + go z' (Bin _ _ l r) = go (go z' r) l foldrWithKey f init (KEC emm) = foldrWithKey_ (\k -> f $ K k) init emm union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2 diff --git a/Data/EnumMapMap/Strict.hs b/Data/EnumMapMap/Strict.hs --- a/Data/EnumMapMap/Strict.hs +++ b/Data/EnumMapMap/Strict.hs @@ -58,6 +58,7 @@ map, mapWithKey, -- * Folds + foldr, foldrWithKey, -- * Lists toList, @@ -187,6 +188,14 @@ key = fromEnum key' mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> id $! f $! K k) emm + foldr f init (KEC emm) = + case emm of Bin _ m l r | m < 0 -> go (go init l) r + | otherwise -> go (go init r) l + _ -> go init emm + where + go z' Nil = z' + go z' (Tip _ x) = f x z' + go z' (Bin _ _ l r) = go (go z' r) l foldrWithKey f init (KEC emm) = foldrWithKey_ (\k -> f $! K k) init emm union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2 diff --git a/Data/EnumMapSet.hs b/Data/EnumMapSet.hs new file mode 100644 --- /dev/null +++ b/Data/EnumMapSet.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.EnumMapSet +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- (c) Matthew West 2012 +-- License : BSD-style +-- Maintainer : +-- Stability : experimental +-- Portability : Uses GHC extensions +-- +-- Based on Data.IntSet. +-- +----------------------------------------------------------------------------- + +module Data.EnumMapSet ( + EnumMapSet, + K(..), (:&)(..), + -- * Query + null, + size, + member, + -- * Construction + empty, + singleton, + insert, + delete, + -- * Combine + union, + difference, + intersection, + -- * Map + map, + -- * Folds + foldr, + -- * Lists + toList, + fromList +) where + +import Prelude hiding (lookup, + map, + filter, + foldr, foldl, + null, init, + head, tail) + +import Data.Bits +import qualified Data.List as List +import GHC.Exts (Word(..), Int(..)) +import GHC.Prim (indexInt8OffAddr#) +#include "MachDeps.h" + +import Data.EnumMapMap.Base ((:&)(..), K(..), EMM(..), + IsEmm, + EnumMapMap, + Prefix, Nat, + intFromNat, bin, + shiftRL, shiftLL, + nomatch, zero, + join, shorter, + foldlStrict) +import qualified Data.EnumMapMap.Base as EMM + +type EnumMapSet k = EnumMapMap k () + +type BitMap = Word + +instance (Enum k) => IsEmm (K k) where + data EnumMapMap (K k) v = KSC (EMM k BitMap) + + emptySubTrees e@(KSC emm) = + case emm of + Nil -> False + _ -> EMM.emptySubTrees_ e + emptySubTrees_ (KSC emm) = go emm + where + go t = case t of + Bin _ _ l r -> go l || go r + Tip _ _ -> False + Nil -> True + + removeEmpties = id + + unsafeJoinKey (KSC _) = undefined + + empty = KSC Nil + + null (KSC ems) = case ems of + Nil -> True + _ -> False + + size (KSC ems) = go ems + where + go (Bin _ _ l r) = go l + go r + go (Tip _ bm) = bitcount 0 bm + go Nil = 0 + + member !(K key') (KSC ems) = key `seq` go ems + where + go (Bin p m l r) + | nomatch key p m = False + | zero key m = go l + | otherwise = go r + go (Tip y bm) = prefixOf key == y && bitmapOf key .&. bm /= 0 + go Nil = False + key = fromEnum key' + + singleton (K key') _ + = key `seq` KSC $ Tip (prefixOf key) (bitmapOf key) + where key = fromEnum key' + + insert (K key') _ (KSC ems) + = key `seq` KSC $ insertBM (prefixOf key) (bitmapOf key) ems + where key = fromEnum key' + + delete (K key') (KSC ems) + = key `seq` KSC $ deleteBM (prefixOf key) (bitmapOf key) ems + where key = fromEnum key' + + foldrWithKey f init (KSC ems) + = case ems of Bin _ m l r | m < 0 -> go (go init l) r + | otherwise -> go (go init r) l + _ -> go init ems + where + go init' Nil = init' + go init' (Tip kx bm) = foldrBits kx f' init' bm + go init' (Bin _ _ l r) = go (go init' r) l + f' !k t = f (K $ toEnum k) undefined t + + union (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2 + where + go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (go l1 l2) (go r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (go l1 t2) r1 + | otherwise = Bin p1 m1 l1 (go r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (go t1 l2) r2 + | otherwise = Bin p2 m2 l2 (go t1 r2) + + go t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t + go t@(Bin _ _ _ _) Nil = t + go (Tip kx bm) t = insertBM kx bm t + go Nil t = t + + difference (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2 + where + go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (go l1 l2) (go r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (go l1 t2) r1 + | otherwise = bin p1 m1 l1 (go r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = go t1 l2 + | otherwise = go t1 r2 + + go t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t + go t@(Bin _ _ _ _) Nil = t + + go t1@(Tip kx bm) t2 = differenceTip t2 + where differenceTip (Bin p2 m2 l2 r2) + | nomatch kx p2 m2 = t1 + | zero kx m2 = differenceTip l2 + | otherwise = differenceTip r2 + differenceTip (Tip kx2 bm2) + | kx == kx2 = tip kx (bm .&. complement bm2) + | otherwise = t1 + differenceTip Nil = t1 + + go Nil _ = Nil + + intersection (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2 + where + go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (go l1 l2) (go r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = go l1 t2 + | otherwise = go r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = go t1 l2 + | otherwise = go t1 r2 + + go t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1 + where intersectBM (Bin p1 m1 l1 r1) + | nomatch kx2 p1 m1 = Nil + | zero kx2 m1 = intersectBM l1 + | otherwise = intersectBM r1 + intersectBM (Tip kx1 bm1) + | kx1 == kx2 = tip kx1 (bm1 .&. bm2) + | otherwise = Nil + intersectBM Nil = Nil + + go (Bin _ _ _ _) Nil = Nil + + go (Tip kx1 bm1) t2 = intersectBM t2 + where intersectBM (Bin p2 m2 l2 r2) + | nomatch kx1 p2 m2 = Nil + | zero kx1 m2 = intersectBM l2 + | otherwise = intersectBM r2 + intersectBM (Tip kx2 bm2) + | kx1 == kx2 = tip kx1 (bm1 .&. bm2) + | otherwise = Nil + intersectBM Nil = Nil + + go Nil _ = Nil + + equal (KSC ems1) (KSC ems2) = go ems1 ems2 + where + go (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (go l1 l2) && (go r1 r2) + go (Tip kx1 bm1) (Tip kx2 bm2) + = kx1 == kx2 && bm1 == bm2 + go Nil Nil = True + go _ _ = False + + nequal (KSC ems1) (KSC ems2) = go ems1 ems2 + where + go (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (go l1 l2) || (go r1 r2) + go (Tip kx1 bm1) (Tip kx2 bm2) + = kx1 /= kx2 || bm1 /= bm2 + go Nil Nil = False + go _ _ = True + + insertWith = undefined + insertWithKey = undefined + lookup = undefined + alter = undefined + foldr = undefined + map = undefined + mapWithKey = undefined + unionWith = undefined + unionWithKey = undefined + differenceWith = undefined + differenceWithKey = undefined + intersectionWith = undefined + intersectionWithKey = undefined + fromList = undefined + toList = undefined + +{--------------------------------------------------------------------- + Exported API + + The Set API is somewhat different to the Map API so we define the following + functions to call the IsEMM functions with the type of 'v' as (), hoping that + GHC will inline away all the empty parameters. +---------------------------------------------------------------------} + +null :: (IsEmm k) => EnumMapSet k -> Bool +null = EMM.null + +size :: (IsEmm k) => EnumMapSet k -> Int +size = EMM.size + +member ::(IsEmm k) => k -> EnumMapSet k -> Bool +member = EMM.member + +empty :: (IsEmm k) => EnumMapSet k +empty = EMM.empty + +singleton :: (IsEmm k) => k -> EnumMapSet k +singleton !key = EMM.singleton key () + +insert :: (IsEmm k) => k -> EnumMapSet k -> EnumMapSet k +insert !key = EMM.insert key () + +delete :: (IsEmm k) => k -> EnumMapSet k -> EnumMapSet k +delete = EMM.delete + +-- This function has not been optimised in any way. +foldr :: (IsEmm k) => (k -> t -> t) -> t -> EnumMapSet k -> t +foldr f = EMM.foldrWithKey go + where + go k _ z = f k z + +-- | @'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, +-- for some @(x,y)@, @x \/= y && f x == f y@ +map :: (IsEmm k1, IsEmm k2) => + (k1 -> k2) -> EnumMapSet k1 -> EnumMapSet k2 +map f = fromList . List.map f . toList + +union :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k +union = EMM.union + +difference :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k +difference = EMM.difference + +intersection :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k +intersection = EMM.intersection + +{--------------------------------------------------------------------- + List +---------------------------------------------------------------------} + +fromList :: IsEmm k => [k] -> EnumMapSet k +fromList xs + = foldlStrict (\t x -> insert x t) empty xs + +toList :: IsEmm k => EnumMapSet k -> [k] +toList = foldr (:) [] + +{--------------------------------------------------------------------- + Instances +---------------------------------------------------------------------} + +{--------------------------------------------------------------------- + Helper functions +---------------------------------------------------------------------} + +insertBM :: Prefix -> BitMap -> EMM k BitMap -> EMM k BitMap +insertBM !kx !bm t + = case t of + Bin p m l r + | nomatch kx p m -> join kx (Tip kx bm) p t + | zero kx m -> Bin p m (insertBM kx bm l) r + | otherwise -> Bin p m l (insertBM kx bm r) + Tip kx' bm' + | kx' == kx -> Tip kx' (bm .|. bm') + | otherwise -> join kx (Tip kx bm) kx' t + Nil -> Tip kx bm + +deleteBM :: Prefix -> BitMap -> EMM k BitMap -> EMM k BitMap +deleteBM !kx !bm t + = case t of + Bin p m l r + | nomatch kx p m -> t + | zero kx m -> bin p m (deleteBM kx bm l) r + | otherwise -> bin p m l (deleteBM kx bm r) + Tip kx' bm' + | kx' == kx -> tip kx (bm' .&. complement bm) + | otherwise -> t + Nil -> Nil + +{-------------------------------------------------------------------- + @tip@ assures that we never have empty bitmaps within a tree. +--------------------------------------------------------------------} +tip :: Prefix -> BitMap -> EMM k BitMap +tip _ 0 = Nil +tip kx bm = Tip kx bm +{-# INLINE tip #-} + +{---------------------------------------------------------------------- + Functions that generate Prefix and BitMap of a Key or a Suffix. + + Commentary and credits can be found with the original code in + Data/IntSet/Base.hs in 'containers 5.0'. +----------------------------------------------------------------------} + +suffixBitMask :: Int +suffixBitMask = bitSize (undefined::Word) - 1 +{-# INLINE suffixBitMask #-} + +prefixBitMask :: Int +prefixBitMask = complement suffixBitMask +{-# INLINE prefixBitMask #-} + +prefixOf :: Int -> Prefix +prefixOf x = x .&. prefixBitMask +{-# INLINE prefixOf #-} + +suffixOf :: Int -> Int +suffixOf x = x .&. suffixBitMask +{-# INLINE suffixOf #-} + +bitmapOfSuffix :: Int -> BitMap +bitmapOfSuffix s = 1 `shiftLL` s +{-# INLINE bitmapOfSuffix #-} + +bitmapOf :: Int -> BitMap +bitmapOf x = bitmapOfSuffix (suffixOf x) +{-# INLINE bitmapOf #-} + +bitcount :: Int -> Word -> Int +bitcount a0 x0 = go a0 x0 + where go a 0 = a + go a x = go (a + 1) (x .&. (x-1)) +{-# INLINE bitcount #-} + +{---------------------------------------------------------------------- + Folds over a BitMap. + + Commentary and credits can be found with the original code in + Data/IntSet/Base.hs in 'containers 5.0'. +----------------------------------------------------------------------} + +foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a + +{-# INLINE foldrBits #-} + +indexOfTheOnlyBit :: Nat -> Int +{-# INLINE indexOfTheOnlyBit #-} +indexOfTheOnlyBit bitmask = + I# (lsbArray `indexInt8OffAddr#` unboxInt + (intFromNat ((bitmask * magic) `shiftRL` offset))) + where unboxInt (I# i) = i +#if WORD_SIZE_IN_BITS==32 + magic = 0x077CB531 + offset = 27 + !lsbArray = "\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"# +#else + magic = 0x07EDD5E59A4E28C2 + offset = 58 + !lsbArray = "\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"# +#endif +lowestBitMask :: Nat -> Nat +lowestBitMask x = x .&. negate x +{-# INLINE lowestBitMask #-} + +revNat :: Nat -> Nat +#if WORD_SIZE_IN_BITS==32 +revNat x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of + x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of + x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of + x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of + x5 -> ( x5 `shiftRL` 16 ) .|. ( x5 `shiftLL` 16); +#else +revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of + x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of + x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of + x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of + x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of + x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32); +#endif +foldrBits prefix f z bitmap = go (revNat bitmap) z + where go bm acc | bm == 0 = acc + | 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) diff --git a/enummapmap.cabal b/enummapmap.cabal --- a/enummapmap.cabal +++ b/enummapmap.cabal @@ -1,13 +1,14 @@ name: enummapmap -version: 0.0.2 +version: 0.1.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 containers 5.0. +description: This package provides 'maps of maps' using Enum types as + keys. The code is based upon Data.IntMap in + containers 5.0. license: BSD3 license-file: LICENSE author: Matthew West and authors of containers v5.0 maintainer: Matthew West -category: Data +category: Data, Data Structures build-type: Simple cabal-version: >=1.10 @@ -17,10 +18,12 @@ location: http://github.com/bovinespirit/enummapmap.git Library - exposed-modules: Data.EnumMapMap.Lazy, Data.EnumMapMap.Strict + exposed-modules: Data.EnumMapMap.Lazy, Data.EnumMapMap.Strict, + Data.EnumMapSet other-modules: Data.EnumMapMap.Base build-depends: base >= 4.0 && < 5, - deepseq >= 1.2 && < 1.4 + deepseq >= 1.2 && < 1.4, + ghc-prim ghc-options: -Wall -O2 default-language: Haskell2010 @@ -33,7 +36,7 @@ build-depends: base >= 4.0 && < 5, HUnit, QuickCheck >= 2, - hspec >= 0.9, + hspec >= 1.3, deepseq >= 1.2 && < 1.4, enummapmap cpp-options: -DTESTING -DLAZY @@ -47,7 +50,7 @@ build-depends: base >= 4.0 && < 5, HUnit, QuickCheck >= 2, - hspec >= 0.9, + hspec >= 1.3, deepseq >= 1.2 && < 1.4, containers >= 0.4.2, enummapmap @@ -62,7 +65,7 @@ build-depends: base >= 4.0 && < 5, HUnit, QuickCheck >= 2, - hspec >= 0.9, + hspec >= 1.3, deepseq >= 1.2 && < 1.4, enummapmap cpp-options: -DTESTING -DSTRICT @@ -76,8 +79,23 @@ build-depends: base >= 4.0 && < 5, HUnit, QuickCheck >= 2, - hspec >= 0.9, + hspec >= 1.3, deepseq >= 1.2 && < 1.4, containers >= 0.4.2, enummapmap cpp-options: -DTESTING -DSTRICT + +Test-Suite test-enummapset-intset + type: exitcode-stdio-1.0 + main-is: EnumMapSetVsIntSet.hs + hs-source-dirs: test + ghc-options: -Wall -O2 + default-language: Haskell2010 + build-depends: base >= 4.0 && < 5, + HUnit, + QuickCheck >= 2, + hspec >= 0.9, + deepseq >= 1.2 && < 1.4, + containers >= 0.4.2, + enummapmap + cpp-options: -DTESTING diff --git a/test/EnumMapMapVsIntMap.hs b/test/EnumMapMapVsIntMap.hs --- a/test/EnumMapMapVsIntMap.hs +++ b/test/EnumMapMapVsIntMap.hs @@ -207,7 +207,7 @@ (\a b -> EMM.toList $ g a b) k1 k2 k3 main :: IO () -main = hspecX $ do +main = hspec $ do describe "toList fromList" $ do prop "Level 1" $ runPropL id id @@ -314,6 +314,14 @@ prop "Level 3" $ \i b n k1 k2 -> runPropL3 (IM.alter (f b n) i) (EMM.alter (f b n) (i :& k1 :& K k2)) k1 k2 + + describe "foldr" $ do + prop "Level 1" $ + runProp (IM.foldr (:) []) (EMM.foldr (:) []) + prop "Level 2" $ + runProp2 (IM.foldr (:) []) (EMM.foldr (:) []) + prop "Level 3" $ + runProp3 (IM.foldr (:) []) (EMM.foldr (:) []) describe "foldrWithKey" $ do let f a b c = [a + b] ++ c diff --git a/test/EnumMapSetVsIntSet.hs b/test/EnumMapSetVsIntSet.hs new file mode 100644 --- /dev/null +++ b/test/EnumMapSetVsIntSet.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | 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.QuickCheck (prop) +import Test.QuickCheck () + +import qualified Data.IntSet as IS + +import Data.EnumMapSet(EnumMapSet, (:&)(..), K(..)) +import qualified Data.EnumMapSet as EMS + +type TestSet1 = EnumMapSet (K Int) +type TestSet2 = EnumMapSet (Int :& K Int) +type TestSet3 = EnumMapSet (Int :& Int :& K Int) + +list2l1 :: [Int] -> [K Int] +list2l1 = map (\k -> K k) + +list2l2 :: Int -> [Int] -> [Int :& K Int] +list2l2 k1 = map (\k -> k :& K k1) + +list2l3 :: Int -> Int -> [Int] -> [Int :& Int :& K Int] +list2l3 k1 k2 = map (\k -> k :& k1 :& K k2) + +runProp :: Eq t => + (IS.IntSet -> t) + -> (TestSet1 -> t) + -> [Int] + -> Bool +runProp f g list = + (f $ IS.fromList list) == (g $ EMS.fromList $ list2l1 list) + +runPropDuo1 :: Eq t => + (IS.IntSet -> IS.IntSet -> t) + -> (TestSet1 -> TestSet1 -> t) + -> [Int] + -> [Int] + -> Bool +runPropDuo1 f g list1 list2 + = (f (IS.fromList list1) $ IS.fromList list2) + == (g (EMS.fromList $ list2l1 list1) $ EMS.fromList $ list2l1 list2) + +runProp2 :: Eq t => + (IS.IntSet -> t) + -> (TestSet2 -> t) + -> Int + -> [Int] + -> Bool +runProp2 f g k1 list + = (f $ IS.fromList list) == (g $ EMS.fromList $ list2l2 k1 list) + +runPropDuo2 :: Eq t => + (IS.IntSet -> IS.IntSet -> t) + -> (TestSet2 -> TestSet2 -> t) + -> Int + -> [Int] + -> [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) + +runProp3 :: Eq t => + (IS.IntSet -> t) + -> (TestSet3 -> t) + -> Int -> Int + -> [Int] + -> Bool +runProp3 f g k1 k2 list + = (f $ IS.fromList list) == (g $ EMS.fromList $ list2l3 k1 k2 list) + +runPropDuo3 :: Eq t => + (IS.IntSet -> IS.IntSet -> t) + -> (TestSet3 -> TestSet3 -> t) + -> Int -> Int + -> [Int] + -> [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) + +runPropL :: (IS.IntSet -> IS.IntSet) + -> (TestSet1 -> TestSet1) + -> [Int] + -> Bool +runPropL f g + = runProp (list2l1 . IS.toList . f) (EMS.toList . g) + +runPropDuoL1 :: (IS.IntSet -> IS.IntSet -> IS.IntSet) + -> (TestSet1 -> TestSet1 -> TestSet1) + -> [Int] + -> [Int] + -> Bool +runPropDuoL1 f g = + runPropDuo1 (\a b -> list2l1 $ IS.toList $ f a b) + (\a b -> EMS.toList $ g a b) + +runPropL2 :: (IS.IntSet -> IS.IntSet) + -> (TestSet2 -> TestSet2) + -> Int + -> [Int] + -> Bool +runPropL2 f g k1 + = runProp2 (list2l2 k1 . IS.toList . f) (EMS.toList . g) k1 + +runPropDuoL2 :: (IS.IntSet -> IS.IntSet -> IS.IntSet) + -> (TestSet2 -> TestSet2 -> TestSet2) + -> Int + -> [Int] + -> [Int] + -> Bool +runPropDuoL2 f g k1 = + runPropDuo2 (\a b -> list2l2 k1 $ IS.toList $ f a b) + (\a b -> EMS.toList $ g a b) k1 + +runPropL3 :: (IS.IntSet -> IS.IntSet) + -> (TestSet3 -> TestSet3) + -> Int -> Int + -> [Int] + -> Bool +runPropL3 f g k1 k2 + = runProp3 (list2l3 k1 k2 . IS.toList . f) (EMS.toList . g) k1 k2 + +runPropDuoL3 :: (IS.IntSet -> IS.IntSet -> IS.IntSet) + -> (TestSet3 -> TestSet3 -> TestSet3) + -> Int -> Int + -> [Int] + -> [Int] + -> Bool +runPropDuoL3 f g k1 k2 = + runPropDuo3 (\a b -> list2l3 k1 k2 $ IS.toList $ f a b) + (\a b -> EMS.toList $ g a b) k1 k2 + +main :: IO () +main = hspec $ do + describe "toList fromList" $ do + prop "Level 1" $ runPropL id id + prop "Level 2" $ runPropL2 id id + prop "Level 3" $ runPropL3 id id + + describe "null" $ do + prop "Level 1" $ runProp IS.null EMS.null + prop "Level 2" $ runProp2 IS.null EMS.null + prop "Level 3" $ runProp3 IS.null EMS.null + + describe "insert" $ do + prop "Level 1" $ \k -> + runPropL (IS.insert k) (EMS.insert $ K k) + prop "Level 2" $ \k k1 -> + runPropL2 (IS.insert k) (EMS.insert $ k :& K k1) k1 + prop "Level 3" $ \k k1 k2 -> + runPropL3 (IS.insert k) (EMS.insert $ k :& k1 :& K k2) k1 k2 + + describe "delete" $ do + prop "Level 1" $ \k -> + runPropL (IS.delete k) (EMS.delete $ K k) + prop "Level 2" $ \k k1 -> + runPropL2 (IS.delete k) (EMS.delete $ k :& K k1) k1 + prop "Level 3" $ \k k1 k2 -> + runPropL3 (IS.delete k) (EMS.delete $ k :& k1 :& K k2) k1 k2 + + describe "map" $ do + let f a = a + 1 + prop "Level 1" $ + runPropL (IS.map f) (EMS.map (\(K k) -> K $ f k)) + prop "Level 2" $ + runPropL2 (IS.map f) (EMS.map (\(k :& K k1) -> f k :& K k1)) + prop "Level 3" $ + runPropL3 (IS.map f) + (EMS.map (\(k :& k2 :& K k1) -> f k :& k2 :& K k1)) + + describe "union" $ do + prop "Level 1" $ + runPropDuoL1 IS.union EMS.union + prop "Level 2" $ + runPropDuoL2 IS.union EMS.union + prop "Level 3" $ + runPropDuoL3 IS.union EMS.union + + describe "difference" $ do + prop "Level 1" $ + runPropDuoL1 IS.difference EMS.difference + prop "Level 2" $ + runPropDuoL2 IS.difference EMS.difference + prop "Level 3" $ + runPropDuoL3 IS.difference EMS.difference + + describe "intersection" $ do + prop "Level 1" $ + runPropDuoL1 IS.intersection EMS.intersection + prop "Level 2" $ + runPropDuoL2 IS.intersection EMS.intersection + prop "Level 3" $ + runPropDuoL3 IS.intersection EMS.intersection + + describe "equals" $ do + prop "Level 1" $ + runPropDuo1 (==) (==) + prop "Level 2" $ + runPropDuo2 (==) (==) + prop "Level 3" $ + runPropDuo3 (==) (==) + + describe "nequals" $ do + prop "Level 1" $ + runPropDuo1 (/=) (/=) + prop "Level 2" $ + runPropDuo2 (/=) (/=) + prop "Level 3" $ + runPropDuo3 (/=) (/=) diff --git a/test/UnitEnumMapMap.hs b/test/UnitEnumMapMap.hs --- a/test/UnitEnumMapMap.hs +++ b/test/UnitEnumMapMap.hs @@ -82,7 +82,7 @@ main :: IO () main = - hspecX $ do + hspec $ do describe "empty" $ do it "creates an empty EnumMapMap" $ (EMM.null $ (EMM.empty :: EnumMapMap (Int :& Int :& K Int) Bool))