diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,29 @@ +## 0.2.9.0 + + * Add `Ord/Ord1/Ord2` instances. (Thanks, Oleg Grenrus) + + * Use `SmallArray#` instead of `Array#` for GHC versions 7.10 and above. + (Thanks, Dmitry Ivanov) + + * Adjust for `Semigroup => Monoid` proposal implementation. + (Thanks, Ryan Scott) + +### Bug fixes + + * Fix a strictness bug in `fromListWith`. + + * Enable eager blackholing for pre-8.2 GHC versions to work around + a runtime system bug. (Thanks, Ben Gamari) + + * Avoid sketchy reimplementation of `ST` when compiling with recent + GHC. + +### Other changes + + * Remove support for GHC versions before 7.8. (Thanks, Dmitry Ivanov) + + * Add internal documentaton. (Thanks, Johan Tibell) + ## 0.2.8.0 * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9` diff --git a/Data/HashMap/Array.hs b/Data/HashMap/Array.hs --- a/Data/HashMap/Array.hs +++ b/Data/HashMap/Array.hs @@ -53,12 +53,7 @@ import Control.Applicative (Applicative) #endif import Control.DeepSeq --- GHC 7.7 exports toList/fromList from GHC.Exts --- In order to avoid warnings on previous GHC versions, we provide --- an explicit import list instead of only hiding the offending symbols -import GHC.Exts (Array#, Int(..), newArray#, readArray#, writeArray#, - indexArray#, unsafeFreezeArray#, unsafeThawArray#, - MutableArray#) +import GHC.Exts(Int(..)) import GHC.ST (ST(..)) #if __GLASGOW_HASKELL__ >= 709 @@ -67,9 +62,17 @@ import Prelude hiding (filter, foldr, length, map, read) #endif -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Exts (sizeofArray#, copyArray#, thawArray#, sizeofMutableArray#, - copyMutableArray#) +#if __GLASGOW_HASKELL__ >= 710 +import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, + indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, + SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, + sizeofSmallMutableArray#, copySmallMutableArray#) + +#else +import GHC.Exts (Array#, newArray#, readArray#, writeArray#, + indexArray#, unsafeFreezeArray#, unsafeThawArray#, + MutableArray#, sizeofArray#, copyArray#, thawArray#, + sizeofMutableArray#, copyMutableArray#) #endif #if defined(ASSERTS) @@ -78,6 +81,24 @@ import Data.HashMap.Unsafe (runST) + +#if __GLASGOW_HASKELL__ >= 710 +type Array# a = SmallArray# a +type MutableArray# a = SmallMutableArray# a + +newArray# = newSmallArray# +readArray# = readSmallArray# +writeArray# = writeSmallArray# +indexArray# = indexSmallArray# +unsafeFreezeArray# = unsafeFreezeSmallArray# +unsafeThawArray# = unsafeThawSmallArray# +sizeofArray# = sizeofSmallArray# +copyArray# = copySmallArray# +thawArray# = thawSmallArray# +sizeofMutableArray# = sizeofSmallMutableArray# +copyMutableArray# = copySmallMutableArray# +#endif + ------------------------------------------------------------------------ #if defined(ASSERTS) @@ -100,49 +121,31 @@ data Array a = Array { unArray :: !(Array# a) -#if __GLASGOW_HASKELL__ < 702 - , length :: !Int -#endif } instance Show a => Show (Array a) where show = show . toList -#if __GLASGOW_HASKELL__ >= 702 length :: Array a -> Int length ary = I# (sizeofArray# (unArray ary)) {-# INLINE length #-} -#endif -- | Smart constructor array :: Array# a -> Int -> Array a -#if __GLASGOW_HASKELL__ >= 702 array ary _n = Array ary -#else -array = Array -#endif {-# INLINE array #-} data MArray s a = MArray { unMArray :: !(MutableArray# s a) -#if __GLASGOW_HASKELL__ < 702 - , lengthM :: !Int -#endif } -#if __GLASGOW_HASKELL__ >= 702 lengthM :: MArray s a -> Int lengthM mary = I# (sizeofMutableArray# (unMArray mary)) {-# INLINE lengthM #-} -#endif -- | Smart constructor marray :: MutableArray# s a -> Int -> MArray s a -#if __GLASGOW_HASKELL__ >= 702 marray mary _n = MArray mary -#else -marray = MArray -#endif {-# INLINE marray #-} ------------------------------------------------------------------------ @@ -237,47 +240,21 @@ -- | Unsafely copy the elements of an array. Array bounds are not checked. copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () -#if __GLASGOW_HASKELL__ >= 702 copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = CHECK_LE("copy", _sidx + _n, length src) CHECK_LE("copy", _didx + _n, lengthM dst) ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) -#else -copy !src !sidx !dst !didx n = - CHECK_LE("copy", sidx + n, length src) - CHECK_LE("copy", didx + n, lengthM dst) - copy_loop sidx didx 0 - where - copy_loop !i !j !c - | c >= n = return () - | otherwise = do b <- indexM src i - write dst j b - copy_loop (i+1) (j+1) (c+1) -#endif -- | Unsafely copy the elements of an array. Array bounds are not checked. copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () -#if __GLASGOW_HASKELL__ >= 702 copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) -#else -copyM !src !sidx !dst !didx n = - CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1) - CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1) - copy_loop sidx didx 0 - where - copy_loop !i !j !c - | c >= n = return () - | otherwise = do b <- read src i - write dst j b - copy_loop (i+1) (j+1) (c+1) -#endif -- | /O(n)/ Insert an element at the given position in this array, -- increasing its size by one. @@ -352,18 +329,10 @@ {-# NOINLINE undefinedElem #-} thaw :: Array e -> Int -> Int -> ST s (MArray s e) -#if __GLASGOW_HASKELL__ >= 702 thaw !ary !_o@(I# o#) !n@(I# n#) = CHECK_LE("thaw", _o + n, length ary) ST $ \ s -> case thawArray# (unArray ary) o# n# s of (# s2, mary# #) -> (# s2, marray mary# n #) -#else -thaw !ary !o !n = - CHECK_LE("thaw", o + n, length ary) - do mary <- new_ n - copy ary o mary 0 n - return mary -#endif {-# INLINE thaw #-} -- | /O(n)/ Delete an element at the given position in this array, diff --git a/Data/HashMap/Base.hs b/Data/HashMap/Base.hs --- a/Data/HashMap/Base.hs +++ b/Data/HashMap/Base.hs @@ -1,10 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} -#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} -#endif {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} module Data.HashMap.Base @@ -104,7 +102,7 @@ #endif import Control.DeepSeq (NFData(rnf)) import Control.Monad.ST (ST) -import Data.Bits ((.&.), (.|.), complement) +import Data.Bits ((.&.), (.|.), complement, popCount) import Data.Data hiding (Typeable) import qualified Data.Foldable as Foldable import qualified Data.List as L @@ -115,17 +113,13 @@ import qualified Data.HashMap.Array as A import qualified Data.Hashable as H import Data.Hashable (Hashable) -import Data.HashMap.PopCount (popCount) import Data.HashMap.Unsafe (runST) import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR) +import Data.HashMap.List (isPermutationBy, unorderedCompare) import Data.Typeable (Typeable) -#if __GLASGOW_HASKELL__ >= 707 import GHC.Exts (isTrue#) -#endif -#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts -#endif #if MIN_VERSION_base(4,9,0) import Data.Functor.Classes @@ -161,9 +155,7 @@ | Collision !Hash !(A.Array (Leaf k v)) deriving (Typeable) -#if __GLASGOW_HASKELL__ >= 708 type role HashMap nominal representational -#endif instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Empty = () @@ -267,10 +259,12 @@ -- order of elements in 'Collision'). go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) - | k1 == k2 && leafEq l1 l2 + | k1 == k2 && + leafEq l1 l2 = go tl1 tl2 go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - | k1 == k2 && A.length ary1 == A.length ary2 && + | k1 == k2 && + A.length ary1 == A.length ary2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2) = go tl1 tl2 go [] [] = True @@ -278,26 +272,43 @@ leafEq (L k v) (L k' v') = eqk k k' && eqv v v' --- Note: previous implemenation isPermutation = null (as // bs) --- was O(n^2) too. +#if MIN_VERSION_base(4,9,0) +instance Ord2 HashMap where + liftCompare2 = cmp + +instance Ord k => Ord1 (HashMap k) where + liftCompare = cmp compare +#endif + +-- | The order is total. -- --- This assumes lists are of equal length -isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool -isPermutationBy f = go - where - f' = flip f +-- /Note:/ Because the hash is not guaranteed to be stable across library +-- versions, OSes, or architectures, neither is an actual order of elements in +-- 'HashMap' or an result of `compare`.is stable. +instance (Ord k, Ord v) => Ord (HashMap k v) where + compare = cmp compare compare - go [] [] = True - go (x : xs) (y : ys) - | f x y = go xs ys - | otherwise = go (deleteBy f' y xs) (deleteBy f x ys) - go [] (_ : _) = False - go (_ : _) [] = False +cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering) + -> HashMap k v -> HashMap k' v' -> Ordering +cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 []) + where + go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) + = compare k1 k2 `mappend` + leafCompare l1 l2 `mappend` + go tl1 tl2 + go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) + = compare k1 k2 `mappend` + compare (A.length ary1) (A.length ary2) `mappend` + unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend` + go tl1 tl2 + go (Leaf _ _ : _) (Collision _ _ : _) = LT + go (Collision _ _ : _) (Leaf _ _ : _) = GT + go [] [] = EQ + go [] _ = LT + go _ [] = GT + go _ _ = error "cmp: Should never happend, toList' includes non Leaf / Collision" --- Data.List.deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] -deleteBy :: (a -> b -> Bool) -> a -> [b] -> [b] -deleteBy _ _ [] = [] -deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' -- Same as 'equal' but doesn't compare the values. equalKeys :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool @@ -1299,28 +1310,7 @@ -- array is not checked. clone16 :: A.Array e -> ST s (A.MArray s e) clone16 ary = -#if __GLASGOW_HASKELL__ >= 702 A.thaw ary 0 16 -#else - do mary <- A.new_ 16 - A.indexM ary 0 >>= A.write mary 0 - A.indexM ary 1 >>= A.write mary 1 - A.indexM ary 2 >>= A.write mary 2 - A.indexM ary 3 >>= A.write mary 3 - A.indexM ary 4 >>= A.write mary 4 - A.indexM ary 5 >>= A.write mary 5 - A.indexM ary 6 >>= A.write mary 6 - A.indexM ary 7 >>= A.write mary 7 - A.indexM ary 8 >>= A.write mary 8 - A.indexM ary 9 >>= A.write mary 9 - A.indexM ary 10 >>= A.write mary 10 - A.indexM ary 11 >>= A.write mary 11 - A.indexM ary 12 >>= A.write mary 12 - A.indexM ary 13 >>= A.write mary 13 - A.indexM ary 14 >>= A.write mary 14 - A.indexM ary 15 >>= A.write mary 15 - return mary -#endif ------------------------------------------------------------------------ -- Bit twiddling @@ -1355,18 +1345,12 @@ -- | Check if two the two arguments are the same value. N.B. This -- function might give false negatives (due to GC moving objects.) ptrEq :: a -> a -> Bool -#if __GLASGOW_HASKELL__ < 707 -ptrEq x y = reallyUnsafePtrEquality# x y ==# 1# -#else ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) -#endif {-# INLINE ptrEq #-} -#if __GLASGOW_HASKELL__ >= 708 ------------------------------------------------------------------------ -- IsList instance instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where type Item (HashMap k v) = (k, v) fromList = fromList toList = toList -#endif diff --git a/Data/HashMap/Lazy.hs b/Data/HashMap/Lazy.hs --- a/Data/HashMap/Lazy.hs +++ b/Data/HashMap/Lazy.hs @@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------ -- | diff --git a/Data/HashMap/List.hs b/Data/HashMap/List.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/List.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} +-- | Extra list functions +-- +-- In separate module to aid testing. +module Data.HashMap.List + ( isPermutationBy + , deleteBy + , unorderedCompare + ) where + +import Data.Maybe (fromMaybe) +import Data.List (sortBy) +import Data.Monoid +import Prelude + +-- Note: previous implemenation isPermutation = null (as // bs) +-- was O(n^2) too. +-- +-- This assumes lists are of equal length +isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +isPermutationBy f = go + where + f' = flip f + + go [] [] = True + go (x : xs) (y : ys) + | f x y = go xs ys + | otherwise = fromMaybe False $ do + xs' <- deleteBy f' y xs + ys' <- deleteBy f x ys + return (go xs' ys') + go [] (_ : _) = False + go (_ : _) [] = False + +-- The idea: +-- +-- Homogeonous version +-- +-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering +-- uc c as bs = compare (sortBy c as) (sortBy c bs) +-- +-- But as we have only (a -> b -> Ordering), we cannot directly compare +-- elements from the same list. +-- +-- So when comparing elements from the list, we count how many elements are +-- "less and greater" in the other list, and use the count as a metric. +-- +unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering +unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) + where + go [] [] = EQ + go [] (_ : _) = LT + go (_ : _) [] = GT + go (x : xs) (y : ys) = c x y `mappend` go xs ys + + cmpA a a' = compare (inB a) (inB a') + cmpB b b' = compare (inA b) (inA b') + + inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) + inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) + +-- Returns Nothing is nothing deleted +deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] +deleteBy _ _ [] = Nothing +deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) diff --git a/Data/HashMap/PopCount.hs b/Data/HashMap/PopCount.hs deleted file mode 100644 --- a/Data/HashMap/PopCount.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Data.HashMap.PopCount - ( popCount - ) where - -#if __GLASGOW_HASKELL__ >= 704 -import Data.Bits (popCount) -#else -import Data.Word (Word) -import Foreign.C (CUInt) -#endif - -#if __GLASGOW_HASKELL__ < 704 -foreign import ccall unsafe "popc.h popcount" c_popcount :: CUInt -> CUInt - -popCount :: Word -> Int -popCount w = fromIntegral (c_popcount (fromIntegral w)) -#endif diff --git a/Data/HashMap/Strict.hs b/Data/HashMap/Strict.hs --- a/Data/HashMap/Strict.hs +++ b/Data/HashMap/Strict.hs @@ -1,8 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, PatternGuards #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------ -- | @@ -183,7 +180,7 @@ else do let l' = x `seq` (L k x) return $! collision h l l' - | otherwise = two s h k x hy ky y + | otherwise = x `seq` two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! leaf h k x diff --git a/Data/HashMap/Unsafe.hs b/Data/HashMap/Unsafe.hs --- a/Data/HashMap/Unsafe.hs +++ b/Data/HashMap/Unsafe.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_base(4,9,0) {-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} +#endif -- | This module exports a workaround for this bug: -- @@ -12,6 +16,12 @@ ( runST ) where +#if MIN_VERSION_base(4,9,0) +-- The GHC issue was fixed in GHC 8.0/base 4.9 +import Control.Monad.ST + +#else + import GHC.Base (realWorld#) import qualified GHC.ST as ST @@ -26,3 +36,4 @@ runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r {-# INLINE [0] runSTRep #-} +#endif diff --git a/Data/HashSet.hs b/Data/HashSet.hs --- a/Data/HashSet.hs +++ b/Data/HashSet.hs @@ -77,7 +77,7 @@ import Data.HashMap.Base (HashMap, foldrWithKey, equalKeys) import Data.Hashable (Hashable(hashWithSalt)) #if __GLASGOW_HASKELL__ >= 711 -import Data.Semigroup (Semigroup(..), Monoid(..)) +import Data.Semigroup (Semigroup(..)) #elif __GLASGOW_HASKELL__ < 709 import Data.Monoid (Monoid(..)) #endif @@ -121,6 +121,15 @@ #if MIN_VERSION_base(4,9,0) instance Eq1 HashSet where liftEq eq (HashSet a) (HashSet b) = equalKeys eq a b +#endif + +instance (Ord a) => Ord (HashSet a) where + compare (HashSet a) (HashSet b) = compare a b + {-# INLINE compare #-} + +#if MIN_VERSION_base(4,9,0) +instance Ord1 HashSet where + liftCompare c (HashSet a) (HashSet b) = liftCompare2 c compare a b #endif instance Foldable.Foldable HashSet where diff --git a/cbits/popc.c b/cbits/popc.c deleted file mode 100644 --- a/cbits/popc.c +++ /dev/null @@ -1,273 +0,0 @@ -#include - -/* Cribbed from http://wiki.cs.pdx.edu/forge/popcount.html */ -static char popcount_table_8[256] = { - /*0*/ 0, - /*1*/ 1, - /*2*/ 1, - /*3*/ 2, - /*4*/ 1, - /*5*/ 2, - /*6*/ 2, - /*7*/ 3, - /*8*/ 1, - /*9*/ 2, - /*10*/ 2, - /*11*/ 3, - /*12*/ 2, - /*13*/ 3, - /*14*/ 3, - /*15*/ 4, - /*16*/ 1, - /*17*/ 2, - /*18*/ 2, - /*19*/ 3, - /*20*/ 2, - /*21*/ 3, - /*22*/ 3, - /*23*/ 4, - /*24*/ 2, - /*25*/ 3, - /*26*/ 3, - /*27*/ 4, - /*28*/ 3, - /*29*/ 4, - /*30*/ 4, - /*31*/ 5, - /*32*/ 1, - /*33*/ 2, - /*34*/ 2, - /*35*/ 3, - /*36*/ 2, - /*37*/ 3, - /*38*/ 3, - /*39*/ 4, - /*40*/ 2, - /*41*/ 3, - /*42*/ 3, - /*43*/ 4, - /*44*/ 3, - /*45*/ 4, - /*46*/ 4, - /*47*/ 5, - /*48*/ 2, - /*49*/ 3, - /*50*/ 3, - /*51*/ 4, - /*52*/ 3, - /*53*/ 4, - /*54*/ 4, - /*55*/ 5, - /*56*/ 3, - /*57*/ 4, - /*58*/ 4, - /*59*/ 5, - /*60*/ 4, - /*61*/ 5, - /*62*/ 5, - /*63*/ 6, - /*64*/ 1, - /*65*/ 2, - /*66*/ 2, - /*67*/ 3, - /*68*/ 2, - /*69*/ 3, - /*70*/ 3, - /*71*/ 4, - /*72*/ 2, - /*73*/ 3, - /*74*/ 3, - /*75*/ 4, - /*76*/ 3, - /*77*/ 4, - /*78*/ 4, - /*79*/ 5, - /*80*/ 2, - /*81*/ 3, - /*82*/ 3, - /*83*/ 4, - /*84*/ 3, - /*85*/ 4, - /*86*/ 4, - /*87*/ 5, - /*88*/ 3, - /*89*/ 4, - /*90*/ 4, - /*91*/ 5, - /*92*/ 4, - /*93*/ 5, - /*94*/ 5, - /*95*/ 6, - /*96*/ 2, - /*97*/ 3, - /*98*/ 3, - /*99*/ 4, - /*100*/ 3, - /*101*/ 4, - /*102*/ 4, - /*103*/ 5, - /*104*/ 3, - /*105*/ 4, - /*106*/ 4, - /*107*/ 5, - /*108*/ 4, - /*109*/ 5, - /*110*/ 5, - /*111*/ 6, - /*112*/ 3, - /*113*/ 4, - /*114*/ 4, - /*115*/ 5, - /*116*/ 4, - /*117*/ 5, - /*118*/ 5, - /*119*/ 6, - /*120*/ 4, - /*121*/ 5, - /*122*/ 5, - /*123*/ 6, - /*124*/ 5, - /*125*/ 6, - /*126*/ 6, - /*127*/ 7, - /*128*/ 1, - /*129*/ 2, - /*130*/ 2, - /*131*/ 3, - /*132*/ 2, - /*133*/ 3, - /*134*/ 3, - /*135*/ 4, - /*136*/ 2, - /*137*/ 3, - /*138*/ 3, - /*139*/ 4, - /*140*/ 3, - /*141*/ 4, - /*142*/ 4, - /*143*/ 5, - /*144*/ 2, - /*145*/ 3, - /*146*/ 3, - /*147*/ 4, - /*148*/ 3, - /*149*/ 4, - /*150*/ 4, - /*151*/ 5, - /*152*/ 3, - /*153*/ 4, - /*154*/ 4, - /*155*/ 5, - /*156*/ 4, - /*157*/ 5, - /*158*/ 5, - /*159*/ 6, - /*160*/ 2, - /*161*/ 3, - /*162*/ 3, - /*163*/ 4, - /*164*/ 3, - /*165*/ 4, - /*166*/ 4, - /*167*/ 5, - /*168*/ 3, - /*169*/ 4, - /*170*/ 4, - /*171*/ 5, - /*172*/ 4, - /*173*/ 5, - /*174*/ 5, - /*175*/ 6, - /*176*/ 3, - /*177*/ 4, - /*178*/ 4, - /*179*/ 5, - /*180*/ 4, - /*181*/ 5, - /*182*/ 5, - /*183*/ 6, - /*184*/ 4, - /*185*/ 5, - /*186*/ 5, - /*187*/ 6, - /*188*/ 5, - /*189*/ 6, - /*190*/ 6, - /*191*/ 7, - /*192*/ 2, - /*193*/ 3, - /*194*/ 3, - /*195*/ 4, - /*196*/ 3, - /*197*/ 4, - /*198*/ 4, - /*199*/ 5, - /*200*/ 3, - /*201*/ 4, - /*202*/ 4, - /*203*/ 5, - /*204*/ 4, - /*205*/ 5, - /*206*/ 5, - /*207*/ 6, - /*208*/ 3, - /*209*/ 4, - /*210*/ 4, - /*211*/ 5, - /*212*/ 4, - /*213*/ 5, - /*214*/ 5, - /*215*/ 6, - /*216*/ 4, - /*217*/ 5, - /*218*/ 5, - /*219*/ 6, - /*220*/ 5, - /*221*/ 6, - /*222*/ 6, - /*223*/ 7, - /*224*/ 3, - /*225*/ 4, - /*226*/ 4, - /*227*/ 5, - /*228*/ 4, - /*229*/ 5, - /*230*/ 5, - /*231*/ 6, - /*232*/ 4, - /*233*/ 5, - /*234*/ 5, - /*235*/ 6, - /*236*/ 5, - /*237*/ 6, - /*238*/ 6, - /*239*/ 7, - /*240*/ 4, - /*241*/ 5, - /*242*/ 5, - /*243*/ 6, - /*244*/ 5, - /*245*/ 6, - /*246*/ 6, - /*247*/ 7, - /*248*/ 5, - /*249*/ 6, - /*250*/ 6, - /*251*/ 7, - /*252*/ 6, - /*253*/ 7, - /*254*/ 7, - /*255*/ 8, -}; -/* Table-driven popcount, with 8-bit tables */ -/* 6 ops plus 4 casts and 4 lookups, 0 long immediates, 4 stages */ -uint32_t -popcount(uint32_t x) -{ - return popcount_table_8[(uint8_t)x] + - popcount_table_8[(uint8_t)(x >> 8)] + - popcount_table_8[(uint8_t)(x >> 16)] + - popcount_table_8[(uint8_t)(x >> 24)]; -} - -/* TODO: Add a 16-bit variant */ diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs --- a/tests/HashMapProperties.hs +++ b/tests/HashMapProperties.hs @@ -40,6 +40,45 @@ pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=) +-- We cannot compare to `Data.Map` as ordering is different. +pOrd1 :: [(Key, Int)] -> Bool +pOrd1 xs = compare x x == EQ + where + x = HM.fromList xs + +pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool +pOrd2 xs ys zs = case (compare x y, compare y z) of + (EQ, o) -> compare x z == o + (o, EQ) -> compare x z == o + (LT, LT) -> compare x z == LT + (GT, GT) -> compare x z == GT + (LT, GT) -> True -- ys greater than xs and zs. + (GT, LT) -> True + where + x = HM.fromList xs + y = HM.fromList ys + z = HM.fromList zs + +pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool +pOrd3 xs ys = case (compare x y, compare y x) of + (EQ, EQ) -> True + (LT, GT) -> True + (GT, LT) -> True + _ -> False + where + x = HM.fromList xs + y = HM.fromList ys + +pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool +pOrdEq xs ys = case (compare x y, x == y) of + (EQ, True) -> True + (LT, False) -> True + (GT, False) -> True + _ -> False + where + x = HM.fromList xs + y = HM.fromList ys + pReadShow :: [(Key, Int)] -> Bool pReadShow xs = M.fromList xs == read (show (M.fromList xs)) @@ -254,6 +293,10 @@ testGroup "instances" [ testProperty "==" pEq , testProperty "/=" pNeq + , testProperty "compare reflexive" pOrd1 + , testProperty "compare transitive" pOrd2 + , testProperty "compare antisymmetric" pOrd3 + , testProperty "Ord => Eq" pOrdEq , testProperty "Read/Show" pReadShow , testProperty "Functor" pFunctor , testProperty "Foldable" pFoldable diff --git a/tests/HashSetProperties.hs b/tests/HashSetProperties.hs --- a/tests/HashSetProperties.hs +++ b/tests/HashSetProperties.hs @@ -34,6 +34,45 @@ pNeq :: [Key] -> [Key] -> Bool pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=) +-- We cannot compare to `Data.Map` as ordering is different. +pOrd1 :: [Key] -> Bool +pOrd1 xs = compare x x == EQ + where + x = S.fromList xs + +pOrd2 :: [Key] -> [Key] -> [Key] -> Bool +pOrd2 xs ys zs = case (compare x y, compare y z) of + (EQ, o) -> compare x z == o + (o, EQ) -> compare x z == o + (LT, LT) -> compare x z == LT + (GT, GT) -> compare x z == GT + (LT, GT) -> True -- ys greater than xs and zs. + (GT, LT) -> True + where + x = S.fromList xs + y = S.fromList ys + z = S.fromList zs + +pOrd3 :: [Key] -> [Key] -> Bool +pOrd3 xs ys = case (compare x y, compare y x) of + (EQ, EQ) -> True + (LT, GT) -> True + (GT, LT) -> True + _ -> False + where + x = S.fromList xs + y = S.fromList ys + +pOrdEq :: [Key] -> [Key] -> Bool +pOrdEq xs ys = case (compare x y, x == y) of + (EQ, True) -> True + (LT, False) -> True + (GT, False) -> True + _ -> False + where + x = S.fromList xs + y = S.fromList ys + pReadShow :: [Key] -> Bool pReadShow xs = Set.fromList xs == read (show (Set.fromList xs)) @@ -136,6 +175,10 @@ [ testProperty "==" pEq , testProperty "Permutation ==" pPermutationEq , testProperty "/=" pNeq + , testProperty "compare reflexive" pOrd1 + , testProperty "compare transitive" pOrd2 + , testProperty "compare antisymmetric" pOrd3 + , testProperty "Ord => Eq" pOrdEq , testProperty "Read/Show" pReadShow , testProperty "Foldable" pFoldable , testProperty "Hashable" pHashable diff --git a/tests/List.hs b/tests/List.hs new file mode 100644 --- /dev/null +++ b/tests/List.hs @@ -0,0 +1,68 @@ +module Main (main) where + +import Data.HashMap.List +import Data.List (nub, sort, sortBy) +import Data.Ord (comparing) + +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck ((==>), (===), property, Property) + +tests :: Test +tests = testGroup "Data.HashMap.List" + [ testProperty "isPermutationBy" pIsPermutation + , testProperty "isPermutationBy of different length" pIsPermutationDiffLength + , testProperty "pUnorderedCompare" pUnorderedCompare + , testGroup "modelUnorderedCompare" + [ testProperty "reflexive" modelUnorderedCompareRefl + , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm + , testProperty "transitive" modelUnorderedCompareTrans + ] + ] + +pIsPermutation :: [Char] -> [Int] -> Bool +pIsPermutation xs is = isPermutationBy (==) xs xs' + where + is' = nub is ++ [maximum (0:is) + 1 ..] + xs' = map fst . sortBy (comparing snd) $ zip xs is' + +pIsPermutationDiffLength :: [Int] -> [Int] -> Property +pIsPermutationDiffLength xs ys = + length xs /= length ys ==> isPermutationBy (==) xs ys === False + +-- | Homogenous version of 'unorderedCompare' +-- +-- *Compare smallest non-equal elements of the two lists*. +modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering +modelUnorderedCompare as bs = compare (sort as) (sort bs) + +modelUnorderedCompareRefl :: [Int] -> Property +modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ + +modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property +modelUnorderedCompareAntiSymm xs ys = case a of + EQ -> b === EQ + LT -> b === GT + GT -> b === LT + where + a = modelUnorderedCompare xs ys + b = modelUnorderedCompare ys xs + +modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property +modelUnorderedCompareTrans xs ys zs = + case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of + (EQ, yz) -> xz === yz + (xy, EQ) -> xz === xy + (LT, LT) -> xz === LT + (GT, GT) -> xz === GT + (LT, GT) -> property True + (GT, LT) -> property True + where + xz = modelUnorderedCompare xs zs + +pUnorderedCompare :: [Int] -> [Int] -> Property +pUnorderedCompare xs ys = + unorderedCompare compare xs ys === modelUnorderedCompare xs ys + +main :: IO () +main = defaultMain [tests] diff --git a/tests/Strictness.hs b/tests/Strictness.hs --- a/tests/Strictness.hs +++ b/tests/Strictness.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -7,7 +7,18 @@ import Test.ChasingBottoms.IsBottom import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(arbitrary)) +import Test.QuickCheck (Arbitrary(arbitrary), Property, (===), (.&&.)) +import Test.QuickCheck.Function +import Test.QuickCheck.Poly (A) +import Data.Maybe (fromMaybe, isJust) +import Control.Arrow (second) +import Control.Monad (guard) +import Data.Foldable (foldl') +#if !MIN_VERSION_base(4,8,0) +import Data.Functor ((<$)) +import Data.Foldable (all) +import Prelude hiding (all) +#endif import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -79,11 +90,64 @@ pFromListWithKeyStrict f = isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)] -pFromListWithValueStrict :: [(Key, Int)] -> Bool -pFromListWithValueStrict xs = case xs of - [] -> True - (x:_) -> isBottom $ HM.fromListWith (\ _ _ -> undefined) (x:xs) +-- The strictness properties of 'fromListWith' are not entirely +-- trivial. +-- fromListWith f kvs is strict in the first value seen for each +-- key, but potentially lazy in the rest: the combining function +-- could be lazy in the "new" value. fromListWith must, however, +-- be strict in whatever value is actually inserted into the map. +-- Getting all these properties specified efficiently seems tricky. +-- Since it's not hard, we verify that the converted HashMap has +-- no unforced values. Rather than trying to go into detail for the +-- rest, this test compares the strictness behavior of fromListWith +-- to that of insertWith. The latter should be easier to specify +-- and (if we choose to do so) test thoroughly. +-- +-- We'll fake up a representation of things that are possibly +-- bottom by using Nothing to represent bottom. The combining +-- (partial) function is represented by a "lazy total" function +-- Maybe a -> Maybe a -> Maybe a, along with a function determining +-- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool, +-- indicating how the combining function should behave if neither +-- argument, just the first argument, just the second argument, +-- or both arguments are bottom. It would be quite tempting to +-- just use Maybe A -> Maybe A -> Maybe A, but that would not +-- necessarily be continous. +pFromListWithValueResultStrict :: [(Key, Maybe A)] + -> Fun (Maybe A, Maybe A) A + -> Fun (Maybe A, Maybe A) Bool + -> Property +pFromListWithValueResultStrict lst comb_lazy calc_good_raw + = all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map)) + where + recovered :: Maybe (HashMap Key (Maybe A)) + recovered = recover (fmap recover real_map) + -- What we get out of the conversion using insertWith + fake_map = foldl' (\m (k,v) -> HM.insertWith real_comb k v m) HM.empty real_list + -- A continuous version of calc_good_raw + calc_good Nothing Nothing = cgr Nothing Nothing + calc_good Nothing y@(Just _) = cgr Nothing Nothing || cgr Nothing y + calc_good x@(Just _) Nothing = cgr Nothing Nothing || cgr x Nothing + calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y + cgr = curry $ apply calc_good_raw + + -- The Maybe A -> Maybe A -> Maybe A that we're after, representing a + -- potentially less total function than comb_lazy + comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y) + + -- What we get out of the conversion using fromListWith + real_map = HM.fromListWith real_comb real_list + + -- A list that may have actual bottom values in it. + real_list = map (second (fromMaybe bottom)) lst + + -- A genuinely partial function mirroring comb + real_comb x y = fromMaybe bottom $ comb (recover x) (recover y) + + recover :: a -> Maybe a + recover a = a <$ guard (not $ isBottom a) + ------------------------------------------------------------------------ -- * Test list @@ -108,7 +172,7 @@ , testProperty "fromList is key-strict" pFromListKeyStrict , testProperty "fromList is value-strict" pFromListValueStrict , testProperty "fromListWith is key-strict" pFromListWithKeyStrict - , testProperty "fromListWith is value-strict" pFromListWithValueStrict + , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict ] ] diff --git a/unordered-containers.cabal b/unordered-containers.cabal --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -1,5 +1,5 @@ name: unordered-containers -version: 0.2.8.0 +version: 0.2.9.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been @@ -20,7 +20,7 @@ build-type: Simple cabal-version: >=1.8 extra-source-files: CHANGES.md -tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4 flag debug description: Enable debug support @@ -34,21 +34,29 @@ other-modules: Data.HashMap.Array Data.HashMap.Base - Data.HashMap.PopCount + Data.HashMap.List Data.HashMap.Unsafe Data.HashMap.UnsafeShift build-depends: - base >= 4 && < 5, + base >= 4.7 && < 5, deepseq >= 1.1, hashable >= 1.0.1.1 && < 1.3 - if impl(ghc < 7.4) - c-sources: cbits/popc.c + other-extensions: + RoleAnnotations, + UnboxedTuples, + ScopedTypeVariables, + MagicHash, + BangPatterns - ghc-options: -Wall -O2 - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs + ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans + + if impl (ghc < 8.2) + -- This is absolutely necessary (but not sufficient) for correctness due to + -- the referential-transparency-breaking mutability in unsafeInsertWith. See + -- #147 and GHC #13615 for details. The bug was fixed in GHC 8.2. + ghc-options: -feager-blackholing if flag(debug) cpp-options: -DASSERTS @@ -103,6 +111,23 @@ ghc-options: -Wall cpp-options: -DASSERTS +test-suite list-tests + hs-source-dirs: tests . + main-is: List.hs + other-modules: + Data.HashMap.List + type: exitcode-stdio-1.0 + + build-depends: + base, + containers >= 0.4, + QuickCheck >= 2.4.0.1, + test-framework >= 0.3.3, + test-framework-quickcheck2 >= 0.2.9 + + ghc-options: -Wall + cpp-options: -DASSERTS + test-suite regressions hs-source-dirs: tests main-is: Regressions.hs @@ -151,7 +176,6 @@ Data.HashMap.Array Data.HashMap.Base Data.HashMap.Lazy - Data.HashMap.PopCount Data.HashMap.Strict Data.HashMap.Unsafe Data.HashMap.UnsafeShift @@ -164,7 +188,7 @@ base, bytestring, containers, - criterion >= 1.0 && < 1.2, + criterion >= 1.0 && < 1.3, deepseq >= 1.1, deepseq-generics, hashable >= 1.0.1.1, @@ -172,14 +196,7 @@ mtl, random - if impl(ghc < 7.4) - c-sources: cbits/popc.c - - ghc-options: -Wall -O2 -rtsopts - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - if impl(ghc > 6.10) - ghc-options: -fregs-graph + ghc-options: -Wall -O2 -rtsopts -fwarn-tabs -ferror-spans if flag(debug) cpp-options: -DASSERTS