diff --git a/primitive-containers.cabal b/primitive-containers.cabal --- a/primitive-containers.cabal +++ b/primitive-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: primitive-containers -version: 0.4.0 +version: 0.4.1 synopsis: containers backed by arrays description: Containers backed by flat arrays. Updates require rebuilding the @@ -41,13 +41,13 @@ , deepseq >= 1.4 , primitive-unlifted >= 0.1 && <0.2 if flag(checked) - build-depends: - contiguous-checked >= 0.4 && < 0.5 - , primitive-checked >= 0.6.4.1 + build-depends: + contiguous-checked >= 0.4 && < 0.6 + , primitive-checked >= 0.6.4.1 && < 0.8 else - build-depends: - contiguous >= 0.4 && < 0.5 - , primitive >= 0.6.4 + build-depends: + contiguous >= 0.4 && < 0.6 + , primitive >= 0.6.4 && < 0.8 exposed-modules: Data.Continuous.Set.Lifted Data.Diet.Map.Strict.Lifted.Lifted @@ -103,7 +103,7 @@ , containers >= 0.5.10 , primitive , primitive-containers - , primitive-unlifted + , primitive-unlifted >= 0.1.1 , quickcheck-classes >= 0.6.2 , tasty , tasty-hunit diff --git a/src/Data/Continuous/Set/Internal.hs b/src/Data/Continuous/Set/Internal.hs --- a/src/Data/Continuous/Set/Internal.hs +++ b/src/Data/Continuous/Set/Internal.hs @@ -24,15 +24,12 @@ import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate,null) import Control.Monad.ST (ST,runST) -import Data.Bool (bool) import Data.Word (Word8) import Data.Primitive.Contiguous (Contiguous,Element,Mutable) import Data.Primitive (PrimArray,MutablePrimArray) import Data.Bits (unsafeShiftL,unsafeShiftR,(.|.),(.&.)) -import qualified Data.Foldable as F import qualified Prelude as P import qualified Data.Primitive.Contiguous as I -import qualified Data.Concatenation as C -- Although the data constructor for this type is exported, -- it isn't needed by anything in the continuous Set modules. It is needed @@ -245,13 +242,13 @@ GT -> Just (xinc,x) LT -> Just (yinc,y) EQ -> Just (max xinc yinc,y) - + eatFromPositiveInfinity :: Inclusivity -- inclusivity for positive infinity -> a -- lower bound for positive infinity -> arr a -- set 1 -> PrimArray Word8 - -> Int -- pairs in set 1 + -> Int -- pairs in set 1 -> arr a -- set 2 -> PrimArray Word8 -> Int -- pairs in set 2 @@ -263,7 +260,7 @@ -> a -- upper bound for negative infinity -> arr a -- set 1 -> PrimArray Word8 - -> Int -- pairs in set 1 + -> Int -- pairs in set 1 -> arr a -- set 2 -> PrimArray Word8 -> Int -- pairs in set 2 @@ -391,7 +388,7 @@ where go !start !end = if end <= start then if end == start - then + then let !(# valLo #) = I.index# keys (2 * start) !(# valHi #) = I.index# keys (2 * start + 1) in case indexInclusivityPair incs start of diff --git a/src/Data/Map/Internal.hs b/src/Data/Map/Internal.hs --- a/src/Data/Map/Internal.hs +++ b/src/Data/Map/Internal.hs @@ -31,6 +31,7 @@ , foldrMapWithKeyM' -- * Traversals , traverse + , traverseWithKey , traverseWithKey_ -- * Functions , append @@ -78,7 +79,6 @@ import Data.Set.Internal (Set(..)) import qualified Data.Concatenation as C -import qualified Data.List as L import qualified Data.Primitive.Contiguous as I import qualified Data.Semigroup as SG import qualified Prelude as P @@ -319,6 +319,11 @@ vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze return (Map ksFinal vsFinal) +newtype STA arr a = STA { _runSTA :: forall s. Mutable arr s a -> ST s (arr a) } + +runSTA :: (Contiguous arr, Element arr a) => Int -> STA arr a -> arr a +runSTA !sz (STA m) = runST $ I.new sz >>= \arr -> m arr + showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) @@ -642,6 +647,14 @@ {-# INLINEABLE traverse #-} traverse f (Map theKeys theVals) = fmap (Map theKeys) (I.traverse f theVals) + +traverseWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr v', Applicative f) + => (k -> v -> f v') + -> Map karr varr k v + -> f (Map karr varr k v') +{-# INLINEABLE traverseWithKey #-} +traverseWithKey f (Map theKeys theVals) = fmap (Map theKeys) + $ I.itraverse (\i v -> f (I.index theKeys i) v) theVals traverseWithKey_ :: forall karr varr k v m b. (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> v -> m b) diff --git a/src/Data/Map/Lifted/Lifted.hs b/src/Data/Map/Lifted/Lifted.hs --- a/src/Data/Map/Lifted/Lifted.hs +++ b/src/Data/Map/Lifted/Lifted.hs @@ -19,6 +19,10 @@ , foldlWithKey' , foldrWithKey' , foldMapWithKey' + -- * Traversals + , traverse + , traverseWithKey + , traverseWithKey_ -- * Monadic Folds , foldlWithKeyM' , foldrWithKeyM' @@ -35,7 +39,7 @@ , elems ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Data.Semigroup (Semigroup) import Data.Primitive.Array (Array) @@ -164,6 +168,27 @@ -> Map k v -> Map k v appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n) + +-- | /O(n)/ traversal over the values in the map. +traverse :: Applicative f + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: Applicative f + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ like 'traverseWithKey', but discards the results. +traverseWithKey_ :: Applicative f + => (k -> v -> f b) + -> Map k v + -> f () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. diff --git a/src/Data/Map/Lifted/Unlifted.hs b/src/Data/Map/Lifted/Unlifted.hs --- a/src/Data/Map/Lifted/Unlifted.hs +++ b/src/Data/Map/Lifted/Unlifted.hs @@ -24,6 +24,10 @@ , foldrWithKeyM' , foldlMapWithKeyM' , foldrMapWithKeyM' + -- * Traversals + , traverse + , traverseWithKey + , traverseWithKey_ -- * List Conversion , toList , fromList @@ -34,7 +38,7 @@ , elems ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Data.Semigroup (Semigroup) import Data.Primitive (Array) @@ -162,6 +166,27 @@ -> Map k v -> Map k v appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n) + +-- | /O(n)/ traversal over the values in the map. +traverse :: (Applicative f, PrimUnlifted v, PrimUnlifted b) + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, PrimUnlifted v, PrimUnlifted b) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ like 'traverseWithKey', but discards the results. +traverseWithKey_ :: (Applicative f, PrimUnlifted v, PrimUnlifted b) + => (k -> v -> f b) + -> Map k v + -> f () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. diff --git a/src/Data/Map/Unboxed/Lifted.hs b/src/Data/Map/Unboxed/Lifted.hs --- a/src/Data/Map/Unboxed/Lifted.hs +++ b/src/Data/Map/Unboxed/Lifted.hs @@ -30,6 +30,10 @@ , foldrWithKeyM' , foldlMapWithKeyM' , foldrMapWithKeyM' + -- * Traversals + , traverse + , traverseWithKey + , traverseWithKey_ -- * List Conversion , toList , fromList @@ -42,7 +46,7 @@ , unsafeFreezeZip ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Control.DeepSeq (NFData) import Control.Monad.ST (ST) @@ -189,6 +193,27 @@ -> Map k v -> Map k v appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n) + +-- | /O(n)/ traversal over the values in the map. +traverse :: (Applicative f, Prim k) + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, Prim k) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ like 'traverseWithKey', but discards the results. +traverseWithKey_ :: (Applicative f, Prim k) + => (k -> v -> f b) + -> Map k v + -> f () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. diff --git a/src/Data/Map/Unboxed/Unboxed.hs b/src/Data/Map/Unboxed/Unboxed.hs --- a/src/Data/Map/Unboxed/Unboxed.hs +++ b/src/Data/Map/Unboxed/Unboxed.hs @@ -26,6 +26,8 @@ , foldlMapWithKeyM' , foldrMapWithKeyM' -- * Traversals + , traverse + , traverseWithKey , traverseWithKey_ -- * List Conversion , toList @@ -39,7 +41,7 @@ , unsafeFreezeZip ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Control.Monad.Primitive (PrimMonad) import Control.Monad.ST (ST) @@ -47,7 +49,6 @@ import Data.Primitive.Types (Prim) import Data.Semigroup (Semigroup) import Data.Set.Unboxed.Internal (Set(..)) -import GHC.Exts (inline) import qualified Data.Map.Internal as I import qualified Data.Semigroup as SG @@ -243,6 +244,20 @@ -> Map k v -- ^ map -> m b foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m + +-- | /O(n)/ traversal over the values in the map. +traverse :: (Applicative f, Prim k, Prim v, Prim b) + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, Prim k, Prim v, Prim b) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m -- | /O(n)/ Traverse the keys and values of the map from left to right. traverseWithKey_ :: (Monad m, Prim k, Prim v) diff --git a/src/Data/Map/Unboxed/Unlifted.hs b/src/Data/Map/Unboxed/Unlifted.hs --- a/src/Data/Map/Unboxed/Unlifted.hs +++ b/src/Data/Map/Unboxed/Unlifted.hs @@ -29,6 +29,8 @@ , foldrMapWithKeyM' -- * Traversals , traverse + , traverseWithKey + , traverseWithKey_ -- * List Conversion , fromList , fromListAppend @@ -249,11 +251,26 @@ foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m -- | /O(n)/ Traverse the values of the map. -traverse :: (Applicative m, Prim k, PrimUnlifted v, PrimUnlifted w) - => (v -> m w) +traverse :: (Applicative m, Prim k, PrimUnlifted v, PrimUnlifted b) + => (v -> m b) -> Map k v - -> m (Map k w) -traverse f (Map m) = fmap Map (I.traverse f m) + -> m (Map k b) +traverse f (Map m) = Map <$> (I.traverse f m) + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, Prim k, PrimUnlifted v, PrimUnlifted b) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ Traverse the keys and values of the map from left to right. +traverseWithKey_ :: (Monad m, Prim k, PrimUnlifted v) + => (k -> v -> m b) -- ^ reduction + -> Map k v -- ^ map + -> m () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m + -- | /O(n)/ Fold over the keys and values of the map with a monoidal -- accumulator. This function does not have left and right variants since diff --git a/src/Data/Map/Unlifted/Lifted.hs b/src/Data/Map/Unlifted/Lifted.hs --- a/src/Data/Map/Unlifted/Lifted.hs +++ b/src/Data/Map/Unlifted/Lifted.hs @@ -21,6 +21,10 @@ , foldrWithKeyM' , foldlMapWithKeyM' , foldrMapWithKeyM' + -- * Traversals + , traverse + , traverseWithKey + , traverseWithKey_ -- * List Conversion , fromList , fromListAppend @@ -31,7 +35,7 @@ , unsafeFreezeZip ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Control.Monad.ST (ST) import Data.Semigroup (Semigroup) @@ -154,6 +158,27 @@ -> Map k v -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m) + +-- | /O(n)/ traversal over the values in the map. +traverse :: (Applicative f, PrimUnlifted k) + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, PrimUnlifted k) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ like 'traverseWithKey', but discards the results. +traverseWithKey_ :: (Applicative f, PrimUnlifted k) + => (k -> v -> f b) + -> Map k v + -> f () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. diff --git a/src/Data/Map/Unlifted/Unboxed.hs b/src/Data/Map/Unlifted/Unboxed.hs --- a/src/Data/Map/Unlifted/Unboxed.hs +++ b/src/Data/Map/Unlifted/Unboxed.hs @@ -20,6 +20,10 @@ , foldrWithKeyM' , foldlMapWithKeyM' , foldrMapWithKeyM' + -- * Traversals + , traverse + , traverseWithKey + , traverseWithKey_ -- * List Conversion , fromList , fromListAppend @@ -30,7 +34,7 @@ , unsafeFreezeZip ) where -import Prelude hiding (lookup,map) +import Prelude hiding (lookup,map,traverse) import Control.Monad.ST (ST) import Data.Semigroup (Semigroup) @@ -151,6 +155,27 @@ -> Map k v -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m) + +-- | /O(n)/ traversal over the values in the map. +traverse :: (Applicative f, PrimUnlifted k, Prim v, Prim b) + => (v -> f b) + -> Map k v + -> f (Map k b) +traverse f (Map m) = Map <$> I.traverse f m + +-- | /O(n)/ traversal over the values in the map, using the keys. +traverseWithKey :: (Applicative f, PrimUnlifted k, Prim v, Prim b) + => (k -> v -> f b) + -> Map k v + -> f (Map k b) +traverseWithKey f (Map m) = Map <$> I.traverseWithKey f m + +-- | /O(n)/ like 'traverseWithKey', but discards the results. +traverseWithKey_ :: (Applicative f, PrimUnlifted k, Prim v) + => (k -> v -> f b) + -> Map k v + -> f () +traverseWithKey_ f (Map m) = I.traverseWithKey_ f m -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. diff --git a/src/Data/Set/Unboxed/Internal.hs b/src/Data/Set/Unboxed/Internal.hs --- a/src/Data/Set/Unboxed/Internal.hs +++ b/src/Data/Set/Unboxed/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} module Data.Set.Unboxed.Internal ( Set(..) @@ -13,9 +14,9 @@ import Prelude hiding (foldr) import Data.Hashable (Hashable) -import Data.Primitive (Prim,PrimArray,Array) +import Data.Primitive (Prim,PrimArray(..)) import Data.Semigroup (Semigroup) -import Text.Show (showListWith) +import Data.Primitive.Unlifted.Class (PrimUnlifted(..)) import qualified Data.Foldable as F import qualified Data.Hashable as H @@ -44,6 +45,20 @@ instance (Hashable a, Prim a) => Hashable (Set a) where hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr + +instance PrimUnlifted (Set a) where + type Unlifted (Set a) = E.ByteArray# + {-# inline toUnlifted# #-} + {-# inline fromUnlifted# #-} + {-# inline writeUnliftedArray# #-} + {-# inline readUnliftedArray# #-} + {-# inline indexUnliftedArray# #-} + toUnlifted# (Set (I.Set p)) = toUnlifted# p + fromUnlifted# b# = Set (I.Set (PrimArray b#)) + writeUnliftedArray# a i s = E.writeByteArrayArray# a i (toUnlifted# s) + readUnliftedArray# a i s0 = case E.readByteArrayArray# a i s0 of + (# s1, x #) -> (# s1, fromUnlifted# x #) + indexUnliftedArray# a i = fromUnlifted# (E.indexByteArrayArray# a i) -- | The functions that convert a list to a 'Set' are asymptotically -- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -172,7 +172,7 @@ , testGroup "Continuous" [ testGroup "Set" [ testGroup "Lifted" - [ testGroup "Unit" + [ testGroup "Unit" [ testCase "A" $ do let s = CSL.singleton Nothing (Just (Inclusive,55 :: Integer)) <> @@ -216,6 +216,7 @@ , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DSL.Set Word16))) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DSL.Set Word16))) , TQC.testProperty "member" (dietMemberProp @Word8 E.fromList DSL.member) + -- DIET SETS , TQC.testProperty "difference" dietSetDifferenceProp , TQC.testProperty "intersection" dietSetIntersectionProp , TQC.testProperty "negate" dietSetNegateProp @@ -230,6 +231,21 @@ , TQC.testProperty "border" dietSetBetweenBorderProp , TQC.testProperty "inside" dietSetBetweenBorderNearProp ] + -- S (newtype) + , TQC.testProperty "difference" dietSetDifferenceProp' + , TQC.testProperty "intersection" dietSetIntersectionProp' + , TQC.testProperty "negate" dietSetNegateProp' + , TQC.testProperty "aboveInclusive" dietSetAboveProp' + , testGroup "belowInclusive" + [ TQC.testProperty "basic" dietSetBelowProp' + , TQC.testProperty "lowest" dietSetBelowLowestProp' + , TQC.testProperty "highest" dietSetBelowHighestProp' + ] + , testGroup "betweenInclusive" + [ TQC.testProperty "basic" dietSetBetweenProp' + , TQC.testProperty "border" dietSetBetweenBorderProp' + , TQC.testProperty "inside" dietSetBetweenBorderNearProp' + ] ] ] , testGroup "Map" @@ -283,18 +299,36 @@ ys' = dietSetToSet ys in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys'))) +dietSetDifferenceProp' :: QC.Property +dietSetDifferenceProp' = QC.property $ \(S xs :: S Word8) (S ys :: S Word8) -> + let xs' = dietSetToSet xs + ys' = dietSetToSet ys + in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys'))) + dietSetIntersectionProp :: QC.Property dietSetIntersectionProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set Word8) -> let xs' = dietSetToSet xs ys' = dietSetToSet ys in DSL.intersection xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.intersection xs' ys'))) +dietSetIntersectionProp' :: QC.Property +dietSetIntersectionProp' = QC.property $ \(S xs :: S Word8) (S ys :: S Word8) -> + let xs' = dietSetToSet xs + ys' = dietSetToSet ys + in DSL.intersection xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.intersection xs' ys'))) + dietSetNegateProp :: QC.Property dietSetNegateProp = QC.property $ \(xs :: DSL.Set Word8) -> let xs' = dietSetToSet xs expected = foldMap (\n -> bool (S.singleton n) mempty (S.member n xs')) [minBound..maxBound] in DSL.negate xs === mconcat (map (\x -> DSL.singleton x x) (F.toList expected)) +dietSetNegateProp' :: QC.Property +dietSetNegateProp' = QC.property $ \(S xs :: S Word8) -> + let xs' = dietSetToSet xs + expected = foldMap (\n -> bool (S.singleton n) mempty (S.member n xs')) [minBound..maxBound] + in DSL.negate xs === mconcat (map (\x -> DSL.singleton x x) (F.toList expected)) + dietSetAboveProp :: QC.Property dietSetAboveProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys @@ -302,6 +336,13 @@ r = if isMember then S.insert y c else c in DSL.aboveInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)) +dietSetAboveProp' :: QC.Property +dietSetAboveProp' = QC.property $ \(y :: Word8) (S ys :: S Word8) -> + let ys' = dietSetToSet ys + (_,isMember,c) = S.splitMember y ys' + r = if isMember then S.insert y c else c + in DSL.aboveInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)) + dietSetBelowProp :: QC.Property dietSetBelowProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys @@ -309,35 +350,71 @@ r = if isMember then S.insert y c else c in DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)) +dietSetBelowProp' :: QC.Property +dietSetBelowProp' = QC.property $ \(y :: Word8) (S ys :: S Word8) -> + let ys' = dietSetToSet ys + (c,isMember,_) = S.splitMember y ys' + r = if isMember then S.insert y c else c + in DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)) + dietSetBelowLowestProp :: QC.Property dietSetBelowLowestProp = QC.property $ \(ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys in case S.lookupMin ys' of Nothing -> QC.property QC.Discard - Just y -> + Just y -> let (c,isMember,_) = S.splitMember y ys' r = if isMember then S.insert y c else c in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))) +dietSetBelowLowestProp' :: QC.Property +dietSetBelowLowestProp' = QC.property $ \(S ys :: S Word8) -> + let ys' = dietSetToSet ys + in case S.lookupMin ys' of + Nothing -> QC.property QC.Discard + Just y -> + let (c,isMember,_) = S.splitMember y ys' + r = if isMember then S.insert y c else c + in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))) + dietSetBelowHighestProp :: QC.Property dietSetBelowHighestProp = QC.property $ \(ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys in case S.lookupMax ys' of Nothing -> QC.property QC.Discard - Just y -> + Just y -> let (c,isMember,_) = S.splitMember y ys' r = if isMember then S.insert y c else c in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))) +dietSetBelowHighestProp' :: QC.Property +dietSetBelowHighestProp' = QC.property $ \(S ys :: S Word8) -> + let ys' = dietSetToSet ys + in case S.lookupMax ys' of + Nothing -> QC.property QC.Discard + Just y -> + let (c,isMember,_) = S.splitMember y ys' + r = if isMember then S.insert y c else c + in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))) + dietSetBetweenProp :: QC.Property dietSetBetweenProp = QC.property $ \(x :: Word8) (y :: Word8) (ys :: DSL.Set Word8) -> (x <= y) - ==> + ==> ( let ys' = dietSetToSet ys r = S.filter (\e -> e >= x && e <= y) ys' in DSL.betweenInclusive x y ys === DSL.fromList (map (\z -> (z,z)) (S.toList r)) ) +dietSetBetweenProp' :: QC.Property +dietSetBetweenProp' = QC.property $ \(x :: Word8) (y :: Word8) (S ys :: S Word8) -> + (x <= y) + ==> + ( let ys' = dietSetToSet ys + r = S.filter (\e -> e >= x && e <= y) ys' + in DSL.betweenInclusive x y ys === DSL.fromList (map (\z -> (z,z)) (S.toList r)) + ) + dietSetBetweenBorderProp :: QC.Property dietSetBetweenBorderProp = QC.property $ \(ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys @@ -345,10 +422,21 @@ Nothing -> QC.property QC.Discard Just hi -> case S.lookupMin ys' of Nothing -> QC.property QC.Discard - Just lo -> + Just lo -> let r = S.filter (\e -> e >= lo && e <= hi) ys' in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r)) +dietSetBetweenBorderProp' :: QC.Property +dietSetBetweenBorderProp' = QC.property $ \(S ys :: S Word8) -> + let ys' = dietSetToSet ys + in case S.lookupMax ys' of + Nothing -> QC.property QC.Discard + Just hi -> case S.lookupMin ys' of + Nothing -> QC.property QC.Discard + Just lo -> + let r = S.filter (\e -> e >= lo && e <= hi) ys' + in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r)) + dietSetBetweenBorderNearProp :: QC.Property dietSetBetweenBorderNearProp = QC.property $ \(ys :: DSL.Set Word8) -> let ys' = dietSetToSet ys @@ -361,6 +449,18 @@ ) ) +dietSetBetweenBorderNearProp' :: QC.Property +dietSetBetweenBorderNearProp' = QC.property $ \(S ys :: S Word8) -> + let ys' = dietSetToSet ys + in ( S.size ys' > 1 + ==> + ( let hi = pred (S.findMax ys') + lo = succ (S.findMin ys') + r = S.filter (\e -> e >= lo && e <= hi) ys' + in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r)) + ) + ) + -- This enumerates all of the element contained by all ranges -- in the diet set. dietSetToSet :: (Enum a, Ord a) => DSL.Set a -> S.Set a @@ -410,14 +510,14 @@ appendWithKeyUnboxedLiftedProp :: QC.Property appendWithKeyUnboxedLiftedProp = QC.property $ \(xs :: M.Map Word8 Word8) ys -> let xs' = MUL.fromList (M.toList xs) - ys' = MUL.fromList (M.toList ys) + ys' = MUL.fromList (M.toList ys) func k x y = k + 2 * x + 3 * y in MUL.toList (MUL.appendWithKey func xs' ys') === M.toList (M.unionWithKey func xs ys) appendWithKeyLiftedLiftedProp :: QC.Property appendWithKeyLiftedLiftedProp = QC.property $ \(xs :: M.Map Word8 Word8) ys -> let xs' = MLL.fromList (M.toList xs) - ys' = MLL.fromList (M.toList ys) + ys' = MLL.fromList (M.toList ys) func k x y = k + 2 * x + 3 * y in MLL.toList (MLL.appendWithKey func xs' ys') === M.toList (M.unionWithKey func xs ys) @@ -593,7 +693,7 @@ instance (Ord k, Enum k, Eq v, Bounded k, Arbitrary k, Arbitrary v) => Arbitrary (MIDBTS.Map k v) where arbitrary = liftA2 MIDBTS.fromList QC.arbitrary (QC.vectorOf 10 arbitraryOrderedPairValue) - + instance (Arbitrary k, Ord k, Arbitrary v, Eq v, Semigroup v) => Arbitrary (MSL.Map k v) where arbitrary = do len <- QC.choose (0,4) @@ -618,7 +718,18 @@ return (lo,hi,v) return (DMUL.fromListAppend ys) shrink x = map E.fromList (QC.shrink (E.toList x)) - + +newtype S a = S (DSL.Set a) + deriving (Eq, Show) + +instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (S a) where + arbitrary = do + sz <- QC.choose (200, 400) + k <- QC.arbitrary + xs <- increasingOrderedPairsHelper sz k + pure $ S $ DSL.fromList xs + shrink (S x) = map (S . E.fromList) (QC.shrink (E.toList x)) + instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DSL.Set a) where arbitrary = DSL.fromList <$> QC.vectorOf 7 arbitraryOrderedPair shrink x = map E.fromList (QC.shrink (E.toList x)) @@ -628,7 +739,7 @@ sz <- QC.choose (0,7) k <- QC.arbitrary foldMap (\(lo,hi) -> DUSL.singleton (Just lo) (Just hi)) <$> increasingOrderedPairsHelper sz k - + increasingOrderedPairsHelper :: (Ord k, Enum k, Bounded k) => Int -> k -> Gen [(k,k)] increasingOrderedPairsHelper n k = if n > 0 then case atLeastTwoGreaterThan k of @@ -685,7 +796,7 @@ instance Monoid Int where mempty = 0 mappend = (SG.<>) - + instance SG.Semigroup Integer where (<>) = (+)