diff --git a/Data/EnumMap.hs b/Data/EnumMap.hs --- a/Data/EnumMap.hs +++ b/Data/EnumMap.hs @@ -1,9 +1,15 @@ +-- Note that all these extensions are only needed for @Whoops@ & Co +-- and only as long as "Utils.Containers.Internal.TypeError" +-- is not exposed in the containers package +-- (see https://github.com/haskell/containers/issues/586). +{-# LANGUAGE CPP, DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, TypeFamilies, UndecidableInstances #-} -- | -- Module : $Header$ -- Description : Data.IntMap with Enum keys. --- Copyright : (c) 2011-2013 Michal Terepeta +-- Copyright : (c) 2011-2019 Michal Terepeta -- License : BSD3 --- Maintainer : michal.terepeta@gmail.com +-- Maintainer : mikolaj.konarski@funktory.com -- Stability : alpha -- Portability : uses DeriveDataTypeable and GeneralizedNewtypeDeriving @@ -13,29 +19,53 @@ module Data.EnumMap ( module Data.EnumMap.Lazy +#ifdef __GLASGOW_HASKELL__ +-- For GHC, we disable these, pending removal. For anything else, +-- we just don't define them at all. , insertWith' , insertWithKey' , fold , foldWithKey +#endif ) where -import Prelude hiding ( filter, foldr, foldl, lookup, map, null ) - import Data.EnumMap.Lazy -import Data.EnumMap.Base -import qualified Data.IntMap as I +#ifdef __GLASGOW_HASKELL__ +-- Unfortunately we can't access this module: +-- import Utils.Containers.Internal.TypeError +-- so we copy-paste things first: -insertWith' :: (Enum k) => (a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a -insertWith' f k x = EnumMap . I.insertWith' f (fromEnum k) x . unWrap +import GHC.TypeLits -insertWithKey' :: (Enum k) - => (k -> a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a -insertWithKey' f k x = - EnumMap . I.insertWithKey' (f . toEnum) (fromEnum k) x . unWrap +class Whoops (a :: Symbol) -fold :: (a -> b -> b) -> b -> EnumMap k a -> b -fold f a = I.fold f a . unWrap +#if __GLASGOW_HASKELL__ >= 800 +instance TypeError ('Text a) => Whoops a +#endif -foldWithKey :: (Enum k) => (k -> a -> b -> b) -> b -> EnumMap k a -> b -foldWithKey f a = I.foldWithKey (f . toEnum) a . unWrap + +-- | This function is being removed and is no longer usable. +-- Use 'Data.EnumMap.Strict.insertWith' +insertWith' :: Whoops "Data.EnumMap.insertWith' is gone. Use Data.EnumMap.Strict.insertWith." + => (a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a +insertWith' _ _ _ _ = undefined + +-- | This function is being removed and is no longer usable. +-- Use 'Data.EnumMap.Strict.insertWithKey'. +insertWithKey' :: Whoops "Data.EnumMap.insertWithKey' is gone. Use Data.EnumMap.Strict.insertWithKey." + => (k -> a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a +insertWithKey' _ _ _ _ = undefined + +-- | This function is being removed and is no longer usable. +-- Use 'Data.EnumMap.Lazy.foldr'. +fold :: Whoops "Data.EnumMap.fold' is gone. Use Data.EnumMap.foldr or Prelude.foldr." + => (a -> b -> b) -> b -> EnumMap k a -> b +fold _ _ _ = undefined + +-- | This function is being removed and is no longer usable. +-- Use 'foldrWithKey'. +foldWithKey :: Whoops "Data.EnumMap.foldWithKey is gone. Use foldrWithKey." + => (k -> a -> b -> b) -> b -> EnumMap k a -> b +foldWithKey _ _ _ = undefined +#endif diff --git a/Data/EnumMap/Base.hs b/Data/EnumMap/Base.hs --- a/Data/EnumMap/Base.hs +++ b/Data/EnumMap/Base.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveTraversable #-} @@ -5,9 +6,9 @@ -- | -- Module : $Header$ -- Description : Data.IntMap with Enum keys. --- Copyright : (c) 2011-2013 Michal Terepeta +-- Copyright : (c) 2011-2019 Michal Terepeta -- License : BSD3 --- Maintainer : michal.terepeta@gmail.com +-- Maintainer : mikolaj.konarski@funktory.com -- Stability : alpha -- Portability : uses DeriveDataTypeable and GeneralizedNewtypeDeriving @@ -122,6 +123,10 @@ -- * Filter , filter , filterWithKey +#if (MIN_VERSION_containers(0,5,8)) + , restrictKeys + , withoutKeys +#endif , partition , partitionWithKey @@ -506,6 +511,18 @@ filterWithKey :: (Enum k) => (k -> a -> Bool) -> EnumMap k a -> EnumMap k a filterWithKey p = EnumMap . I.filterWithKey (p . toEnum) . unWrap {-# INLINE filterWithKey #-} + +#if (MIN_VERSION_containers(0,5,8)) +restrictKeys :: (Enum k) => EnumMap k a -> EnumSet k -> EnumMap k a +restrictKeys m s = + EnumMap $ I.restrictKeys (unWrap m) (EnumSet.enumSetToIntSet s) +{-# INLINE restrictKeys #-} + +withoutKeys :: (Enum k) => EnumMap k a -> EnumSet k -> EnumMap k a +withoutKeys m s = + EnumMap $ I.withoutKeys (unWrap m) (EnumSet.enumSetToIntSet s) +{-# INLINE withoutKeys #-} +#endif partition :: (a -> Bool) -> EnumMap k a -> (EnumMap k a, EnumMap k a) partition p = (EnumMap *** EnumMap) . I.partition p . unWrap diff --git a/Data/EnumMap/Lazy.hs b/Data/EnumMap/Lazy.hs --- a/Data/EnumMap/Lazy.hs +++ b/Data/EnumMap/Lazy.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} -- | -- Module : $Header$ -- Description : Data.IntMap.Lazy with Enum keys. --- Copyright : (c) 2011-2013 Michal Terepeta +-- Copyright : (c) 2011-2019 Michal Terepeta -- License : BSD3 --- Maintainer : michal.terepeta@gmail.com +-- Maintainer : mikolaj.konarski@funktory.com -- Stability : alpha -- Portability : uses DeriveDataTypeable and GeneralizedNewtypeDeriving @@ -122,6 +123,10 @@ -- * Filter , filter , filterWithKey +#if (MIN_VERSION_containers(0,5,8)) + , restrictKeys + , withoutKeys +#endif , partition , partitionWithKey @@ -156,6 +161,6 @@ , maxViewWithKey ) where -import Prelude hiding ( filter, foldr, foldl, lookup, map, null ) +import Prelude hiding (filter, foldl, foldr, lookup, map, null) import Data.EnumMap.Base diff --git a/Data/EnumMap/Strict.hs b/Data/EnumMap/Strict.hs --- a/Data/EnumMap/Strict.hs +++ b/Data/EnumMap/Strict.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} -- | -- Module : $Header$ -- Description : Data.IntMap.Strict with Enum keys. --- Copyright : (c) 2011-2013 Michal Terepeta +-- Copyright : (c) 2011-2019 Michal Terepeta -- License : BSD3 --- Maintainer : michal.terepeta@gmail.com +-- Maintainer : mikolaj.konarski@funktory.com -- Stability : alpha -- Portability : uses DeriveDataTypeable and GeneralizedNewtypeDeriving @@ -122,6 +123,10 @@ -- * Filter , filter , filterWithKey +#if (MIN_VERSION_containers(0,5,8)) + , restrictKeys + , withoutKeys +#endif , partition , partitionWithKey @@ -156,60 +161,29 @@ , maxViewWithKey ) where -import Prelude hiding ( filter, foldr, foldl, lookup, map, null ) +import Prelude hiding (filter, foldl, foldr, lookup, map, null) import qualified Prelude as P -import Control.Arrow ( (***), first, second ) +import Control.Arrow (first, second, (***)) import qualified Data.IntMap.Strict as I -import Data.EnumSet ( EnumSet ) +import Data.EnumSet (EnumSet) import qualified Data.EnumSet as EnumSet -import Data.EnumMap.Base hiding - ( findWithDefault - , singleton - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , unionsWith - , unionWith - , unionWithKey - , differenceWith - , differenceWithKey - , intersectionWith - , intersectionWithKey - , mergeWithKey - , updateMinWithKey - , updateMaxWithKey - , updateMax - , updateMin - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeysWith - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - , fromSet - , fromList - , fromListWith - , fromListWithKey - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - ) +import Data.EnumMap.Base hiding (adjust, adjustWithKey, alter, differenceWith, + differenceWithKey, findWithDefault, fromAscList, + fromAscListWith, fromAscListWithKey, + fromDistinctAscList, fromList, fromListWith, + fromListWithKey, fromSet, insert, insertLookupWithKey, + insertWith, insertWithKey, intersectionWith, + intersectionWithKey, map, mapAccum, mapAccumRWithKey, + mapAccumWithKey, mapEither, mapEitherWithKey, + mapKeysWith, mapMaybe, mapMaybeWithKey, mapWithKey, + mergeWithKey, singleton, unionWith, unionWithKey, + unionsWith, update, updateLookupWithKey, updateMax, + updateMaxWithKey, updateMin, updateMinWithKey, + updateWithKey) findWithDefault :: (Enum k) => a -> k -> EnumMap k a -> a findWithDefault def k = I.findWithDefault def (fromEnum k) . unWrap diff --git a/Data/EnumSet.hs b/Data/EnumSet.hs --- a/Data/EnumSet.hs +++ b/Data/EnumSet.hs @@ -4,9 +4,9 @@ -- | -- Module : $Header$ -- Description : Data.IntSet with Enum elements. --- Copyright : (c) 2011-2013 Michal Terepeta +-- Copyright : (c) 2011-2019 Michal Terepeta -- License : BSD3 --- Maintainer : michal.terepeta@gmail.com +-- Maintainer : mikolaj.konarski@funktory.com -- Stability : alpha -- Portability : uses DeriveDataTypeable and GeneralizedNewtypeDeriving diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,26 @@ -Copyright (c) 2011-2013 Michal Terepeta +BSD 3-Clause License All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Michal Terepeta nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +Enummapset +========== + +[![Build Status](https://travis-ci.org/Mikolaj/enummapset.svg?branch=master)](https://travis-ci.org/Mikolaj/enummapset) +[![Hackage](https://img.shields.io/hackage/v/enummapset.svg)](https://hackage.haskell.org/package/enummapset) + +This package contains simple wrappers around 'Data.IntMap' and +'Data.IntSet' with 'Enum' keys and elements respectively. +Especially useful for 'Int's wrapped with `newtype`. + +Copyright +--------- + +Copyright (c) 2011-2019 Michal Terepeta + +Copyright (c) 2019 Mikolaj Konarski and others (see git history) diff --git a/enummapset.cabal b/enummapset.cabal --- a/enummapset.cabal +++ b/enummapset.cabal @@ -1,25 +1,27 @@ name: enummapset -version: 0.5.2.2 +version: 0.6.0.1 synopsis: IntMap and IntSet with Enum keys/elements. description: This package contains simple wrappers around 'Data.IntMap' and 'Data.IntSet' with 'Enum' keys and elements respectively. - Especially useful for 'Int's wrapped with newtype. -homepage: https://github.com/michalt/enummapset -bug-reports: https://github.com/michalt/enummapset/issues + Especially useful for 'Int's wrapped with `newtype`. +homepage: https://github.com/Mikolaj/enummapset +bug-reports: https://github.com/Mikolaj/enummapset/issues license: BSD3 license-file: LICENSE +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, + GHC==8.6.3 author: Michal Terepeta -maintainer: Michal Terepeta -copyright: (c) 2011-2013 Michal Terepeta - -category: Data +maintainer: Mikolaj Konarski +category: Data Structures build-type: Simple -cabal-version: >=1.6 +cabal-version: >=1.8 +extra-source-files: README.md + source-repository head type: git - location: https://github.com/michalt/enummapset.git + location: https://github.com/Mikolaj/enummapset.git flag debug description: Debug build (more warnings, etc.) @@ -36,10 +38,38 @@ Data.EnumMap.Base build-depends: - base < 5, - containers >= 0.5.2 && < 0.6, + base >= 4.6 && < 5, + containers >= 0.5.2 && < 0.7, semigroups >=0.1 && <1.0, deepseq if flag(debug) ghc-options: -Wall + + other-extensions: CPP, BangPatterns, + DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, TypeFamilies, UndecidableInstances + +Test-suite intset-properties + hs-source-dirs: tests, . + main-is: intset-properties.hs + other-modules: + Data.EnumSet + IntSetValidity + type: exitcode-stdio-1.0 + cpp-options: -DTESTING + + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim + ghc-options: -O2 + other-extensions: CPP, BangPatterns, + DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, TypeFamilies, UndecidableInstances + + build-depends: + containers, + semigroups, + HUnit, + QuickCheck >= 2.7.1, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 diff --git a/tests/IntSetValidity.hs b/tests/IntSetValidity.hs new file mode 100644 --- /dev/null +++ b/tests/IntSetValidity.hs @@ -0,0 +1,91 @@ +-- Copied from https://github.com/haskell/containers + +{-# LANGUAGE CPP #-} +module IntSetValidity (valid) where + +import Data.Bits (xor, (.&.)) +import Data.IntSet.Internal +import Test.QuickCheck (Property, counterexample, property, (.&&.)) +import Utils.Containers.Internal.BitUtil (bitcount) + +{-------------------------------------------------------------------- + Assertions +--------------------------------------------------------------------} +-- | Returns true iff the internal structure of the IntSet is valid. +valid :: IntSet -> Property +valid t = + counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&. + counterexample "maskPowerOfTwo" (maskPowerOfTwo t) .&&. + counterexample "commonPrefix" (commonPrefix t) .&&. + counterexample "markRespected" (maskRespected t) .&&. + counterexample "tipsValid" (tipsValid t) + +-- Invariant: Nil is never found as a child of Bin. +nilNeverChildOfBin :: IntSet -> Bool +nilNeverChildOfBin t = + case t of + Nil -> True + Tip _ _ -> True + Bin _ _ l r -> noNilInSet l && noNilInSet r + where + noNilInSet t' = + case t' of + Nil -> False + Tip _ _ -> True + Bin _ _ l' r' -> noNilInSet l' && noNilInSet r' + +-- Invariant: The Mask is a power of 2. It is the largest bit position at which +-- two elements of the set differ. +maskPowerOfTwo :: IntSet -> Bool +maskPowerOfTwo t = + case t of + Nil -> True + Tip _ _ -> True + Bin _ m l r -> + bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r + +-- Invariant: Prefix is the common high-order bits that all elements share to +-- the left of the Mask bit. +commonPrefix :: IntSet -> Bool +commonPrefix t = + case t of + Nil -> True + Tip _ _ -> True + b@(Bin p _ l r) -> all (sharedPrefix p) (elems b) && commonPrefix l && commonPrefix r + where + sharedPrefix :: Prefix -> Int -> Bool + sharedPrefix p a = p == p .&. a + +-- Invariant: In Bin prefix mask left right, left consists of the elements that +-- don't have the mask bit set; right is all the elements that do. +maskRespected :: IntSet -> Bool +maskRespected t = + case t of + Nil -> True + Tip _ _ -> True + Bin _ binMask l r -> + all (\x -> zero x binMask) (elems l) && + all (\x -> not (zero x binMask)) (elems r) && + maskRespected l && + maskRespected r + +-- Invariant: The Prefix is zero for the last 5 (on 32 bit arches) or 6 bits +-- (on 64 bit arches). The values of the set represented by a tip +-- are the prefix plus the indices of the set bits in the bit map. +-- +-- Note: Valid entries stored in tip omitted. +tipsValid :: IntSet -> Bool +tipsValid t = + case t of + Nil -> True + tip@(Tip p b) -> validTipPrefix p + Bin _ _ l r -> tipsValid l && tipsValid r + +validTipPrefix :: Prefix -> Bool +#if WORD_SIZE_IN_BITS==32 +-- Last 5 bits of the prefix must be zero for 32 bit arches. +validTipPrefix p = (0x0000001F .&. p) == 0 +#else +-- Last 6 bits of the prefix must be zero 64 bit anches. +validTipPrefix p = (0x000000000000003F .&. p) == 0 +#endif diff --git a/tests/intset-properties.hs b/tests/intset-properties.hs new file mode 100644 --- /dev/null +++ b/tests/intset-properties.hs @@ -0,0 +1,416 @@ +-- Copied from https://github.com/haskell/containers and tweaked slithgly + +{-# LANGUAGE CPP #-} +import Data.Bits (popCount, (.&.)) +import Data.EnumSet +import Data.IntSet.Internal (IntSet (Bin)) +import Data.List (nub, sort) +import qualified Data.List as List +import Data.Monoid (mempty) +import qualified Data.Set as Set +import Data.Word (Word) +import qualified IntSetValidity as IntSetValidity (valid) +import Prelude hiding (filter, foldl, foldr, lookup, map, null) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test, Testable) +import Test.QuickCheck hiding ((.&.)) + +valid :: EnumSet k -> Property +valid = IntSetValidity.valid . enumSetToIntSet + +main :: IO () +main = defaultMain [ testCase "lookupLT" test_lookupLT + , testCase "lookupGT" test_lookupGT + , testCase "lookupLE" test_lookupLE + , testCase "lookupGE" test_lookupGE + , testCase "split" test_split + , testProperty "prop_Valid" prop_Valid + , testProperty "prop_EmptyValid" prop_EmptyValid + , testProperty "prop_SingletonValid" prop_SingletonValid + , testProperty "prop_InsertIntoEmptyValid" prop_InsertIntoEmptyValid + , testProperty "prop_Single" prop_Single + , testProperty "prop_Member" prop_Member + , testProperty "prop_NotMember" prop_NotMember + , testProperty "prop_LookupLT" prop_LookupLT + , testProperty "prop_LookupGT" prop_LookupGT + , testProperty "prop_LookupLE" prop_LookupLE + , testProperty "prop_LookupGE" prop_LookupGE + , testProperty "prop_InsertDelete" prop_InsertDelete + , testProperty "prop_MemberFromList" prop_MemberFromList + , testProperty "prop_UnionInsert" prop_UnionInsert + , testProperty "prop_UnionAssoc" (prop_UnionAssoc :: EnumSet Ordering -> EnumSet Ordering -> EnumSet Ordering -> Bool) + , testProperty "prop_UnionComm" (prop_UnionComm :: EnumSet Integer -> EnumSet Integer -> Bool) + , testProperty "prop_Diff" prop_Diff + , testProperty "prop_Int" prop_Int + , testProperty "prop_Ordered" prop_Ordered + , testProperty "prop_List" prop_List + , testProperty "prop_DescList" prop_DescList + , testProperty "prop_AscDescList" prop_AscDescList + , testProperty "prop_fromList" prop_fromList +-- , testProperty "prop_MaskPow2" prop_MaskPow2 +-- , testProperty "prop_Prefix" prop_Prefix +-- , testProperty "prop_LeftRight" prop_LeftRight + , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf + , testProperty "prop_isProperSubsetOf2" (prop_isProperSubsetOf2 :: EnumSet Double -> EnumSet Double -> Bool) + , testProperty "prop_isSubsetOf" prop_isSubsetOf + , testProperty "prop_isSubsetOf2" (prop_isSubsetOf2 :: EnumSet Bool -> EnumSet Bool -> Bool) +-- , testProperty "prop_disjoint" prop_disjoint + , testProperty "prop_size" prop_size + , testProperty "prop_findMax" prop_findMax + , testProperty "prop_findMin" prop_findMin + , testProperty "prop_ord" prop_ord + , testProperty "prop_readShow" prop_readShow + , testProperty "prop_foldR" prop_foldR + , testProperty "prop_foldR'" prop_foldR' + , testProperty "prop_foldL" prop_foldL + , testProperty "prop_foldL'" prop_foldL' + , testProperty "prop_map" (prop_map :: EnumSet Char -> Bool) + , testProperty "prop_maxView" prop_maxView + , testProperty "prop_minView" prop_minView + , testProperty "prop_split" prop_split + , testProperty "prop_splitMember" prop_splitMember +-- , testProperty "prop_splitRoot" prop_splitRoot + , testProperty "prop_partition" prop_partition + , testProperty "prop_filter" prop_filter + , testProperty "prop_bitcount" prop_bitcount + ] + +---------------------------------------------------------------- +-- Unit tests +---------------------------------------------------------------- + +test_lookupLT :: Assertion +test_lookupLT = do + lookupLT 3 (fromList [3, 5]) @?= Nothing + lookupLT 5 (fromList [3, 5]) @?= Just 3 + +test_lookupGT :: Assertion +test_lookupGT = do + lookupGT 4 (fromList [3, 5]) @?= Just 5 + lookupGT 5 (fromList [3, 5]) @?= Nothing + +test_lookupLE :: Assertion +test_lookupLE = do + lookupLE 2 (fromList [3, 5]) @?= Nothing + lookupLE 4 (fromList [3, 5]) @?= Just 3 + lookupLE 5 (fromList [3, 5]) @?= Just 5 + +test_lookupGE :: Assertion +test_lookupGE = do + lookupGE 3 (fromList [3, 5]) @?= Just 3 + lookupGE 4 (fromList [3, 5]) @?= Just 5 + lookupGE 6 (fromList [3, 5]) @?= Nothing + +test_split :: Assertion +test_split = do + split 3 (fromList [1..5]) @?= (fromList [1,2], fromList [4,5]) + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance (Enum k, Arbitrary k) => Arbitrary (EnumSet k) where + arbitrary = do{ xs <- arbitrary + ; return (fromList xs) + } + +{-------------------------------------------------------------------- + Valid IntMaps +--------------------------------------------------------------------} +forValid :: Testable a => (EnumSet Int -> a) -> Property +forValid f = forAll arbitrary $ \t -> + classify (size t == 0) "empty" $ + classify (size t > 0 && size t <= 10) "small" $ + classify (size t > 10 && size t <= 64) "medium" $ + classify (size t > 64) "large" $ f t + +forValidUnitTree :: Testable a => (EnumSet Int -> a) -> Property +forValidUnitTree f = forValid f + +prop_Valid :: Property +prop_Valid = forValidUnitTree $ \t -> valid t + +{-------------------------------------------------------------------- + Construction validity +--------------------------------------------------------------------} + +prop_EmptyValid :: Property +prop_EmptyValid = + valid empty + +prop_SingletonValid :: Int -> Property +prop_SingletonValid x = + valid (singleton x) + +prop_InsertIntoEmptyValid :: Int -> Property +prop_InsertIntoEmptyValid x = + valid (insert x empty) + +{-------------------------------------------------------------------- + Single, Member, Insert, Delete, Member, FromList +--------------------------------------------------------------------} +prop_Single :: Int -> Bool +prop_Single x + = (insert x empty == singleton x) + +prop_Member :: [Int] -> Int -> Bool +prop_Member xs n = + let m = fromList xs + in all (\k -> k `member` m == (k `elem` xs)) (n : xs) + +prop_NotMember :: [Int] -> Int -> Bool +prop_NotMember xs n = + let m = fromList xs + in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs) + +test_LookupSomething :: (Int -> EnumSet Int -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool +test_LookupSomething lookup' cmp xs = + let odd_sorted_xs = filter_odd $ nub $ sort xs + t = fromList odd_sorted_xs + test x = case List.filter (`cmp` x) odd_sorted_xs of + [] -> lookup' x t == Nothing + cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element + | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element + in all test xs + + where filter_odd [] = [] + filter_odd [_] = [] + filter_odd (_ : o : xs) = o : filter_odd xs + +prop_LookupLT :: [Int] -> Bool +prop_LookupLT = test_LookupSomething lookupLT (<) + +prop_LookupGT :: [Int] -> Bool +prop_LookupGT = test_LookupSomething lookupGT (>) + +prop_LookupLE :: [Int] -> Bool +prop_LookupLE = test_LookupSomething lookupLE (<=) + +prop_LookupGE :: [Int] -> Bool +prop_LookupGE = test_LookupSomething lookupGE (>=) + +prop_InsertDelete :: Int -> EnumSet Int -> Property +prop_InsertDelete k t + = not (member k t) ==> + case delete k (insert k t) of + t' -> valid t' .&&. t' === t + +prop_MemberFromList :: [Int] -> Bool +prop_MemberFromList xs + = all (`member` t) abs_xs && all ((`notMember` t) . negate) abs_xs + where abs_xs = [abs x | x <- xs, x /= 0] + t = fromList abs_xs + +{-------------------------------------------------------------------- + Union, Difference and Intersection +--------------------------------------------------------------------} +prop_UnionInsert :: Int -> EnumSet Int -> Property +prop_UnionInsert x t = + case union t (singleton x) of + t' -> + valid t' .&&. + t' === insert x t + +prop_UnionAssoc :: EnumSet k -> EnumSet k -> EnumSet k -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: EnumSet k -> EnumSet k -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == union t2 t1) + +prop_Diff :: [Int] -> [Int] -> Property +prop_Diff xs ys = + case difference (fromList xs) (fromList ys) of + t -> + valid t .&&. + toAscList t === List.sort ((List.\\) (nub xs) (nub ys)) + +prop_Int :: [Int] -> [Int] -> Property +prop_Int xs ys = + case intersection (fromList xs) (fromList ys) of + t -> + valid t .&&. + toAscList t === List.sort (nub ((List.intersect) (xs) (ys))) +{- + +prop_disjoint :: EnumSet k -> EnumSet k -> Bool +prop_disjoint a b = a `disjoint` b == null (a `intersection` b) + +-} + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == toAscList (fromList xs)) + +prop_DescList :: [Int] -> Bool +prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs)) + +prop_AscDescList :: [Int] -> Bool +prop_AscDescList xs = toAscList s == reverse (toDescList s) + where s = fromList xs + +prop_fromList :: [Int] -> Property +prop_fromList xs + = case fromList xs of + t -> valid t .&&. + t === fromAscList sort_xs .&&. + t === fromDistinctAscList nub_sort_xs .&&. + t === List.foldr insert empty xs + where sort_xs = sort xs + nub_sort_xs = List.map List.head $ List.group sort_xs + +{-------------------------------------------------------------------- + Bin invariants +--------------------------------------------------------------------} +powersOf2 :: EnumSet Int +powersOf2 = fromList [2^i | i <- [0..63]] + +{- + +-- Check the invariant that the mask is a power of 2. +prop_MaskPow2 :: EnumSet k -> Bool +prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right +prop_MaskPow2 _ = True + +-- Check that the prefix satisfies its invariant. +prop_Prefix :: EnumSet k -> Bool +prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right +prop_Prefix _ = True + +-- Check that the left elements don't have the mask bit set, and the right +-- ones do. +prop_LeftRight :: EnumSet k -> Bool +prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right] +prop_LeftRight _ = True + +-} + +{-------------------------------------------------------------------- + EnumSet k operations are like Set operations +--------------------------------------------------------------------} +toSet :: EnumSet Int -> Set.Set Int +toSet = Set.fromList . toList + +-- Check that EnumSet k.isProperSubsetOf is the same as Set.isProperSubsetOf. +prop_isProperSubsetOf :: EnumSet Int -> EnumSet Int -> Bool +prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b) + +-- In the above test, isProperSubsetOf almost always returns False (since a +-- random set is almost never a subset of another random set). So this second +-- test checks the True case. +prop_isProperSubsetOf2 :: EnumSet k -> EnumSet k -> Bool +prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where + c = union a b + +prop_isSubsetOf :: EnumSet Int -> EnumSet Int -> Bool +prop_isSubsetOf a b = isSubsetOf a b == Set.isSubsetOf (toSet a) (toSet b) + +prop_isSubsetOf2 :: EnumSet k -> EnumSet k -> Bool +prop_isSubsetOf2 a b = isSubsetOf a (union a b) + +prop_size :: EnumSet Int -> Property +prop_size s = sz === foldl' (\i _ -> i + 1) (0 :: Int) s .&&. + sz === List.length (toList s) + where sz = size s + +prop_findMax :: EnumSet Int -> Property +prop_findMax s = not (null s) ==> findMax s == maximum (toList s) + +prop_findMin :: EnumSet Int -> Property +prop_findMin s = not (null s) ==> findMin s == minimum (toList s) + +prop_ord :: EnumSet Int -> EnumSet Int -> Bool +prop_ord s1 s2 = s1 `compare` s2 == toList s1 `compare` toList s2 + +prop_readShow :: EnumSet Int -> Bool +prop_readShow s = s == read (show s) + +prop_foldR :: EnumSet Int -> Bool +prop_foldR s = foldr (:) [] s == toList s + +prop_foldR' :: EnumSet Int -> Bool +prop_foldR' s = foldr' (:) [] s == toList s + +prop_foldL :: EnumSet Int -> Bool +prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s) + +prop_foldL' :: EnumSet Int -> Bool +prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s) + +prop_map :: Enum k => EnumSet k -> Bool +prop_map s = map id s == s + +prop_maxView :: EnumSet Int -> Bool +prop_maxView s = case maxView s of + Nothing -> null s + Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s' + +prop_minView :: EnumSet Int -> Bool +prop_minView s = case minView s of + Nothing -> null s + Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s' + +prop_split :: EnumSet Int -> Int -> Property +prop_split s i = case split i s of + (s1,s2) -> valid s1 .&&. + valid s2 .&&. + all (i) (toList s2) .&&. + i `delete` s === union s1 s2 + +prop_splitMember :: EnumSet Int -> Int -> Property +prop_splitMember s i = case splitMember i s of + (s1,t,s2) -> valid s1 .&&. + valid s2 .&&. + all (i) (toList s2) .&&. + t === i `member` s .&&. + i `delete` s === union s1 s2 + + +{- +prop_splitRoot :: EnumSet k -> Bool +prop_splitRoot s = loop ls && (s == unions ls) + where + ls = splitRoot s + loop [] = True + loop (s1:rst) = List.null + [ (x,y) | x <- toList s1 + , y <- toList (unions rst) + , x > y ] +-} + +prop_partition :: EnumSet Int -> Int -> Property +prop_partition s i = case partition odd s of + (s1,s2) -> valid s1 .&&. + valid s2 .&&. + all odd (toList s1) .&&. + all even (toList s2) .&&. + s === s1 `union` s2 + +prop_filter :: EnumSet Int -> Int -> Property +prop_filter s i = + let parts = partition odd s + odds = filter odd s + evens = filter even s + in valid odds .&&. + valid evens .&&. + parts === (odds, evens) + +prop_bitcount :: Int -> Word -> Bool +prop_bitcount a w = bitcount_orig a w == bitcount_new a w + where + bitcount_orig a0 x0 = go a0 x0 + where go a 0 = a + go a x = go (a + 1) (x .&. (x-1)) + bitcount_new a x = a + popCount x