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.1 +version: 0.5.0 synopsis: containers backed by arrays description: Containers backed by flat arrays. Updates require rebuilding the @@ -36,7 +36,7 @@ src build-depends: base >=4.9 && <5 - , primitive-sort >= 0.1 && < 0.2 + , primitive-sort >= 0.1.1 && < 0.2 , hashable >= 1.2.5 , deepseq >= 1.4 , primitive-unlifted >= 0.1 && <0.2 @@ -46,16 +46,11 @@ , primitive-checked >= 0.6.4.1 && < 0.8 else build-depends: - contiguous >= 0.4 && < 0.6 + contiguous >= 0.4 && < 0.7 , primitive >= 0.6.4 && < 0.8 exposed-modules: Data.Continuous.Set.Lifted - Data.Diet.Map.Strict.Lifted.Lifted Data.Diet.Map.Strict.Unboxed.Lifted - Data.Diet.Set - Data.Diet.Set.Lifted - Data.Diet.Set.Unboxed - Data.Diet.Unbounded.Set.Lifted Data.Map.Lifted.Lifted Data.Map.Lifted.Unlifted Data.Map.Unboxed.Lifted @@ -67,20 +62,14 @@ Data.Set.Unboxed Data.Set.Unlifted Data.Set.NonEmpty.Unlifted - Data.Map.Interval Data.Map.Subset.Strict.Lifted Data.Map.Subset.Strict.Unlifted Data.Map.Subset.Lazy.Lifted Data.Map.Subset.Lazy.Unlifted - Data.Map.Interval.DBTSLL - Data.Map.Interval.DBTSUL - Data.Map.Interval.DBTSUU other-modules: Data.Concatenation - Data.Diet.Map.Strict.Internal - Data.Diet.Set.Internal Data.Continuous.Set.Internal - Data.Diet.Unbounded.Set.Internal + Data.Diet.Map.Strict.Internal Data.Map.Internal Data.Map.Subset.Strict.Internal Data.Map.Subset.Lazy.Internal @@ -88,7 +77,6 @@ Data.Set.Lifted.Internal Data.Set.Unboxed.Internal Data.Set.Unlifted.Internal - Data.Map.Interval.DBTS.Internal ghc-options: -O2 -Wall default-language: Haskell2010 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 @@ -25,7 +25,7 @@ import Control.Monad.ST (ST,runST) import Data.Word (Word8) -import Data.Primitive.Contiguous (Contiguous,Element,Mutable) +import Data.Primitive.Contiguous (Contiguous,ContiguousU,Element,Mutable) import Data.Primitive (PrimArray,MutablePrimArray) import Data.Bits (unsafeShiftL,unsafeShiftR,(.|.),(.&.)) import qualified Prelude as P @@ -86,18 +86,18 @@ -> Set arr a singleton Nothing Nothing = universe singleton Nothing (Just (incHi,hi)) = runST $ do - keys <- I.replicateMutable 1 hi >>= I.unsafeFreeze - incs <- I.replicateMutable 1 (edgePairToWord8 (inclusivityToEdge incHi) EdgeAbsent) >>= I.unsafeFreeze + keys <- I.replicateMut 1 hi >>= I.unsafeFreeze + incs <- I.replicateMut 1 (edgePairToWord8 (inclusivityToEdge incHi) EdgeAbsent) >>= I.unsafeFreeze return (Set keys incs) singleton (Just (incLo,lo)) Nothing = runST $ do - keys <- I.replicateMutable 1 lo >>= I.unsafeFreeze - incs <- I.replicateMutable 1 (edgePairToWord8 EdgeAbsent (inclusivityToEdge incLo)) >>= I.unsafeFreeze + keys <- I.replicateMut 1 lo >>= I.unsafeFreeze + incs <- I.replicateMut 1 (edgePairToWord8 EdgeAbsent (inclusivityToEdge incLo)) >>= I.unsafeFreeze return (Set keys incs) singleton (Just (incLo,lo)) (Just (incHi,hi)) = case compare lo hi of GT -> empty EQ -> if incLo == Inclusive && incHi == Inclusive then runST $ do - keys <- I.replicateMutable 2 lo >>= I.unsafeFreeze + keys <- I.replicateMut 2 lo >>= I.unsafeFreeze incsMut <- I.new 2 I.write incsMut 0 (inclusivityPairToWord8 Inclusive Inclusive) I.write incsMut 1 (edgePairToWord8 EdgeAbsent EdgeAbsent) @@ -109,7 +109,7 @@ -- the caller must ensure that lo is less than hi unsafeSingleton :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a unsafeSingleton incLo lo incHi hi = runST $ do - keysMut <- I.replicateMutable 2 lo + keysMut <- I.replicateMut 2 lo I.write keysMut 1 hi keys <- I.unsafeFreeze keysMut incsMut <- I.new 2 @@ -120,7 +120,7 @@ except :: (Contiguous arr, Element arr a) => a -> Set arr a except x = Set keys incs where - keys = runST $ I.replicateMutable 2 x >>= I.unsafeFreeze + keys = runST $ I.replicateMut 2 x >>= I.unsafeFreeze incs = runST $ do m <- I.new 1 I.write m 0 (edgePairToWord8 EdgeExclusive EdgeExclusive) @@ -144,7 +144,7 @@ -- less than the lower bound for pos inf unsafeInfinities :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a unsafeInfinities negInfHiInc negInfHi posInfLoInc posInfLo = runST $ do - keysMut <- I.replicateMutable 2 negInfHi + keysMut <- I.replicateMut 2 negInfHi I.write keysMut 1 posInfLo keys <- I.unsafeFreeze keysMut incsMut <- I.new 1 @@ -152,7 +152,7 @@ incs <- I.unsafeFreeze incsMut return (Set keys incs) -append :: forall arr a. (Ord a, Contiguous arr, Element arr a) => Set arr a -> Set arr a -> Set arr a +append :: forall arr a. (Ord a, ContiguousU arr, Element arr a) => Set arr a -> Set arr a -> Set arr a append s1@(Set keys1 incs1) s2@(Set keys2 incs2) | null s1 = s2 | null s2 = s1 diff --git a/src/Data/Diet/Map/Strict/Internal.hs b/src/Data/Diet/Map/Strict/Internal.hs --- a/src/Data/Diet/Map/Strict/Internal.hs +++ b/src/Data/Diet/Map/Strict/Internal.hs @@ -16,7 +16,6 @@ , lookup , concat , equals - , fromSet , showsPrec , liftShowsPrec2 -- list conversion @@ -34,8 +33,7 @@ import Data.Semigroup (Semigroup) import Data.Foldable (foldl') import Text.Show (showListWith) -import Data.Primitive.Contiguous (Contiguous,Element,Mutable) -import Data.Diet.Set.Internal (Set(..)) +import Data.Primitive.Contiguous (ContiguousU,Element,Mutable) import qualified Data.List as L import qualified Data.Semigroup as SG import qualified Prelude as P @@ -47,36 +45,36 @@ -- unpack these two arguments at some point. data Map karr varr k v = Map !(karr k) !(varr v) -empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v +empty :: (ContiguousU karr, ContiguousU varr) => Map karr varr k v empty = Map I.empty I.empty -- Note: this is only correct when the function is a bijection. -map :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w +map :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w map f (Map k v) = Map k (I.map f v) -equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool +equals :: (ContiguousU karr, Element karr k, Eq k, ContiguousU varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2 -fromListN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v +fromListN :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v fromListN = fromListWithN (\_ a -> a) -fromList :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => [(k,k,v)] -> Map karr varr k v +fromList :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => [(k,k,v)] -> Map karr varr k v fromList = fromListN 1 -fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v +fromListAppendN :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Semigroup v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v fromListAppendN = fromListWithN (SG.<>) -fromListAppend :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [(k,k,v)] -> Map karr varr k v +fromListAppend :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Semigroup v, Eq v) => [(k,k,v)] -> Map karr varr k v fromListAppend = fromListAppendN 1 -fromListWithN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Int -> [(k,k,v)] -> Map karr varr k v +fromListWithN :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => (v -> v -> v) -> Int -> [(k,k,v)] -> Map karr varr k v fromListWithN combine _ xs = concatWith combine (P.map (\(lo,hi,v) -> singleton lo hi v) xs) -concat :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [Map karr varr k v] -> Map karr varr k v +concat :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Semigroup v, Eq v) => [Map karr varr k v] -> Map karr varr k v concat = concatWith (SG.<>) -singleton :: forall karr varr k v. (Contiguous karr, Element karr k,Ord k,Contiguous varr, Element varr v) => k -> k -> v -> Map karr varr k v +singleton :: forall karr varr k v. (ContiguousU karr, Element karr k,Ord k,ContiguousU varr, Element varr v) => k -> k -> v -> Map karr varr k v singleton !lo !hi !v = if lo <= hi then Map ( runST $ do @@ -92,7 +90,7 @@ ) else empty -lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v +lookup :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => k -> Map karr varr k v -> Maybe v lookup a (Map keys vals) = go 0 (I.size vals - 1) where go :: Int -> Int -> Maybe v go !start !end = if end <= start @@ -116,18 +114,17 @@ {-# INLINEABLE lookup #-} -append :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v +append :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Semigroup v, Eq v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v append (Map ksA vsA) (Map ksB vsB) = case unionArrWith (SG.<>) ksA vsA ksB vsB of (k,v) -> Map k v -appendWith :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v +appendWith :: (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v appendWith combine (Map ksA vsA) (Map ksB vsB) = case unionArrWith combine ksA vsA ksB vsB of (k,v) -> Map k v - - -unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) + +unionArrWith :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => (v -> v -> v) -> karr k -- keys a -> varr v -- values a @@ -277,8 +274,8 @@ return (ixDst + 1) let ixB' = ixB + 1 remaining = szB - ixB' - I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2) - I.copy valsDst ixDst' valsB ixB' remaining + I.copy keysDst (ixDst' * 2) (I.slice keysB (ixB' * 2) (remaining * 2)) + I.copy valsDst ixDst' (I.slice valsB ixB' remaining) return (ixDst' + remaining) copyA :: Int -> k -> k -> v -> Int -> ST s Int copyA !ixA !loA !hiA !valA !ixDst = do @@ -294,8 +291,8 @@ return (ixDst + 1) let ixA' = ixA + 1 remaining = szA - ixA' - I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2) - I.copy valsDst ixDst' valsA ixA' remaining + I.copy keysDst (ixDst' * 2) (I.slice keysA (ixA' * 2) (remaining * 2)) + I.copy valsDst ixDst' (I.slice valsA ixA' remaining) return (ixDst' + remaining) let !loA0 = indexLoKeyA 0 !loB0 = indexLoKeyB 0 @@ -356,19 +353,19 @@ !valsFinal <- I.resize valsDst total liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal) -concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) +concatWith :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, Enum k, ContiguousU varr, Element varr v, Eq v) => (v -> v -> v) -> [Map karr varr k v] -> Map karr varr k v concatWith combine = C.concatSized size empty (appendWith combine) -size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int +size :: (ContiguousU varr, Element varr v) => Map karr varr k v -> Int size (Map _ vals) = I.size vals -toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,k,v)] +toList :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => Map karr varr k v -> [(k,k,v)] toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) [] -foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> k -> v -> b -> b) -> b -> Map karr varr k v -> b +foldrWithKey :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> k -> v -> b -> b) -> b -> Map karr varr k v -> b foldrWithKey f z (Map keys vals) = let !sz = I.size vals go !i @@ -380,32 +377,11 @@ in f lo hi v (go (i + 1)) in go 0 --- Convert a diet set to a diet map. The function takes the --- low and high keys in a range. This function should probably --- have a test written for it. -fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) - => (k -> k -> v) -> Set karr k -> Map karr varr k v -fromSet f (Set keys) = Map keys values - where - values = runST $ do - let !sz = div (I.size keys) 2 - m <- I.new sz - let go !ix !twiceIx = if ix < sz - then do - let !(# lo #) = I.index# keys twiceIx - !(# hi #) = I.index# keys (twiceIx + 1) - I.write m ix (f lo hi) - go (ix + 1) (twiceIx + 2) - else return () - go 0 0 - I.unsafeFreeze m - - -showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS +showsPrec :: (ContiguousU karr, Element karr k, Show k, ContiguousU varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) -liftShowsPrec2 :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (Int -> k -> ShowS) -> ([k] -> ShowS) -> (Int -> v -> ShowS) -> ([v] -> ShowS) -> Int -> Map karr varr k v -> ShowS +liftShowsPrec2 :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (Int -> k -> ShowS) -> ([k] -> ShowS) -> (Int -> v -> ShowS) -> ([v] -> ShowS) -> Int -> Map karr varr k v -> ShowS liftShowsPrec2 showsPrecK _ showsPrecV _ p xs = showParen (p > 10) $ showString "fromList " . showListWith (\(a,b,c) -> show_tuple [showsPrecK 0 a, showsPrecK 0 b, showsPrecV 0 c]) (toList xs) @@ -415,5 +391,4 @@ . showChar '(' . foldr1 (\s r -> s . showChar ',' . r) ss . showChar ')' - diff --git a/src/Data/Diet/Map/Strict/Lifted/Lifted.hs b/src/Data/Diet/Map/Strict/Lifted/Lifted.hs deleted file mode 100644 --- a/src/Data/Diet/Map/Strict/Lifted/Lifted.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -O2 #-} -module Data.Diet.Map.Strict.Lifted.Lifted - ( Map - , singleton - , lookup - -- * List Conversion - , fromList - , fromListAppend - , fromListN - , fromListAppendN - ) where - -import Prelude hiding (lookup,map) - -import Data.Semigroup (Semigroup) -import Data.Functor.Classes (Show2(..)) -import Data.Primitive (Array) -import qualified GHC.Exts as E -import qualified Data.Semigroup as SG -import qualified Data.Diet.Map.Strict.Internal as I - -newtype Map k v = Map (I.Map Array Array k v) - --- | /O(1)/ Create a diet map with a single element. -singleton :: Ord k - => k -- ^ inclusive lower bound - -> k -- ^ inclusive upper bound - -> v -- ^ value - -> Map k v -singleton lo hi v = Map (I.singleton lo hi v) - --- | /O(log n)/ Lookup the value at a key in the map. -lookup :: Ord k => k -> Map k v -> Maybe v -lookup a (Map s) = I.lookup a s - -instance (Show k, Show v) => Show (Map k v) where - showsPrec p (Map m) = I.showsPrec p m - -instance (Eq k, Eq v) => Eq (Map k v) where - Map x == Map y = I.equals x y - -instance (Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where - Map x <> Map y = Map (I.append x y) - -instance (Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where - mempty = Map I.empty - mappend = (SG.<>) - mconcat = Map . I.concat . E.coerce - -instance (Ord k, Enum k, Eq v) => E.IsList (Map k v) where - type Item (Map k v) = (k,k,v) - fromListN n = Map . I.fromListN n - fromList = Map . I.fromList - toList (Map s) = I.toList s - -fromList :: (Ord k, Enum k, Eq v) => [(k,k,v)] -> Map k v -fromList = Map . I.fromList - -fromListN :: (Ord k, Enum k, Eq v) - => Int -- ^ expected size of resulting 'Map' - -> [(k,k,v)] -- ^ key-value pairs - -> Map k v -fromListN n = Map . I.fromListN n - -fromListAppend :: (Ord k, Enum k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v -fromListAppend = Map . I.fromListAppend - -fromListAppendN :: (Ord k, Enum k, Semigroup v, Eq v) - => Int -- ^ expected size of resulting 'Map' - -> [(k,k,v)] -- ^ key-value pairs - -> Map k v -fromListAppendN n = Map . I.fromListAppendN n diff --git a/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs b/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs --- a/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs +++ b/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs @@ -10,7 +10,6 @@ , singleton , lookup , mapBijection - , fromSet -- * List Conversion , fromList , fromListAppend @@ -20,7 +19,6 @@ import Prelude hiding (lookup,map) -import Data.Diet.Set.Unboxed (Set(..)) import Data.Functor.Classes (Show2(..)) import Data.Primitive.Array (Array) import Data.Primitive.PrimArray (PrimArray) @@ -98,11 +96,3 @@ -> Map k v -> Map k w mapBijection f (Map m) = Map (I.map f m) - --- | Convert a diet set to a diet map, constructing each value --- from the low and high key in its corresponding range. -fromSet :: Prim k - => (k -> k -> v) - -> Set k - -> Map k v -fromSet f (Set s) = Map (I.fromSet f s) diff --git a/src/Data/Diet/Set.hs b/src/Data/Diet/Set.hs deleted file mode 100644 --- a/src/Data/Diet/Set.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-| - -The modules in this hierarchy implement sets of nonoverlapping, -nonadjacent intervals. In the literature, one such implementation of -these is known as - -(DIETs). This implementation is discussed in -, -Martin Erwig. Journal of Functional Programming, Vol. 8, No. 6, 627-632, 1998. -In this package, we use the term diet set to refer to not just that one -implementation but to any set of nonoverlapping, nonadjacent intervals. - -These are not the same as interval sets. An interval set preserves -the original intervals that the user inserted into the set. A diet set -will coalesce adjacent or overlapping ranges. For example: - ->>> ⦃[2,6]⦄ ⋄ ⦃[1,3]⦄ ⋄ ⦃[8,11]⦄ ⋄ ⦃[12,12]⦄ -⦃[1,6],[8,12]⦄ - -The implementation in this packages is optimized for reads. Building -a diet set is expensive since the array-backed implementation cannot -do any sharing when it creates a new data structure. However, testing -for membership is @O(log n)@. - --} - -module Data.Diet.Set () where diff --git a/src/Data/Diet/Set/Internal.hs b/src/Data/Diet/Set/Internal.hs deleted file mode 100644 --- a/src/Data/Diet/Set/Internal.hs +++ /dev/null @@ -1,638 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -module Data.Diet.Set.Internal - ( Set(..) - , empty - , singleton - , append - , member - , concat - , equals - , showsPrec - , difference - , intersection - , negate - , foldr - , size - -- unsafe indexing - , locate - , slice - , indexLower - , indexUpper - -- splitting - , aboveExclusive - , aboveInclusive - , belowInclusive - , belowExclusive - , betweenInclusive - -- list conversion - , fromListN - , fromList - , toList - ) where - -import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate) - -import Control.Monad.ST (ST,runST) -import Data.Bool (bool) -import Data.Primitive.Contiguous (Contiguous,Element,Mutable) -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 diet Set modules. It is needed --- by the diet Map modules to implement conversion functions. -newtype Set arr a = Set (arr a) - -empty :: Contiguous arr => Set arr a -empty = Set I.empty - -equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool -equals (Set x) (Set y) = I.equals x y - -fromListN :: (Contiguous arr, Element arr a, Ord a, Enum a) => Int -> [(a,a)] -> Set arr a -fromListN _ xs = concat (P.map (uncurry singleton) xs) - -fromList :: (Contiguous arr, Element arr a, Ord a, Enum a) => [(a,a)] -> Set arr a -fromList = fromListN 1 - -concat :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => [Set arr a] - -> Set arr a -concat = C.concatSized size empty append - -singleton :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a -- ^ lower inclusive bound - -> a -- ^ upper inclusive bound - -> Set arr a -singleton !lo !hi = if lo <= hi - then uncheckedSingleton lo hi - else empty - --- precondition: lo must be less than or equal to hi -uncheckedSingleton :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a -- ^ lower inclusive bound - -> a -- ^ upper inclusive bound - -> Set arr a -uncheckedSingleton lo hi = runST $ do - !(arr :: Mutable arr s a) <- I.new 2 - I.write arr 0 lo - I.write arr 1 hi - r <- I.unsafeFreeze arr - return (Set r) - -member :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a - -> Set arr a - -> Bool -member a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where - go :: Int -> Int -> Bool - go !start !end = if end <= start - then if end == start - then - let !(# valLo #) = I.index# arr (2 * start) - !(# valHi #) = I.index# arr (2 * start + 1) - in a >= valLo && a <= valHi - else False - else - let !mid = div (end + start + 1) 2 - !valLo = I.index arr (2 * mid) - in case P.compare a valLo of - LT -> go start (mid - 1) - EQ -> True - GT -> go mid end -{-# INLINEABLE member #-} - --- This may segfault if given something out of bounds -indexLower :: (Contiguous arr, Element arr a) - => Int - -> Set arr a - -> a -indexLower ix (Set arr) = I.index arr (ix * 2) - --- This may segfault if given something out of bounds -indexUpper :: (Contiguous arr, Element arr a) - => Int - -> Set arr a - -> a -indexUpper ix (Set arr) = I.index arr (ix * 2 + 1) - --- This may segfault if given bad indices. You are allow to give --- a high index that is one less than the low index though. -slice :: (Contiguous arr, Element arr a) - => Int -- inclusive low index - -> Int -- inclusive high index - -> Set arr a - -> Set arr a -slice loIx hiIx (Set arr) = Set (I.clone arr (loIx * 2) ((hiIx - loIx + 1) * 2)) - --- This is exported for use in Unbounded Diet Sets, but it should --- be considered an internal function since it provided an index --- into the set. --- Right means that the needle was found. The index provided is the --- index of the range that contains it [0,n). Left means that the needle --- was not contained by any of the ranges. The index provided is --- the index of the range to its right [0,n] -locate :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a - -> Set arr a - -> Either Int Int -locate a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where - go :: Int -> Int -> Either Int Int - go !start !end = if end <= start - then if end == start - then - let !valLo = I.index arr (2 * start) - !valHi = I.index arr (2 * start + 1) - in if (a >= valLo) - then if a <= valHi - then Right start - else Left (start + 1) - else Left start - else Left 0 - else - let !mid = div (end + start + 1) 2 - !valLo = I.index arr (2 * mid) - in case P.compare a valLo of - LT -> go start (mid - 1) - EQ -> Right mid - GT -> go mid end - -betweenInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a -- ^ inclusive lower bound - -> a -- ^ inclusive upper bound - -> Set arr a - -> Set arr a -betweenInclusive lo hi (Set arr) - | hi < lo = empty - | I.size arr > 0 && I.index arr 0 >= lo && I.index arr (I.size arr - 1) <= hi = Set arr - | otherwise = case locate lo (Set arr) of - Left ixLo -> case locate hi (Set arr) of - Left ixHi -> Set (I.clone arr (ixLo * 2) ((ixHi - ixLo) * 2)) - Right ixHi -> runST $ do - let len = ixHi - ixLo + 1 - res <- I.new (len * 2) - rightLo <- I.indexM arr (ixHi * 2) - I.copy res 0 arr (ixLo * 2) (len * 2 - 2) - I.write res (len * 2 - 2) rightLo - I.write res (len * 2 - 1) hi - r <- I.unsafeFreeze res - return (Set r) - Right ixLo -> case locate hi (Set arr) of - Left ixHi -> runST $ do - let len = ixHi - ixLo - (res :: Mutable arr s a) <- I.new (len * 2) - leftHi <- I.indexM arr (ixLo * 2 + 1) - I.write res 0 lo - I.write res 1 leftHi - I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 2) - r <- I.unsafeFreeze res - return (Set r) - Right ixHi -> if ixLo == ixHi - then uncheckedSingleton lo hi - else runST $ do - let len = ixHi - ixLo + 1 - (res :: Mutable arr s a) <- I.new (len * 2) - leftHi <- I.indexM arr (ixLo * 2 + 1) - I.write res 0 lo - I.write res 1 leftHi - I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 4) - rightLo <- I.indexM arr (ixHi * 2) - I.write res (len * 2 - 2) rightLo - I.write res (len * 2 - 1) hi - r <- I.unsafeFreeze res - return (Set r) - - -aboveInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a -- ^ inclusive lower bound - -> Set arr a - -> Set arr a -aboveInclusive x (Set arr) = case locate x (Set arr) of - Left ix -> if ix == 0 - then Set arr - else Set (I.clone arr (ix * 2) (I.size arr - ix * 2)) - Right ix -> - let lo = I.index arr (ix * 2) - hi = I.index arr (ix * 2 + 1) - in if lo == x - then if ix == 0 - then Set arr - else Set (I.clone arr (ix * 2) (I.size arr - ix * 2)) - else runST $ do - (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2) - I.write result 0 x - I.write result 1 hi - I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2) - r <- I.unsafeFreeze result - return (Set r) - -aboveExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- ^ exclusive lower bound - -> Set arr a - -> Set arr a -aboveExclusive x (Set arr) = case locate x (Set arr) of - Left ix -> if ix == 0 - then Set arr - else Set (I.clone arr (ix * 2) (I.size arr - ix * 2)) - Right ix -> - let hi = I.index arr (ix * 2 + 1) - in if hi == x - then Set (I.clone arr ((ix + 1) * 2) (I.size arr - (ix + 1) * 2)) - else runST $ do - (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2) - I.write result 0 (succ x) - I.write result 1 hi - I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2) - r <- I.unsafeFreeze result - return (Set r) - - -belowInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a -- ^ inclusive upper bound - -> Set arr a - -> Set arr a -belowInclusive x (Set arr) = case locate x (Set arr) of - Left ix -> if ix * 2 == I.size arr - then Set arr - else Set (I.clone arr 0 (ix * 2)) - Right ix -> - let lo = I.index arr (ix * 2) - hi = I.index arr (ix * 2 + 1) - in if hi == x - then if ix * 2 == I.size arr - 2 - then Set arr - else Set (I.clone arr 0 ((ix + 1) * 2)) - else runST $ do - result <- I.new ((ix + 1) * 2) - I.copy result 0 arr 0 (ix * 2) - I.write result (ix * 2) lo - I.write result (ix * 2 + 1) x - r <- I.unsafeFreeze result - return (Set r) - -belowExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- ^ exclusive upper bound - -> Set arr a - -> Set arr a -belowExclusive x (Set arr) = case locate x (Set arr) of - Left ix -> if ix * 2 == I.size arr - then Set arr - else Set (I.clone arr 0 (ix * 2)) - Right ix -> - let lo = I.index arr (ix * 2) - in if lo == x - then Set (I.clone arr 0 (ix * 2)) - else runST $ do - result <- I.new ((ix + 1) * 2) - I.copy result 0 arr 0 (ix * 2) - I.write result (ix * 2) lo - I.write result (ix * 2 + 1) (pred x) - r <- I.unsafeFreeze result - return (Set r) - -append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => Set arr a - -> Set arr a - -> Set arr a -append (Set keysA) (Set keysB) - | szA < 1 = Set keysB - | szB < 1 = Set keysA - | otherwise = runST action - where - !szA = div (I.size keysA) 2 - !szB = div (I.size keysB) 2 - action :: forall s. ST s (Set arr a) - action = do - !(keysDst :: Mutable arr s a) <- I.new (max szA szB * 8) - let writeKeyRange :: Int -> a -> a -> ST s () - writeKeyRange !ix !lo !hi = do - I.write keysDst (2 * ix) lo - I.write keysDst (2 * ix + 1) hi - writeDstHiKey :: Int -> a -> ST s () - writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi - readDstHiKey :: Int -> ST s a - readDstHiKey !ix = I.read keysDst (2 * ix + 1) - indexLoKeyA :: Int -> a - indexLoKeyA !ix = I.index keysA (ix * 2) - indexLoKeyB :: Int -> a - indexLoKeyB !ix = I.index keysB (ix * 2) - indexHiKeyA :: Int -> a - indexHiKeyA !ix = I.index keysA (ix * 2 + 1) - indexHiKeyB :: Int -> a - indexHiKeyB !ix = I.index keysB (ix * 2 + 1) - -- In the go functon, ixDst is always at least one. Similarly, - -- all key arguments are always greater than minBound. - let go :: Int -> a -> a -> Int -> a -> a -> Int -> ST s Int - go !ixA !loA !hiA !ixB !loB !hiB !ixDst = do - prevHi <- readDstHiKey (ixDst - 1) - case compare loA loB of - LT -> do - let (upper,ixA') = if hiA < loB - then (hiA,ixA + 1) - else (pred loB,ixA) - ixDst' <- if pred loA == prevHi - then do - writeDstHiKey (ixDst - 1) upper - return ixDst - else do - writeKeyRange ixDst loA upper - return (ixDst + 1) - if ixA' < szA - then do - let (loA',hiA') = if hiA < loB - then (indexLoKeyA ixA',indexHiKeyA ixA') - else (loB,hiA) - go ixA' loA' hiA' ixB loB hiB ixDst' - else copyB ixB loB hiB ixDst' - GT -> do - let (upper,ixB') = if hiB < loA - then (hiB,ixB + 1) - else (pred loA,ixB) - ixDst' <- if pred loB == prevHi - then do - writeDstHiKey (ixDst - 1) upper - return ixDst - else do - writeKeyRange ixDst loB upper - return (ixDst + 1) - if ixB' < szB - then do - let (loB',hiB') = if hiB < loA - then (indexLoKeyB ixB',indexHiKeyB ixB') - else (loA,hiB) - go ixA loA hiA ixB' loB' hiB' ixDst' - else copyA ixA loA hiA ixDst' - EQ -> do - case compare hiA hiB of - LT -> do - ixDst' <- if pred loA == prevHi - then do - writeDstHiKey (ixDst - 1) hiA - return ixDst - else do - writeKeyRange ixDst loA hiA - return (ixDst + 1) - let ixA' = ixA + 1 - loB' = succ hiA - if ixA' < szA - then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB loB' hiB ixDst' - else copyB ixB loB' hiB ixDst' - GT -> do - ixDst' <- if pred loB == prevHi - then do - writeDstHiKey (ixDst - 1) hiB - return ixDst - else do - writeKeyRange ixDst loB hiB - return (ixDst + 1) - let ixB' = ixB + 1 - loA' = succ hiB - if ixB' < szB - then go ixA loA' hiA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst' - else copyA ixA loA' hiA ixDst' - EQ -> do - ixDst' <- if pred loB == prevHi - then do - writeDstHiKey (ixDst - 1) hiB - return ixDst - else do - writeKeyRange ixDst loB hiB - return (ixDst + 1) - let ixA' = ixA + 1 - ixB' = ixB + 1 - if ixA' < szA - then if ixB' < szB - then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst' - else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixDst' - else if ixB' < szB - then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst' - else return ixDst' - copyB :: Int -> a -> a -> Int -> ST s Int - copyB !ixB !loB !hiB !ixDst = do - prevHi <- readDstHiKey (ixDst - 1) - ixDst' <- if pred loB == prevHi - then do - writeDstHiKey (ixDst - 1) hiB - return ixDst - else do - writeKeyRange ixDst loB hiB - return (ixDst + 1) - let ixB' = ixB + 1 - remaining = szB - ixB' - I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2) - return (ixDst' + remaining) - copyA :: Int -> a -> a -> Int -> ST s Int - copyA !ixA !loA !hiA !ixDst = do - prevHi <- readDstHiKey (ixDst - 1) - ixDst' <- if pred loA == prevHi - then do - writeDstHiKey (ixDst - 1) hiA - return ixDst - else do - writeKeyRange ixDst loA hiA - return (ixDst + 1) - let ixA' = ixA + 1 - remaining = szA - ixA' - I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2) - return (ixDst' + remaining) - let !loA0 = indexLoKeyA 0 - !loB0 = indexLoKeyB 0 - !hiA0 = indexHiKeyA 0 - !hiB0 = indexHiKeyB 0 - total <- case compare loA0 loB0 of - LT -> if hiA0 < loB0 - then do - writeKeyRange 0 loA0 hiA0 - if 1 < szA - then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 loB0 hiB0 1 - else copyB 0 loB0 hiB0 1 - else do - -- here we know that hiA > loA - let !upperA = pred loB0 - writeKeyRange 0 loA0 upperA - go 0 loB0 hiA0 0 loB0 hiB0 1 - EQ -> case compare hiA0 hiB0 of - LT -> do - writeKeyRange 0 loA0 hiA0 - if 1 < szA - then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 (succ hiA0) hiB0 1 - else copyB 0 (succ hiA0) hiB0 1 - GT -> do - writeKeyRange 0 loB0 hiB0 - if 1 < szB - then go 0 (succ hiB0) hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1 - else copyA 0 (succ hiB0) hiA0 1 - EQ -> do - writeKeyRange 0 loA0 hiA0 - if 1 < szA - then if 1 < szB - then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) 1 - else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) 1 - else if 1 < szB - then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) 1 - else return 1 - GT -> if hiB0 < loA0 - then do - writeKeyRange 0 loB0 hiB0 - if 1 < szB - then go 0 loA0 hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1 - else copyA 0 loA0 hiA0 1 - else do - let !upperB = pred loA0 - writeKeyRange 0 loB0 upperB - go 0 loA0 hiA0 0 loA0 hiB0 1 - !keysFinal <- I.resize keysDst (total * 2) - fmap Set (I.unsafeFreeze keysFinal) - --- The element type must have a Bounded instance for --- this to work. -negate :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a, Bounded a) - => Set arr a - -> Set arr a -negate set@(Set arr) - | sz == 0 = uncheckedSingleton minBound maxBound - | otherwise = runST action - where - action :: forall s. ST s (Set arr a) - action = do - let !(# lowest #) = I.index# arr 0 - !(# highest #) = I.index# arr (sz * 2 - 1) - anyBeneath = lowest /= minBound - anyAbove = highest /= maxBound - newSz = - (bool 0 1 anyBeneath) + - (bool 0 1 anyAbove) + - (sz - 1) - (marr :: Mutable arr s a) <- I.new (newSz * 2) - startDstIx <- if anyBeneath - then do - I.write marr 0 minBound - I.write marr 1 (pred lowest) - return 1 - else return 0 - let go !ix !dstIx = if ix < sz - 1 - then do - hi <- I.indexM arr (2 * ix + 1) - I.write marr (dstIx * 2) (succ hi) - lo <- I.indexM arr (2 * ix + 2) - I.write marr (dstIx * 2 + 1) (pred lo) - go (ix + 1) (dstIx + 1) - else return () - go 0 startDstIx - if anyAbove - then do - I.write marr (newSz * 2 - 2) (succ highest) - I.write marr (newSz * 2 - 1) maxBound - else return () - frozen <- I.unsafeFreeze (marr :: Mutable arr s a) - return (Set frozen) - sz = size set - - --- This is a disappointing implementation, but it's the best I can --- come up with given that I'm not willing to spend very much time --- on it. Basically, it builds a list of diet sets where each set is --- a slice of setA that only contains the elements from a contiguous range --- of the negation of setB. This is simple to implement and it's easy --- to see that it is correct. However, it is inefficient. There is a --- better solution that writes to a output buffer directly without --- building any intermediate artifacts. Additionally, the better solution --- should not need an Enum constraint. If anyone can figure out the better --- way to do this, I would gladly take a PR for it. -difference :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a) - => Set arr a - -> Set arr a - -> Set arr a -difference setA@(Set arrA) setB@(Set arrB) - | szA == 0 = empty - | szB == 0 = setA - | otherwise = - let inners :: Int -> [Set arr a] - inners !ix = if ix < szB - 1 - then - let inner = betweenInclusive - (succ (I.index arrB (2 * ix + 1))) - (pred (I.index arrB (2 * ix + 2))) - (Set arrA) - in inner : inners (ix + 1) - else [] - lowestA = I.index arrA 0 - highestA = I.index arrA (szA * 2 - 1) - lowestB = I.index arrB 0 - highestB = I.index arrB (szB * 2 - 1) - lowFragment = if lowestA < lowestB - then [belowExclusive lowestB (Set arrA)] - else [] - highFragment = if highestA > highestB - then [aboveExclusive highestB (Set arrA)] - else [] - -- we should use a more efficient concat since - -- we know everything is ordered. - in concat (lowFragment ++ inners 0 ++ highFragment) - where - !szA = size setA - !szB = size setB - --- This implementation suffers from the same problems as the implementation --- for difference. Notice that it's a bit simpler since we do not have to --- negate the diet set. This means we do not have to do the weirdness with --- treating the first and last elements specially and the weirdness with --- straddling ranges as we walk the second diet set. -intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a) - => Set arr a - -> Set arr a - -> Set arr a -intersection setA@(Set arrA) setB@(Set arrB) - | szA == 0 = empty - | szB == 0 = empty - | otherwise = - let inners :: Int -> [Set arr a] - inners !ix = if ix < szB - then - let inner = betweenInclusive - (I.index arrB (2 * ix)) - (I.index arrB (2 * ix + 1)) - (Set arrA) - in inner : inners (ix + 1) - else [] - -- we should use a more efficient concat since - -- we know everything is ordered. - in concat (inners 0) - where - !szA = size setA - !szB = size setB - -size :: (Contiguous arr, Element arr a) => Set arr a -> Int -size (Set arr) = quot (I.size arr) 2 - -toList :: (Contiguous arr, Element arr a) => Set arr a -> [(a,a)] -toList = foldr (\lo hi xs -> (lo,hi) : xs) [] - -foldr :: (Contiguous arr, Element arr a) => (a -> a -> b -> b) -> b -> Set arr a -> b -foldr f z (Set arr) = - let !sz = div (I.size arr) 2 - go !i - | i == sz = z - | otherwise = - let !lo = I.index arr (i * 2) - !hi = I.index arr (i * 2 + 1) - in f lo hi (go (i + 1)) - in go 0 -{-# INLINABLE foldr #-} - -showsPrec :: (Contiguous arr, Element arr a, Show a) - => Int - -> Set arr a - -> ShowS -showsPrec p xs = showParen (p > 10) $ - showString "fromList " . shows (toList xs) - diff --git a/src/Data/Diet/Set/Lifted.hs b/src/Data/Diet/Set/Lifted.hs deleted file mode 100644 --- a/src/Data/Diet/Set/Lifted.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -O2 #-} -module Data.Diet.Set.Lifted - ( Set(..) - , singleton - , member - , difference - , intersection - , negate - -- * Split - , aboveInclusive - , belowInclusive - , betweenInclusive - -- * Folds - , foldr - -- * List Conversion - , fromList - , fromListN - ) where - -import Prelude hiding (lookup,map,foldr,negate) - -import Data.Semigroup (Semigroup) -import Data.Primitive (Array) -import qualified GHC.Exts as E -import qualified Data.Semigroup as SG -import qualified Data.Diet.Set.Internal as I - --- | A diet set. Currently, the data constructor for this type is --- exported. Please do not use it. It will be moved to an internal --- module at some point. -newtype Set a = Set (I.Set Array a) - --- | /O(1)/ Create a diet set with a single element. -singleton :: Ord a - => a -- ^ inclusive lower bound - -> a -- ^ inclusive upper bound - -> Set a -singleton lo hi = Set (I.singleton lo hi) - --- | /O(log n)/ Returns @True@ if the element is a member of the diet set. -member :: Ord a => a -> Set a -> Bool -member a (Set s) = I.member a s - -instance Show a => Show (Set a) where - showsPrec p (Set s) = I.showsPrec p s - -instance Eq a => Eq (Set a) where - Set x == Set y = I.equals x y - -instance Ord a => Ord (Set a) where - compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys) - -instance (Ord a, Enum a) => Semigroup (Set a) where - Set x <> Set y = Set (I.append x y) - -instance (Ord a, Enum a) => Monoid (Set a) where - mempty = Set I.empty - mappend = (SG.<>) - mconcat = Set . I.concat . E.coerce - -instance (Ord a, Enum a) => E.IsList (Set a) where - type Item (Set a) = (a,a) - fromListN n = Set . I.fromListN n - fromList = Set . I.fromList - toList (Set s) = I.toList s - -fromList :: (Ord a, Enum a) => [(a,a)] -> Set a -fromList = Set . I.fromList - -fromListN :: (Ord a, Enum a) - => Int -- ^ expected size of resulting diet 'Set' - -> [(a,a)] -- ^ key-value pairs - -> Set a -fromListN n = Set . I.fromListN n - --- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the --- minuend of size @n@. It should be possible to improve the improve --- the performance of this to /O(n + m)/. Anyone interested in doing --- this should open a PR. -difference :: (Ord a, Enum a) - => Set a -- ^ minuend - -> Set a -- ^ subtrahend - -> Set a -difference (Set x) (Set y) = Set (I.difference x y) - --- | The intersection of two diet sets. -intersection :: (Ord a, Enum a) - => Set a -- ^ minuend - -> Set a -- ^ subtrahend - -> Set a -intersection (Set x) (Set y) = Set (I.intersection x y) - --- | The negation of a diet set. The resulting set contains --- all elements that were not contained by the argument set, --- and it only contains these elements. -negate :: (Ord a, Enum a, Bounded a) - => Set a - -> Set a -negate (Set x) = Set (I.negate x) - -foldr :: (a -> a -> b -> b) -> b -> Set a -> b -foldr f z (Set arr) = I.foldr f z arr - --- | /O(n)/ The subset where all elements are greater than --- or equal to the given value. -aboveInclusive :: (Ord a) - => a -- ^ inclusive lower bound - -> Set a - -> Set a -aboveInclusive x (Set s) = Set (I.aboveInclusive x s) - --- | /O(n)/ The subset where all elements are less than --- or equal to the given value. -belowInclusive :: (Ord a) - => a -- ^ inclusive upper bound - -> Set a - -> Set a -belowInclusive x (Set s) = Set (I.belowInclusive x s) - --- | /O(n)/ The subset where all elements are greater than --- or equal to the lower bound and less than or equal to --- the upper bound. -betweenInclusive :: (Ord a) - => a -- ^ inclusive lower bound - -> a -- ^ inclusive upper bound - -> Set a - -> Set a -betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s) - diff --git a/src/Data/Diet/Set/Unboxed.hs b/src/Data/Diet/Set/Unboxed.hs deleted file mode 100644 --- a/src/Data/Diet/Set/Unboxed.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -O2 #-} -module Data.Diet.Set.Unboxed - ( Set(..) - , singleton - , member - , difference - , intersection - , negate - -- * Split - , aboveInclusive - , belowInclusive - , betweenInclusive - -- * Folds - , foldr - -- * List Conversion - , toList - , fromList - , fromListN - ) where - -import Prelude hiding (lookup,map,foldr,negate) - -import Data.Semigroup (Semigroup) -import Data.Functor.Classes (Show2(..)) -import Data.Primitive.Types (Prim) -import Data.Primitive.PrimArray (PrimArray) -import qualified GHC.Exts as E -import qualified Data.Semigroup as SG -import qualified Data.Diet.Set.Internal as I - --- | A diet set. Currently, the data constructor for this type is --- exported. Please do not use it. -newtype Set a = Set (I.Set PrimArray a) - --- | /O(1)/ Create a diet set with a single element. -singleton :: (Ord a, Prim a) - => a -- ^ inclusive lower bound - -> a -- ^ inclusive upper bound - -> Set a -singleton lo hi = Set (I.singleton lo hi) - --- | /O(log n)/ Lookup the value at a key in the map. -member :: (Ord a, Prim a) => a -> Set a -> Bool -member a (Set s) = I.member a s - -instance (Show a, Prim a) => Show (Set a) where - showsPrec p (Set s) = I.showsPrec p s - -instance (Eq a, Prim a) => Eq (Set a) where - Set x == Set y = I.equals x y - -instance (Ord a, Prim a) => Ord (Set a) where - compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys) - -instance (Ord a, Enum a, Prim a) => Semigroup (Set a) where - Set x <> Set y = Set (I.append x y) - -instance (Ord a, Enum a, Prim a) => Monoid (Set a) where - mempty = Set I.empty - mappend = (SG.<>) - mconcat = Set . I.concat . E.coerce - -instance (Ord a, Enum a, Prim a) => E.IsList (Set a) where - type Item (Set a) = (a,a) - fromListN n = Set . I.fromListN n - fromList = Set . I.fromList - toList (Set s) = I.toList s - -toList :: Prim a => Set a -> [(a,a)] -toList (Set x) = I.toList x - -fromList :: (Ord a, Enum a, Prim a) => [(a,a)] -> Set a -fromList = Set . I.fromList - -fromListN :: (Ord a, Enum a, Prim a) - => Int -- ^ expected size of resulting diet 'Set' - -> [(a,a)] -- ^ key-value pairs - -> Set a -fromListN n = Set . I.fromListN n - --- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the --- minuend of size @n@. It should be possible to improve the improve --- the performance of this to /O(n + m)/. Anyone interested in doing --- this should open a PR. -difference :: (Ord a, Enum a, Prim a) - => Set a -- ^ minuend - -> Set a -- ^ subtrahend - -> Set a -difference (Set x) (Set y) = Set (I.difference x y) - --- | The intersection of two diet sets. -intersection :: (Ord a, Enum a, Prim a) - => Set a -- ^ minuend - -> Set a -- ^ subtrahend - -> Set a -intersection (Set x) (Set y) = Set (I.intersection x y) - --- | The negation of a diet set. The resulting set contains --- all elements that were not contained by the argument set, --- and it only contains these elements. -negate :: (Ord a, Enum a, Prim a, Bounded a) - => Set a - -> Set a -negate (Set x) = Set (I.negate x) - -foldr :: Prim a => (a -> a -> b -> b) -> b -> Set a -> b -foldr f z (Set arr) = I.foldr f z arr - --- | /O(n)/ The subset where all elements are greater than --- or equal to the given value. -aboveInclusive :: (Ord a, Prim a) - => a -- ^ inclusive lower bound - -> Set a - -> Set a -aboveInclusive x (Set s) = Set (I.aboveInclusive x s) - --- | /O(n)/ The subset where all elements are less than --- or equal to the given value. -belowInclusive :: (Ord a, Prim a) - => a -- ^ inclusive upper bound - -> Set a - -> Set a -belowInclusive x (Set s) = Set (I.belowInclusive x s) - --- | /O(n)/ The subset where all elements are greater than --- or equal to the lower bound and less than or equal to --- the upper bound. -betweenInclusive :: (Ord a, Prim a) - => a -- ^ inclusive lower bound - -> a -- ^ inclusive upper bound - -> Set a - -> Set a -betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s) - diff --git a/src/Data/Diet/Unbounded/Set/Internal.hs b/src/Data/Diet/Unbounded/Set/Internal.hs deleted file mode 100644 --- a/src/Data/Diet/Unbounded/Set/Internal.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wall #-} - -module Data.Diet.Unbounded.Set.Internal - ( Set - , empty - , singleton - , append - , member - , equals - , showsPrec - ) where - -import Prelude hiding (showsPrec) - -import Data.Primitive.Contiguous (Contiguous,Element,Mutable) - -import qualified Data.Diet.Set.Internal as S -import qualified Data.Primitive.Contiguous as I - --- todo: switch to using an unboxed sum instead of --- Maybe once GHC 8.4.3 becomes prevalent. --- --- If the first Maybe is Just, then everything from negative --- infinity (whatever that may mean for the type at hand) up --- to the value is included in the set. It works similarly --- for the second Maybe and positive infinity. Internally, --- we must uphold the invariant that the range up from negative --- infinity and the one up to positive infinity do not overlap --- with the diet set in the middle and that they are not --- adjacent to it (according to the Enum instance). --- --- The second data constructor, SetAll, means that all values --- of type @a@ are included in the Set. We do actually need --- a separate data constructor for this since there is no --- way to communicate it with the first one. -data Set arr a - = SetSome !(Maybe a) !(S.Set arr a) !(Maybe a) - | SetAll - -empty :: Contiguous arr => Set arr a -empty = SetSome Nothing S.empty Nothing - -equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool -equals SetAll SetAll = True -equals SetAll (SetSome _ _ _) = False -equals (SetSome _ _ _) SetAll = False -equals (SetSome a b c) (SetSome x y z) = a == x && c == z && S.equals b y - -singleton :: (Contiguous arr, Element arr a, Ord a) - => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@ - -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@ - -> Set arr a -singleton Nothing Nothing = SetAll -singleton Nothing (Just hi) = SetSome (Just hi) S.empty Nothing -singleton (Just lo) Nothing = SetSome Nothing S.empty (Just lo) -singleton (Just lo) (Just hi) = SetSome Nothing (S.singleton lo hi) Nothing - -append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => Set arr a - -> Set arr a - -> Set arr a -append SetAll _ = SetAll -append (SetSome _ _ _) SetAll = SetAll -append (SetSome Nothing a Nothing) (SetSome Nothing b Nothing) = - SetSome Nothing (S.append a b) Nothing -append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b Nothing) = - let (infHi, trimmedB) = establishInfinityHi infHiA b - in SetSome (Just infHi) (S.append a trimmedB) Nothing -append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b Nothing) = - let (infHi, trimmedA) = establishInfinityHi infHiB a - in SetSome (Just infHi) (S.append trimmedA b) Nothing -append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b Nothing) = - case compare infHiA infHiB of - EQ -> SetSome (Just infHiA) (S.append a b) Nothing - LT -> - let (infHi, trimmedA) = establishInfinityHi infHiB a - in SetSome (Just infHi) (S.append trimmedA b) Nothing - GT -> - let (infHi, trimmedB) = establishInfinityHi infHiA b - in SetSome (Just infHi) (S.append a trimmedB) Nothing -append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b Nothing) = - let (infLo, trimmedB) = establishInfinityLo infLoA b - in SetSome Nothing (S.append a trimmedB) (Just infLo) -append (SetSome Nothing a Nothing) (SetSome Nothing b (Just infLoB)) = - let (infLo, trimmedA) = establishInfinityLo infLoB a - in SetSome Nothing (S.append trimmedA b) (Just infLo) -append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b (Just infLoB)) = - case compare infLoA infLoB of - EQ -> SetSome Nothing (S.append a b) (Just infLoB) - LT -> - let (infLo, trimmedB) = establishInfinityLo infLoA b - in SetSome Nothing (S.append a trimmedB) (Just infLo) - GT -> - let (infLo, trimmedA) = establishInfinityLo infLoB a - in SetSome Nothing (S.append trimmedA b) (Just infLo) -append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b Nothing) = - case establishInfinityBoth infHiA infLoA b of - Nothing -> SetAll - Just (infHi,infLo,trimmedB) -> SetSome (Just infHi) (S.append a trimmedB) (Just infLo) -append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b (Just infLoB)) = - case establishInfinityBoth infHiB infLoB a of - Nothing -> SetAll - Just (infHi,infLo,trimmedA) -> SetSome (Just infHi) (S.append trimmedA b) (Just infLo) -append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) = - generalAppend (max infHiA infHiB) (min infLoA infLoB) a b -append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) = - generalAppend infHiB (min infLoA infLoB) a b -append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b (Just infLoB)) = - generalAppend infHiA (min infLoA infLoB) a b -append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b (Just infLoB)) = - generalAppend (max infHiA infHiB) infLoB a b -append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b Nothing) = - generalAppend (max infHiA infHiB) infLoA a b -append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b Nothing) = - generalAppend infHiB infLoA a b -append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b (Just infLoB)) = - generalAppend infHiA infLoB a b - -generalAppend :: (Contiguous arr, Ord a, Enum a, Element arr a) - => a -> a -> S.Set arr a -> S.Set arr a -> Set arr a -generalAppend infHiX infLoX a b = - case establishInfinityBoth infHiX infLoX (S.append a b) of - Nothing -> SetAll - Just (infHi,infLo,trimmed) -> SetSome (Just infHi) trimmed (Just infLo) - --- This takes an value @a@ which is the upper bound of (-∞,a] range. --- It also takes a diet set. It removes everything from the set --- that is contained by the up-from-negative-infinity range, and --- it also removes a range adjacent to @a@. If a range adjacent to --- @a@ was removed, then the returned value will be the upper bound --- of the removed adjacent range. -establishInfinityHi :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- upper bound from negative infinity - -> S.Set arr a -- diet set - -> (a, S.Set arr a) -- new upper bound, trimmed diet set -establishInfinityHi a s = case locateAdjacentAbove a s of - Right ix -> - let upper = S.indexUpper ix s - in (upper,S.slice (ix + 1) (S.size s - 1) s) - Left ix -> (a,S.slice ix (S.size s - 1) s) - -establishInfinityLo :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- lower bound from positive infinity - -> S.Set arr a -- diet set - -> (a, S.Set arr a) -- new lower bound, trimmed diet set -establishInfinityLo a s = case locateAdjacentBelow a s of - Right ix -> - let lower = S.indexLower ix s - in (lower,S.slice 0 (ix - 1) s) - Left ix -> (a, S.slice 0 ix s) - --- this is a tweaked version of locate. If the element --- isn't found in the diet set, it looks at its predecessor --- to see if it is present so that we can collapse a maximal --- number of ranges. Left gives the index of the range to --- the left of (meaning: less than) the element. --- --- Right: [0,n-1] --- Left: [-1,n-1] -locateAdjacentBelow :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- lower bound from positive infinity - -> S.Set arr a -- diet set - -> Either Int Int -locateAdjacentBelow a s = case S.locate a s of - Right ix -> Right ix - Left ix -> if ix == 0 - then Left (-1) - else if S.indexUpper (ix - 1) s == pred a - then Right (ix - 1) - else Left (ix - 1) - --- this is a tweaked version of locate. If the element --- isn't found in the diet set, it looks at its successor --- to see if it is present so that we can collapse a maximal --- number of ranges. Left gives the index of the range to --- the right of (meaning: greater than) the element. --- --- Right: [0,n-1] --- Left: [0,n] -locateAdjacentAbove :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- upper bound from negative infinity - -> S.Set arr a -- diet set - -> Either Int Int -locateAdjacentAbove a s = case S.locate a s of - Right ix -> Right ix - Left ix -> if ix == S.size s - then Left ix - else if S.indexLower ix s == succ a - then Right ix - else Left ix - -establishInfinityBoth :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a) - => a -- upper bound from negative infinity - -> a -- lower bound from positive infinity - -> S.Set arr a -- diet set - -> Maybe (a, a, S.Set arr a) -- new upper bound, new lower bound, trimmed diet set -establishInfinityBoth negInfHi posInfLo s = if posInfLo <= negInfHi - then Nothing - else case locateAdjacentAbove negInfHi s of - Left loIx -> case locateAdjacentBelow posInfLo s of - Left hiIx -> Just (negInfHi,posInfLo,S.slice loIx hiIx s) - Right hiIx -> Just (negInfHi,S.indexLower hiIx s,S.slice loIx (hiIx - 1) s) - Right loIx -> case locateAdjacentBelow posInfLo s of - Left hiIx -> Just (S.indexUpper loIx s,posInfLo,S.slice (loIx + 1) hiIx s) - Right hiIx -> if hiIx <= loIx - then Nothing - else Just (S.indexUpper loIx s, S.indexLower hiIx s, S.slice (loIx + 1) (hiIx - 1) s) - -member :: forall arr a. (Contiguous arr, Element arr a, Ord a) - => a - -> Set arr a - -> Bool -member _ SetAll = True -member x (SetSome negInfHi s posInfLo) = - maybe False (\hi -> hi >= x) negInfHi - || maybe False (\lo -> lo <= x) posInfLo - || S.member x s -{-# INLINEABLE member #-} - -showsPrec :: (Contiguous arr, Element arr a, Show a) - => Int - -> Set arr a - -> ShowS -showsPrec _ SetAll = showString "[(-∞,+∞)]" -showsPrec p (SetSome negInfHi s posInfLo) = showParen (p > 10) $ - showString "fromList " . showListInf shows negInfHi (S.toList s) posInfLo - -showListInf :: (a -> ShowS) -> Maybe a -> [(a,a)] -> Maybe a -> ShowS -showListInf showx mnegInfHi [] mposInfLo s = case mnegInfHi of - Nothing -> case mposInfLo of - Nothing -> "[]" ++ s - Just posInfLo -> '[' : showPosInfLo showx posInfLo (']' : s) - Just negInfHi -> case mposInfLo of - Nothing -> '[' : showNegInfHi showx negInfHi (']' : s) - Just posInfLo -> '[' : showNegInfHi showx negInfHi (',' : showPosInfLo showx posInfLo (']' : s)) -showListInf showx mnegInfHi ((a0,b0):xs) mposInfLo s = - '[' : maybe id (\negInfHi s' -> showNegInfHi showx negInfHi (',' : s')) mnegInfHi ('(' : showx a0 (',' : showx b0 (')' : showl xs))) - where - showl [] = maybe id (\posInfLo -> showChar ',' . showPosInfLo showx posInfLo) mposInfLo (']' : s) - showl ((a,b):ys) = ',' : '(' : showx a (',' : showx b (')' : showl ys)) - -showNegInfHi :: (a -> ShowS) -> a -> ShowS -showNegInfHi showx x s = "(-∞," ++ showx x (")" ++ s) - -showPosInfLo :: (a -> ShowS) -> a -> ShowS -showPosInfLo showx x s = '(' : (showx x (",+∞)" ++ s)) - diff --git a/src/Data/Diet/Unbounded/Set/Lifted.hs b/src/Data/Diet/Unbounded/Set/Lifted.hs deleted file mode 100644 --- a/src/Data/Diet/Unbounded/Set/Lifted.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -O2 #-} -module Data.Diet.Unbounded.Set.Lifted - ( Set - , singleton - , member - ) where - -import Data.Semigroup (Semigroup) -import Data.Primitive (Array) -import qualified GHC.Exts as E -import qualified Data.Semigroup as SG -import qualified Data.Diet.Unbounded.Set.Internal as I - -newtype Set a = Set (I.Set Array a) - -instance Eq a => Eq (Set a) where - Set x == Set y = I.equals x y - -instance (Ord a, Enum a) => Semigroup (Set a) where - Set x <> Set y = Set (I.append x y) - -instance (Ord a, Enum a) => Monoid (Set a) where - mempty = Set (I.empty) - mappend = (SG.<>) - -instance Show a => Show (Set a) where - showsPrec p (Set s) = I.showsPrec p s - --- | /O(1)/ Create an unbounded diet set with a single element. -singleton :: Ord a - => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@ - -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@ - -> Set a -singleton lo hi = Set (I.singleton lo hi) - --- | /O(log n)/ Returns @True@ if the element is a member of the diet set. -member :: Ord a => a -> Set a -> Bool -member a (Set s) = I.member a s - - - 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 @@ -73,9 +73,8 @@ import Control.Monad.Primitive (PrimMonad,PrimState) import Control.Monad.ST (ST,runST) import Data.List.NonEmpty (NonEmpty) -import Data.Primitive.Contiguous (Contiguous,Mutable,Element) +import Data.Primitive.Contiguous (ContiguousU,Mutable,Element) import Data.Primitive.Sort (sortUniqueTaggedMutable) -import Data.Semigroup (Semigroup) import Data.Set.Internal (Set(..)) import qualified Data.Concatenation as C @@ -86,13 +85,13 @@ -- TODO: Do some sneakiness with UnliftedRep data Map karr varr k v = Map !(karr k) !(varr v) -empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v +empty :: (ContiguousU karr, ContiguousU varr) => Map karr varr k v empty = Map I.empty I.empty -null :: Contiguous varr => Map karr varr k v -> Bool +null :: ContiguousU varr => Map karr varr k v -> Bool null (Map _ vals) = I.null vals -singleton :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => k -> v -> Map karr varr k v +singleton :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => k -> v -> Map karr varr k v singleton k v = Map ( runST $ do arr <- I.new 1 @@ -105,13 +104,13 @@ I.unsafeFreeze arr ) -equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool +equals :: (ContiguousU karr, Element karr k, Eq k, ContiguousU varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2 -compare :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Ord v) => Map karr varr k v -> Map karr varr k v -> Ordering +compare :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v, Ord v) => Map karr varr k v -> Map karr varr k v -> Ordering compare m1 m2 = P.compare (toList m1) (toList m2) -fromListWithN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => (v -> v -> v) -> Int -> [(k,v)] -> Map karr varr k v +fromListWithN :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => (v -> v -> v) -> Int -> [(k,v)] -> Map karr varr k v fromListWithN combine n xs = case xs of [] -> empty @@ -119,7 +118,7 @@ let (leftovers, result) = fromAscListWith combine (max 1 n) k v ys in concatWith combine (result : P.map (uncurry singleton) leftovers) -fromListN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +fromListN :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => Int -> [(k,v)] -> Map karr varr k v @@ -128,13 +127,14 @@ (ks,vs) <- mutableArraysFromPairs (max n 1) xs unsafeFreezeZip ks vs -mutableArraysFromPairs :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +mutableArraysFromPairs :: forall s karr varr k v. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => Int -- must be at least one -> [(k,v)] -> ST s (Mutable karr s k, Mutable varr s v) {-# INLINABLE mutableArraysFromPairs #-} mutableArraysFromPairs n xs = do - let go !ix !_ !ks !vs [] = return (ix,ks,vs) + let go :: Int -> Int -> Mutable karr s k -> Mutable varr s v -> [(k,v)] -> ST s (Int, Mutable karr s k, Mutable varr s v) + go !ix !_ !ks !vs [] = return (ix,ks,vs) go !ix !len !ks !vs ((k,v) : ys) = if ix < len then do I.write ks ix k @@ -144,8 +144,8 @@ let len' = len * 2 ks' <- I.new len' vs' <- I.new len' - I.copyMutable ks' 0 ks 0 len - I.copyMutable vs' 0 vs 0 len + I.copyMut ks' 0 (I.sliceMut ks 0 len) + I.copyMut vs' 0 (I.sliceMut vs 0 len) I.write ks' ix k I.write vs' ix v go (ix + 1) len' ks' vs' ys @@ -156,16 +156,16 @@ vsFinal <- I.resize vs' len return (ksFinal,vsFinal) -fromList :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => [(k,v)] -> Map karr varr k v +fromList :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => [(k,v)] -> Map karr varr k v fromList = fromListN 8 -fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => Int -> [(k,v)] -> Map karr varr k v +fromListAppendN :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v, Semigroup v) => Int -> [(k,v)] -> Map karr varr k v fromListAppendN = fromListWithN (SG.<>) -fromListAppend :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [(k,v)] -> Map karr varr k v +fromListAppend :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v, Semigroup v) => [(k,v)] -> Map karr varr k v fromListAppend = fromListAppendN 1 -fromAscListWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +fromAscListWith :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => (v -> v -> v) -> Int -- initial size of buffer, must be 1 or higher -> k -- first key @@ -214,14 +214,14 @@ go 1 k0 n keys0 vals0 xs0 -map :: (Contiguous varr, Contiguous warr, Element varr v, Element warr w) +map :: (ContiguousU varr, ContiguousU warr, Element varr v, Element warr w) => (v -> w) -> Map karr varr k v -> Map karr warr k w map f (Map k v) = Map k (I.map f v) -- | /O(n)/ Map over the elements with access to their corresponding keys. -mapWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) +mapWithKey :: forall karr varr k v w. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (k -> v -> w) -> Map karr varr k v -> Map karr varr k w @@ -244,7 +244,7 @@ return (Map ksFinal vsFinal) -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. -mapMaybe :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) +mapMaybe :: forall karr varr k v w. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (v -> Maybe w) -> Map karr varr k v -> Map karr varr k w @@ -269,7 +269,7 @@ return (Map ksFinal vsFinal) -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. -mapMaybeP :: forall karr varr m k v w. (PrimMonad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) +mapMaybeP :: forall karr varr m k v w. (PrimMonad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (v -> m (Maybe w)) -> Map karr varr k v -> m (Map karr varr k w) @@ -294,7 +294,7 @@ return (Map ksFinal vsFinal) -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. -mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) +mapMaybeWithKey :: forall karr varr k v w. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (k -> v -> Maybe w) -> Map karr varr k v -> Map karr varr k w @@ -319,19 +319,14 @@ 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 :: (ContiguousU karr, Element karr k, Show k, ContiguousU varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) -toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,v)] +toList :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => Map karr varr k v -> [(k,v)] toList = foldrWithKey (\k v xs -> (k,v) : xs) [] -foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) +foldrWithKey :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> v -> b -> b) -> b -> Map karr varr k v @@ -346,7 +341,7 @@ in f k v (go (i + 1)) in go 0 -foldMapWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m) +foldMapWithKey :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Monoid m) => (k -> v -> m) -> Map karr varr k v -> m @@ -360,15 +355,15 @@ in mappend (f k v) (go (i + 1)) in go 0 -adjustMany :: forall karr varr m k v a. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, PrimMonad m, Ord k) +adjustMany :: forall karr varr m k v a. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, PrimMonad m, Ord k) => ((k -> (v -> m v) -> m ()) -> m a) -- Callback that takes a modify function -> Map karr varr k v -> m (Map karr varr k v, a) {-# INLINABLE adjustMany #-} adjustMany f (Map theKeys theVals) = do - mvals <- I.thaw theVals 0 (I.size theVals) + mvals <- I.thaw (I.slice theVals 0 (I.size theVals)) let g :: k -> (v -> m v) -> m () - g !k updateVal = + g !k updateVal = let go !start !end = if end < start then pure () else @@ -386,15 +381,15 @@ rvals <- I.unsafeFreeze mvals pure (Map theKeys rvals, r) -adjustManyInline :: forall karr varr m k v a. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, PrimMonad m, Ord k) +adjustManyInline :: forall karr varr m k v a. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, PrimMonad m, Ord k) => ((k -> (v -> m v) -> m ()) -> m a) -- Callback that takes a modify function -> Map karr varr k v -> m (Map karr varr k v, a) {-# INLINE adjustManyInline #-} adjustManyInline f (Map theKeys theVals) = do - mvals <- I.thaw theVals 0 (I.size theVals) + mvals <- I.thaw (I.slice theVals 0 (I.size theVals)) let g :: k -> (v -> m v) -> m () - g !k updateVal = + g !k updateVal = let go !start !end = if end < start then pure () else @@ -412,44 +407,44 @@ rvals <- I.unsafeFreeze mvals pure (Map theKeys rvals, r) -concat :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [Map karr varr k v] -> Map karr varr k v +concat :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v, Semigroup v) => [Map karr varr k v] -> Map karr varr k v concat = concatWith (SG.<>) -concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +concatWith :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => (v -> v -> v) -> [Map karr varr k v] -> Map karr varr k v concatWith combine = C.concatSized size empty (appendWith combine) -intersectionsWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) +intersectionsWith :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k) => (v -> v -> v) -> NonEmpty (Map karr varr k v) -> Map karr varr k v intersectionsWith f = C.concatSized1 size (intersectionWith f) -appendRightBiased :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v +appendRightBiased :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v appendRightBiased = appendWith const -appendWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) +appendWithKey :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k) => (k -> v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v appendWithKey combine (Map ksA vsA) (Map ksB vsB) = case unionArrWith combine ksA vsA ksB vsB of (k,v) -> Map k v -appendWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) +appendWith :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v appendWith combine (Map ksA vsA) (Map ksB vsB) = case unionArrWith (\_ x y -> combine x y) ksA vsA ksB vsB of (k,v) -> Map k v -append :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k, Semigroup v) +append :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k, Semigroup v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v append (Map ksA vsA) (Map ksB vsB) = case unionArrWith (\_ x y -> x SG.<> y) ksA vsA ksB vsB of (k,v) -> Map k v intersectionWith :: forall k v w x karr varr warr xarr. - (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Contiguous warr, Element warr w, Contiguous xarr, Element xarr x, Ord k) + (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, ContiguousU warr, Element warr w, ContiguousU xarr, Element xarr x, Ord k) => (v -> w -> x) -> Map karr varr k v -> Map karr warr k w @@ -483,7 +478,7 @@ !sz1 = size s1 !sz2 = size s2 -unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +unionArrWith :: forall karr varr k v. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => (k -> v -> v -> v) -> karr k -- keys a -> varr v -- values a @@ -520,13 +515,13 @@ I.write valsDst ixDst valB go ixA (ixB + 1) (ixDst + 1) else do - I.copy keysDst ixDst keysA ixA (szA - ixA) - I.copy valsDst ixDst valsA ixA (szA - ixA) + I.copy keysDst ixDst (I.slice keysA ixA (szA - ixA)) + I.copy valsDst ixDst (I.slice valsA ixA (szA - ixA)) return (ixDst + (szA - ixA)) else if ixB < szB then do - I.copy keysDst ixDst keysB ixB (szB - ixB) - I.copy valsDst ixDst valsB ixB (szB - ixB) + I.copy keysDst ixDst (I.slice keysB ixB (szB - ixB)) + I.copy valsDst ixDst (I.slice valsB ixB (szB - ixB)) return (ixDst + (szB - ixB)) else return ixDst !total <- go 0 0 0 @@ -535,7 +530,7 @@ liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal) lookup :: forall karr varr k v. - (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) + (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => k -> Map karr varr k v -> Maybe v @@ -553,11 +548,11 @@ (# r #) -> Just r GT -> go (mid + 1) end -size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int +size :: (ContiguousU varr, Element varr v) => Map karr varr k v -> Int size (Map _ arr) = I.size arr -- This may have less constraints than size -sizeKeys :: (Contiguous karr, Element karr k) => Map karr varr k v -> Int +sizeKeys :: (ContiguousU karr, Element karr k) => Map karr varr k v -> Int sizeKeys (Map arr _) = I.size arr -- | Sort and deduplicate the key array, preserving the last value associated @@ -565,7 +560,7 @@ -- to this function. This function is only unsafe because of the requirement -- that the arguments not be reused. If the arrays do not match in size, the -- larger one will be truncated to the length of the shorter one. -unsafeFreezeZip :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) +unsafeFreezeZip :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) => Mutable karr s k -> Mutable varr s v -> ST s (Map karr varr k v) @@ -583,13 +578,13 @@ -- -- If either of these conditions is not met, this function will introduce -- undefined behavior or segfaults. -unsafeZipPresorted :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) +unsafeZipPresorted :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => karr k -- array of keys, must already be sorted -> varr v -- array of values -> Map karr varr k v unsafeZipPresorted = Map -foldlWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v) +foldlWithKeyM' :: forall karr varr k v m b. (Monad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (b -> k -> v -> m b) -> b -> Map karr varr k v @@ -606,7 +601,7 @@ else return acc {-# INLINEABLE foldlWithKeyM' #-} -foldrWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v) +foldrWithKeyM' :: forall karr varr k v m b. (Monad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> v -> b -> m b) -> b -> Map karr varr k v @@ -622,7 +617,7 @@ else return acc {-# INLINEABLE foldrWithKeyM' #-} -foldlMapWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b) +foldlMapWithKeyM' :: forall karr varr k v m b. (Monad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Monoid b) => (k -> v -> m b) -> Map karr varr k v -> m b @@ -640,7 +635,7 @@ else return accl {-# INLINEABLE foldlMapWithKeyM' #-} -traverse :: (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) +traverse :: (Applicative m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr w) => (v -> m w) -> Map karr varr k v -> m (Map karr varr k w) @@ -648,7 +643,7 @@ 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) +traverseWithKey :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Element varr v', Applicative f) => (k -> v -> f v') -> Map karr varr k v -> f (Map karr varr k v') @@ -656,7 +651,7 @@ 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) +traverseWithKey_ :: forall karr varr k v m b. (Applicative m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> v -> m b) -> Map karr varr k v -> m () @@ -672,7 +667,7 @@ else pure () {-# INLINEABLE traverseWithKey_ #-} -foldrMapWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b) +foldrMapWithKeyM' :: forall karr varr k v m b. (Monad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Monoid b) => (k -> v -> m b) -> Map karr varr k v -> m b @@ -689,7 +684,7 @@ else return accr {-# INLINEABLE foldrMapWithKeyM' #-} -foldMapWithKey' :: forall karr varr k v m. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m) +foldMapWithKey' :: forall karr varr k v m. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Monoid m) => (k -> v -> m) -> Map karr varr k v -> m @@ -705,7 +700,7 @@ else accl {-# INLINEABLE foldMapWithKey' #-} -foldlWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v) +foldlWithKey' :: forall karr varr k v b. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (b -> k -> v -> b) -> b -> Map karr varr k v @@ -722,7 +717,7 @@ else acc {-# INLINEABLE foldlWithKey' #-} -foldrWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v) +foldrWithKey' :: forall karr varr k v b. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> v -> b -> b) -> b -> Map karr varr k v @@ -740,7 +735,7 @@ -- The algorithm used here is good when the subset is small, but -- when the subset is large, it is worse that just walking the map. -restrict :: forall karr varr k v. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) +restrict :: forall karr varr k v. (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, Ord k) => Map karr varr k v -> Set karr k -> Map karr varr k v @@ -772,8 +767,8 @@ stage2 !ix = runST $ do ksMut <- I.new szMin vsMut <- I.new szMin - I.copy ksMut 0 ks 0 ix - I.copy vsMut 0 vs 0 ix + I.copy ksMut 0 (I.slice ks 0 ix) + I.copy vsMut 0 (I.slice vs 0 ix) let -- TODO: Turn this into a galloping search. It would -- probably be worth trying this out on -- Data.Set.Internal.intersection first. @@ -795,14 +790,14 @@ return (Map ks' vs') {-# INLINEABLE restrict #-} -fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) +fromSet :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> v) -> Set karr k -> Map karr varr k v fromSet f (Set arr) = Map arr (I.map f arr) {-# INLINE fromSet #-} -fromSetP :: (PrimMonad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v) +fromSetP :: (PrimMonad m, ContiguousU karr, Element karr k, ContiguousU varr, Element varr v) => (k -> m v) -> Set karr k -> m (Map karr varr k v) @@ -815,7 +810,7 @@ elems :: Map karr varr k v -> varr v elems (Map _ v) = v -rnf :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, NFData k, NFData v) +rnf :: (ContiguousU karr, Element karr k, ContiguousU varr, Element varr v, NFData k, NFData v) => Map karr varr k v -> () rnf (Map k v) = seq (I.rnf k) (seq (I.rnf v) ()) diff --git a/src/Data/Map/Interval.hs b/src/Data/Map/Interval.hs deleted file mode 100644 --- a/src/Data/Map/Interval.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-| - -This module only exists for documentation. It should never be imported. - -The interval maps provided by the submodules of `Data.Map.Interval` -coallesce overlapping intervals. Their behavior differs from that -of the type from the `IntervalMap` package. The interval map from -that package preserves all the original interval that were used -as keys for the map. The interval map from this package creates a -new interval from the overlap, combining the values. - -There are several points in the design space to explore with this -kind of interval map. A motivation for some of these variants is -having `Eq` instances that satisfy a bidirectional variant of the -substition law. That is: - -> ∀ x y. (x == y ↔ ∀ f. f x == f y) - -Here are the different design choices that we face: - -* Discrete (D) vs Continuous (C): The basically comes down to whether or - not there is an `Enum` instance for the type. Although it cannot be - enforced by the type system, continuous-keyed maps should not use discrete - types as keys. The bidirectional substituion law is not upheld in this - case. The discrete-keyed interval map uses `succ` and `pred` - to coalesce adjacent intervals. The continuous-keyed interval map, - assuming that unequal values have infinitely many values between - them, only considers merging adjacent intervals when an open interval - butts up against a closed interval with a matching key. -* Bounded (B) vs Unbounded (U): Is there a Bounded instance for the type? - Bounded types can treat `maxBound` as infinity. Unbounded types like - `Integer` and `Text` have no value for infinity. If the key type has - a `Bounded` instance, it is incorrect to use it in an unbounded interval - map since the `Eq` instance will not satisfy the bidirectional substitution law. -* Partial (P) vs Total (T): Is there a value corresponding to every key? - The decides whether or not the return value of `lookup` is wrapped in a - `Maybe`. Total maps with unconstrained values also have an `Applicative` - instance. The internal representation of total maps is also more - efficient than that of partial maps since we only need to store the - upper bound of each interval. -* Coalesce (S) vs Detach (H): The names here a little here are a little - misleading. The strict variant uses on an `Eq` instance for values - to coallesce adjacent ranges. For example, with discrete integers, - the interval-value pairs ([4,6],12) and ([7,9],12) can be coallesced - because 6 is adjacent to 7 and both pairs share value 12. Coalescing - in this way is crucial to satisfying the bidirectional substitution - law. It also induces value-strictness. Some users may prefer - laziness in the values. This is also offered, but none of the - value-lazy interval maps have `Eq` instances since it is not possible - to satisfy the bidirectional substitution law without forcing the - values. - -The modules are named using acronyms that refer to various combinations -of these flavors. For exmaple, `Data.Map.Interval.DUTS` provides the -discrete unbounded total strict interval map. Some combinations are not -provided because the author is unaware of useful types that meet the -restrictions (for example, pairing continuous and bounded seems -dubious). - -For users who want to use 'Double' as the key type, it is recommended -that CUxx be used since the `Enum` instance for `Double` is dubious. - --} -module Data.Map.Interval () where diff --git a/src/Data/Map/Interval/DBTS/Internal.hs b/src/Data/Map/Interval/DBTS/Internal.hs deleted file mode 100644 --- a/src/Data/Map/Interval/DBTS/Internal.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTSyntax #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ViewPatterns #-} - -module Data.Map.Interval.DBTS.Internal - ( Map - , pure - , singleton - , empty - , lookup - , union - , unionWith - , equals - , map - , mapBijection - , traverseP - , traverse - , traverse_ - , fromList - , foldrWithKey - , foldlWithKeyM' - , foldl' - , foldlM' - , foldMap - , toList - , showsPrec - , concat - , elems - , size - , convertKeys - , convertKeysValues - ) where - --- TODO: In very unusual situation where the keys or values --- are passed to the FFI, the approach used here can lead to --- unsoundness. This will be addressed in GHC 8.10. - -import Prelude hiding (pure,lookup,compare,map,showsPrec,concat,traverse,foldMap) - -import Control.Monad.ST (ST,runST) -import Control.Monad.Primitive (PrimMonad) -import Data.Kind (Type) -import Data.Primitive (PrimArray) -import Data.Primitive.Contiguous (Contiguous,Element,Mutable) -import GHC.Exts (ArrayArray#) -import qualified Data.Concatenation as C -import qualified Data.Primitive.Contiguous as I -import qualified Prelude as P - --- | The key array is the same length as the value array. Every key --- is the upper bound of a range. The keys array always has a length --- of at least one. The last element is always maxBound. The lowest bound --- is assumed to be minBound. For example, the interval map of @Int16@: --- --- > [-inf,5],[6,17],[18,20],[21,+inf] --- --- Would be represented by the keys: --- --- > 5,17,20,65536 -data Map :: (Type -> Type) -> (Type -> Type) -> Type -> Type -> Type where - MapInternal :: ArrayArray# -> ArrayArray# -> Map karr varr k v - -- Map !(karr k) !(varr v) - -typedArrays :: (Contiguous karr, Contiguous varr) => Map karr varr k v -> (karr k, varr v) -typedArrays (MapInternal ks vs) = (I.lift ks, I.lift vs) - -typedValues :: Contiguous varr => Map karr varr k v -> (# ArrayArray#, varr v #) -typedValues (MapInternal ks vs) = (# ks, I.lift vs #) - -typedKeys :: Contiguous karr => Map karr varr k v -> (# karr k, ArrayArray# #) -typedKeys (MapInternal ks vs) = (# I.lift ks, vs #) - -pattern Map :: (Contiguous karr, Contiguous varr) => () => karr k -> varr v -> Map karr varr k v -pattern Map ks vs <- (typedArrays -> (ks,vs)) where - Map xs ys = MapInternal (I.unlift xs) (I.unlift ys) - -pattern MapValues :: Contiguous varr => () => ArrayArray# -> varr v -> Map karr varr k v -pattern MapValues ks vs <- (typedValues -> (# ks, vs #)) where - MapValues xs ys = MapInternal xs (I.unlift ys) - -pattern MapKeys :: Contiguous karr => () => karr k -> ArrayArray# -> Map karr varr k v -pattern MapKeys ks vs <- (typedKeys -> (# ks, vs #)) where - MapKeys xs ys = MapInternal (I.unlift xs) ys - -{-# COMPLETE Map #-} -{-# COMPLETE MapValues #-} -{-# COMPLETE MapKeys #-} - -equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool -equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2 - -size :: (Contiguous varr, Element varr v) - => Map karr varr k v - -> Int -size (MapValues _ v) = I.size v - --- compare :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Ord v) => Map karr varr k v -> Map karr varr k v -> Bool --- compare (Map k1 v1) (Map k2 v2) = mappend (I.compare k1 k2) (I.compare v1 v2) - --- Note: this is only correct when the function is a bijection. -mapBijection :: (Contiguous varr, Element varr v, Element varr w) - => (v -> w) -> Map karr varr k v -> Map karr varr k w -mapBijection f (MapValues k v) = MapValues k (I.map f v) - --- The function does not need to be a bijection. It may cause adjacent --- keys to collapse if their values become the same. -map :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w, Eq w) - => (v -> w) - -> Map karr varr k v - -> Map karr varr k w -map f (Map keys vals) = runST action where - !sz = I.size vals - action :: forall s. ST s (Map karr varr k w) - action = do - m <- I.new sz - let go :: Int -> Int -> w -> [Int] -> Int -> ST s (Int,[Int],Int) - go !ixSrc !ixDst !prevVal !dropped !droppedCount = if ixSrc < sz - then do - oldVal <- I.indexM vals ixSrc - let val = f oldVal - if val == prevVal - then go (ixSrc + 1) ixDst val ((ixSrc - 1) : dropped) (droppedCount + 1) - else do - I.write m ixDst val - go (ixSrc + 1) (ixDst + 1) val dropped droppedCount - else return (ixDst,dropped,droppedCount) - v0 <- I.indexM vals 0 - let !w0 = f v0 - I.write m 0 w0 - (len,dropped,droppedCount) <- go 1 1 w0 [] 0 - vals' <- I.resize m len >>= I.unsafeFreeze - case droppedCount of - 0 -> return (Map keys vals') - _ -> do - n <- I.new len - let !(d :: PrimArray Int) = I.unsafeFromListReverseN (droppedCount + 1) (maxBound : dropped) - let run :: Int -> Int -> Int -> ST s () - run !ixKey !ixDst !ixDrop = if ixKey < sz - then if I.index d ixDrop == ixKey - then run (ixKey + 1) ixDst (ixDrop + 1) - else do - I.write n ixDst =<< I.indexM keys ixKey - run (ixKey + 1) (ixDst + 1) ixDrop - else return () - run 0 0 0 - keys' <- I.unsafeFreeze n - return (Map keys' vals') - - --- Note: this is only correct when the function is a bijection. -traverseP :: (Contiguous varr, Element varr v, Element varr w, PrimMonad m) - => (v -> m w) -> Map karr varr k v -> m (Map karr varr k w) -traverseP f (MapValues k v) = fmap (MapValues k) (I.traverseP f v) - --- Note: this is only correct when the function is a bijection. -traverse :: (Contiguous varr, Element varr v, Element varr w, Applicative m) - => (v -> m w) -> Map karr varr k v -> m (Map karr varr k w) -traverse f (MapValues k v) = fmap (MapValues k) (I.traverse f v) - -traverse_ :: (Contiguous varr, Element varr v, Applicative m) - => (v -> m w) -> Map karr varr k v -> m () -traverse_ f (MapValues _ v) = I.traverse_ f v - -pure :: (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k) => v -> Map karr varr k v -pure v = Map - (runST $ do - !(arr :: Mutable karr s k) <- I.replicateMutable 1 maxBound - I.unsafeFreeze arr - ) - (runST $ do - !(arr :: Mutable varr s v) <- I.replicateMutable 1 v - I.unsafeFreeze arr - ) - --- This is not actually empty, but it is the monoidal identity. -empty :: (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k, Monoid v) => Map karr varr k v -empty = pure mempty - -singleton :: forall karr varr k v. (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k, Enum k, Ord k, Eq v) - => v -- value outside of the interval - -> k -- lower bound - -> k -- upper bound - -> v -- value inside the interval - -> Map karr varr k v -singleton def lo hi v = if lo <= hi && def /= v - then if lo > minBound - then if hi < maxBound - then Map - (runST $ do - !(arr :: Mutable karr s k) <- I.new 3 - I.write arr 0 (pred lo) - I.write arr 1 hi - I.write arr 2 maxBound - I.unsafeFreeze arr - ) - (runST $ do - !(arr :: Mutable varr s v) <- I.new 3 - I.write arr 0 def - I.write arr 1 v - I.write arr 2 def - I.unsafeFreeze arr - ) - else Map - (runST $ do - !(arr :: Mutable karr s k) <- I.new 2 - I.write arr 0 (pred lo) - I.write arr 1 maxBound - I.unsafeFreeze arr - ) - (runST $ do - !(arr :: Mutable varr s v) <- I.new 2 - I.write arr 0 def - I.write arr 1 v - I.unsafeFreeze arr - ) - else if hi < maxBound - then Map - (runST $ do - !(arr :: Mutable karr s k) <- I.new 2 - I.write arr 0 hi - I.write arr 1 maxBound - I.unsafeFreeze arr - ) - (runST $ do - !(arr :: Mutable varr s v) <- I.new 2 - I.write arr 0 v - I.write arr 1 def - I.unsafeFreeze arr - ) - else pure v - else pure def - -lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) - => k -> Map karr varr k v -> v -lookup a (Map keys vals) = go 0 (I.size vals - 1) - where - go :: Int -> Int -> v - go !start !end - -- The threshold used here could be any nonnegative number. - -- This algorithm will be correct regardless. Switching from - -- a divide-and-conquer approach to a simple scan when the map - -- is small improves performance. - | delta > 8 = - let !mid = div (end + start) 2 - !valHi = I.index keys mid - in case P.compare a valHi of - LT -> go start mid - EQ -> let !(# v #) = I.index# vals mid in v - GT -> go (mid + 1) end - | otherwise = finish start end - where !delta = end - start - finish :: Int -> Int -> v - finish !start !end = - let !(# val #) = I.index# keys start - in if a > val - then finish (start + 1) end - else let !(# v #) = I.index# vals start in v -{-# INLINEABLE lookup #-} - -union :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v, Semigroup v) - => Map karr varr k v - -> Map karr varr k v - -> Map karr varr k v -union = unionWith (<>) - --- This is also known as liftA2 -unionWith :: forall karr aarr barr carr k a b c. (Contiguous karr, Element karr k, Ord k, Contiguous aarr, Element aarr a, Contiguous barr, Element barr b, Contiguous carr, Element carr c, Eq c) - => (a -> b -> c) - -> Map karr aarr k a - -> Map karr barr k b - -> Map karr carr k c -unionWith combine (Map keysA valsA) (Map keysB valsB) = runST action where - action :: forall s. ST s (Map karr carr k c) - action = do - let szA = I.size keysA - szB = I.size keysB - szMax = szA + szB - keysDst <- I.new szMax - valsDst <- I.new szMax - -- For total maps, we don't have to worry about one map running out - -- before the other. Also, this function has a precondition that - -- all three indices are greater than zero. - let go :: Int -> Int -> Int -> c -> ST s Int - go !ixA !ixB !ixDst prevVal = if ixA < szA && ixB < szB - then do - keyA <- I.indexM keysA ixA - keyB <- I.indexM keysB ixB - case P.compare keyA keyB of - EQ -> do - valA <- I.indexM valsA ixA - valB <- I.indexM valsB ixB - let !v = combine valA valB - if v == prevVal - then do - I.write keysDst (ixDst - 1) keyA - go (ixA + 1) (ixB + 1) ixDst v - else do - I.write keysDst ixDst keyA - I.write valsDst ixDst v - go (ixA + 1) (ixB + 1) (ixDst + 1) v - LT -> do - valA <- I.indexM valsA ixA - valB <- I.indexM valsB ixB - let !v = combine valA valB - if v == prevVal - then do - I.write keysDst (ixDst - 1) keyA - go (ixA + 1) ixB ixDst v - else do - I.write keysDst ixDst keyA - I.write valsDst ixDst v - go (ixA + 1) ixB (ixDst + 1) v - GT -> do - valA <- I.indexM valsA ixA - valB <- I.indexM valsB ixB - let !v = combine valA valB - if v == prevVal - then do - I.write keysDst (ixDst - 1) keyB - go ixA (ixB + 1) ixDst v - else do - I.write keysDst ixDst keyB - I.write valsDst ixDst v - go ixA (ixB + 1) (ixDst + 1) v - else return ixDst - keyA <- I.indexM keysA 0 - keyB <- I.indexM keysB 0 - valA <- I.indexM valsA 0 - valB <- I.indexM valsB 0 - let v = combine valA valB - dstIx <- case P.compare keyA keyB of - EQ -> do - I.write keysDst 0 keyA - I.write valsDst 0 v - go 1 1 1 v - LT -> do - I.write keysDst 0 keyA - I.write valsDst 0 v - go 1 0 1 v - GT -> do - I.write keysDst 0 keyB - I.write valsDst 0 v - go 0 1 1 v - keys <- I.resize keysDst dstIx >>= I.unsafeFreeze - vals <- I.resize valsDst dstIx >>= I.unsafeFreeze - return (Map keys vals) - -showsPrec :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k, Show k, Show v) - => Int -> Map karr varr k v -> ShowS -showsPrec p m = showParen (p > 10) - $ showString "fromList " - . shows (toList m) - -foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k) - => (k -> k -> v -> b -> b) - -> b - -> Map karr varr k v - -> b -foldrWithKey f z (Map keys vals) = - let !sz = I.size vals - -- we must be lazy in the second argument - go !i lo - | i == sz = z - | otherwise = - let !hi = I.index keys i - !(# v #) = I.index# vals i - in f lo hi v (go (i + 1) (succ hi)) - in go 0 minBound - -foldlWithKeyM' :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k, Monad m) - => (b -> k -> k -> v -> m b) - -> b - -> Map karr varr k v - -> m b -foldlWithKeyM' f z (Map keys vals) = - let !sz = I.size vals - -- we must be lazy in the third argument - go !i !acc lo - | i == sz = return acc - | otherwise = do - let !hi = I.index keys i - !(# v #) = I.index# vals i - acc' <- f acc lo hi v - go (i + 1) acc' (succ hi) - in go 0 z minBound - -foldl' :: (Contiguous varr, Element varr v) - => (b -> v -> b) - -> b - -> Map karr varr k v - -> b -foldl' f b0 (MapValues _ vals) = I.foldl' f b0 vals - -foldlM' :: (Contiguous varr, Element varr v, Monad m) - => (b -> v -> m b) - -> b - -> Map karr varr k v - -> m b -foldlM' f b0 (MapValues _ vals) = I.foldlM' f b0 vals - -foldMap :: (Contiguous varr, Element varr v, Monoid m) - => (v -> m) - -> Map karr varr k v - -> m -foldMap f (MapValues _ vals) = I.foldMap f vals - -toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k) - => Map karr varr k v - -> [(k,k,v)] -toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) [] - -fromList :: (Contiguous karr, Element karr k, Bounded k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) - => v -- value outside of the ranges - -> [(k,k,v)] - -> Map karr varr k v -fromList def xs = concatWith - def - (\x y -> if x == def then y else x) - (P.map (\(lo,hi,v) -> singleton def lo hi v) xs) - -concatWith :: forall karr varr k v. (Contiguous karr, Bounded k, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v) - => v -- value used if the list is empty - -> (v -> v -> v) - -> [Map karr varr k v] - -> Map karr varr k v -concatWith def combine = C.concatSized size (pure def) (unionWith combine) - -concat :: (Contiguous karr, Bounded k, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v, Monoid v) - => [Map karr varr k v] - -> Map karr varr k v -concat = concatWith mempty mappend - -elems :: Contiguous varr => Map karr varr k v -> varr v -elems (MapValues _ v) = v - --- TODO: use convert instead of map once that function --- is released in a version of contiguous. -convertKeys :: (Contiguous karr, Element karr k, Contiguous jarr, Element jarr k) - => Map karr varr k v -> Map jarr varr k v -convertKeys (MapKeys ks vs) = MapKeys (I.map id ks) vs - --- TODO: use convert instead of map once that function --- is released in a version of contiguous. -convertKeysValues :: (Contiguous karr, Element karr k, Contiguous jarr, Element jarr k, Contiguous varr, Element varr v, Contiguous warr, Element warr v) - => Map karr varr k v -> Map jarr warr k v -convertKeysValues (Map ks vs) = Map (I.map id ks) (I.map id vs) - diff --git a/src/Data/Map/Interval/DBTSLL.hs b/src/Data/Map/Interval/DBTSLL.hs deleted file mode 100644 --- a/src/Data/Map/Interval/DBTSLL.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - -module Data.Map.Interval.DBTSLL - ( Map(..) -- data constructor exposed as a hack - , pure - , singleton - , lookup - , fromList - , unionWith - -- * Mapping - , map - , mapBijection - -- * Traversals - , traverseBijectionP - , traverseBijection - -- * Folds - , foldl' - , foldlM' - , foldMap - , foldrWithKey - , foldlWithKeyM' - , traverse_ - -- * Properties - , size - -- * Conversion - , elems - , toList - ) where - -import Prelude hiding (lookup,map,pure,foldMap) - -import Data.Semigroup (Semigroup) -import Data.Primitive.Array (Array) -import Control.Monad.Primitive (PrimMonad) -import qualified Data.Semigroup as SG -import qualified Data.Foldable as F -import qualified Data.Map.Interval.DBTS.Internal as I -import qualified GHC.Exts as E - --- | A total interval map from keys @k@ to values @v@. The key type must be discrete --- and bounded. This map is strict in the values. -newtype Map k v = Map (I.Map Array Array k v) - -instance (Eq k, Eq v) => Eq (Map k v) where - Map x == Map y = I.equals x y - --- instance (Ord k, Ord v) => Ord (Map k v) where --- compare (Map x) (Map y) = I.compare x y - -instance (Ord k, Semigroup v, Eq v) => Semigroup (Map k v) where - Map x <> Map y = Map (I.union x y) - --- The redundant constraint is needed for GHC < 8.4 -instance (Ord k, Bounded k, Semigroup v, Monoid v, Eq v) => Monoid (Map k v) where - mappend = (SG.<>) - mempty = Map I.empty - mconcat = Map . I.concat . E.coerce - -instance (Bounded k, Enum k, Show k, Show v) => Show (Map k v) where - showsPrec p (Map m) = I.showsPrec p m - -instance (Bounded k, Enum k, Ord k, Eq v, Monoid v) => E.IsList (Map k v) where - type Item (Map k v) = (k,k,v) - fromList xs = Map (I.fromList mempty xs) - toList (Map m) = I.toList m - -instance Foldable (Map k) where - foldr f b (Map m) = F.foldr f b (I.elems m) - foldl' f b (Map m) = F.foldl' f b (I.elems m) - toList (Map m) = F.toList (I.elems m) - length (Map m) = F.length (I.elems m) - -pure :: Bounded k => v -> Map k v -pure = Map . I.pure - -singleton :: (Bounded k, Enum k, Ord k, Eq v) - => v -- ^ value outside of the interval - -> k -- ^ lower bound - -> k -- ^ upper bound - -> v -- ^ value inside the interval - -> Map k v -singleton def lo hi v = Map (I.singleton def lo hi v) - -lookup :: Ord k => k -> Map k v -> v -lookup k (Map m) = I.lookup k m - --- | Create an interval map from a list of range-value triples. The first --- argument is a default value used everywhere outside of the given --- ranges. In the case of overlapping ranges, the leftmost value is --- used. -fromList :: (Bounded k, Ord k, Enum k, Eq v) - => v -- ^ value outside of the ranges - -> [(k,k,v)] -- ^ low-high inclusive ranges with their corresponding values - -> Map k v -fromList def xs = Map (I.fromList def xs) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijectionP :: PrimMonad m - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijectionP f (Map m) = fmap Map (I.traverseP f m) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijection :: Applicative m - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijection f (Map m) = fmap Map (I.traverse f m) - -traverse_ :: Applicative m => (v -> m w) -> Map k v -> m () -traverse_ f (Map m) = I.traverse_ f m - -mapBijection :: (v -> w) -> Map k v -> Map k w -mapBijection f (Map m) = Map (I.mapBijection f m) - -map :: Eq w => (v -> w) -> Map k v -> Map k w -map f (Map m) = Map (I.map f m) - -foldl' :: - (b -> v -> b) - -> b - -> Map k v - -> b -foldl' f b0 (Map m) = I.foldl' f b0 m - -foldlM' :: Monad m - => (b -> v -> m b) - -> b - -> Map k v - -> m b -foldlM' f b0 (Map m) = I.foldlM' f b0 m - -foldMap :: (Monoid m) - => (v -> m) - -> Map k v - -> m -foldMap f (Map m) = I.foldMap f m - -unionWith :: (Ord k, Eq c) - => (a -> b -> c) - -> Map k a - -> Map k b - -> Map k c -unionWith f (Map a) (Map b) = Map (I.unionWith f a b) - -foldrWithKey :: (Bounded k, Enum k) - => (k -> k -> v -> b -> b) - -> b - -> Map k v - -> b -foldrWithKey f z (Map m) = I.foldrWithKey f z m - -foldlWithKeyM' :: (Bounded k, Enum k, Monad m) - => (b -> k -> k -> v -> m b) - -> b - -> Map k v - -> m b -foldlWithKeyM' f z (Map m) = I.foldlWithKeyM' f z m - --- | The number of values in the interval map. Also the number of --- contiguous key ranges in the map. -size :: Map k v -> Int -size (Map m) = I.size m - -elems :: Map k v -> Array v -elems (Map m) = I.elems m - -toList :: (Bounded k, Enum k) => Map k v -> [(k,k,v)] -toList (Map m) = I.toList m diff --git a/src/Data/Map/Interval/DBTSUL.hs b/src/Data/Map/Interval/DBTSUL.hs deleted file mode 100644 --- a/src/Data/Map/Interval/DBTSUL.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - -module Data.Map.Interval.DBTSUL - ( Map - , pure - , singleton - , lookup - , fromList - , unionWith - -- * Mapping - , map - , mapBijection - -- * Traversals - , traverseBijectionP - , traverseBijection - -- * Folds - , foldl' - , foldlM' - , foldMap - , foldrWithKey - , foldlWithKeyM' - , traverse_ - -- * Properties - , size - -- * Conversion - , elems - , toList - , fromLiftedLifted - ) where - -import Prelude hiding (lookup,map,pure,foldMap) - -import Data.Semigroup (Semigroup) -import Data.Primitive.Array (Array) -import Data.Primitive (PrimArray) -import Data.Primitive.Types (Prim) -import Control.Monad.Primitive (PrimMonad) -import qualified Data.Semigroup as SG -import qualified Data.Map.Interval.DBTS.Internal as I -import qualified Data.Map.Interval.DBTSLL as DBTSLL -import qualified GHC.Exts as E - --- | A total interval map from keys @k@ to values @v@. The key type must be discrete --- and bounded. This map is strict in the values. The key type must have a --- 'Prim' instance. -newtype Map k v = Map (I.Map PrimArray Array k v) - -instance (Prim k, Eq k, Eq v) => Eq (Map k v) where - Map x == Map y = I.equals x y - -instance (Prim k, Ord k, Semigroup v, Eq v) => Semigroup (Map k v) where - Map x <> Map y = Map (I.union x y) - --- The redundant constraint is needed for GHC < 8.4 -instance (Prim k, Ord k, Bounded k, Semigroup v, Monoid v, Eq v) => Monoid (Map k v) where - mappend = (SG.<>) - mempty = Map I.empty - mconcat = Map . I.concat . E.coerce - -instance (Prim k, Bounded k, Enum k, Show k, Show v) => Show (Map k v) where - showsPrec p (Map m) = I.showsPrec p m - -instance (Prim k, Bounded k, Enum k, Ord k, Eq v, Monoid v) => E.IsList (Map k v) where - type Item (Map k v) = (k,k,v) - fromList xs = Map (I.fromList mempty xs) - toList (Map m) = I.toList m - -pure :: (Prim k, Bounded k) => v -> Map k v -pure = Map . I.pure - -singleton :: (Prim k, Bounded k, Enum k, Ord k, Eq v) - => v -- ^ value outside of the interval - -> k -- ^ lower bound - -> k -- ^ upper bound - -> v -- ^ value inside the interval - -> Map k v -singleton def lo hi v = Map (I.singleton def lo hi v) - --- | /O(log n)/ Lookup a key. The value corresponding to the range --- that contains this key will be returned. -lookup :: (Ord k, Prim k) => k -> Map k v -> v -lookup k (Map m) = I.lookup k m - --- | Create an interval map from a list of range-value triples. The first --- argument is a default value used everywhere outside of the given --- ranges. In the case of overlapping ranges, the leftmost value is --- used. -fromList :: (Prim k, Bounded k, Ord k, Enum k, Eq v) - => v -- ^ value outside of the ranges - -> [(k,k,v)] -- ^ low-high inclusive ranges with their corresponding values - -> Map k v -fromList def xs = Map (I.fromList def xs) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijectionP :: PrimMonad m - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijectionP f (Map m) = fmap Map (I.traverseP f m) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijection :: Applicative m - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijection f (Map m) = fmap Map (I.traverse f m) - -traverse_ :: Applicative m => (v -> m w) -> Map k v -> m () -traverse_ f (Map m) = I.traverse_ f m - -mapBijection :: (v -> w) -> Map k v -> Map k w -mapBijection f (Map m) = Map (I.mapBijection f m) - -map :: (Prim k, Eq w) => (v -> w) -> Map k v -> Map k w -map f (Map m) = Map (I.map f m) - -foldl' :: Prim k - => (b -> v -> b) - -> b - -> Map k v - -> b -foldl' f b0 (Map m) = I.foldl' f b0 m - -foldlM' :: (Monad m, Prim k) - => (b -> v -> m b) - -> b - -> Map k v - -> m b -foldlM' f b0 (Map m) = I.foldlM' f b0 m - -foldMap :: (Monoid m, Prim k) - => (v -> m) - -> Map k v - -> m -foldMap f (Map m) = I.foldMap f m - -unionWith :: (Ord k, Eq c, Prim k) - => (a -> b -> c) - -> Map k a - -> Map k b - -> Map k c -unionWith f (Map a) (Map b) = Map (I.unionWith f a b) - -foldrWithKey :: (Bounded k, Enum k, Prim k) - => (k -> k -> v -> b -> b) - -> b - -> Map k v - -> b -foldrWithKey f z (Map m) = I.foldrWithKey f z m - -foldlWithKeyM' :: (Bounded k, Enum k, Monad m, Prim k) - => (b -> k -> k -> v -> m b) - -> b - -> Map k v - -> m b -foldlWithKeyM' f z (Map m) = I.foldlWithKeyM' f z m - --- | The number of values in the interval map. Also the number of --- contiguous key ranges in the map. -size :: Map k v -> Int -size (Map m) = I.size m - -elems :: Map k v -> Array v -elems (Map m) = I.elems m - -toList :: (Bounded k, Enum k, Prim k) => Map k v -> [(k,k,v)] -toList (Map m) = I.toList m - -fromLiftedLifted :: Prim k => DBTSLL.Map k v -> Map k v -fromLiftedLifted (DBTSLL.Map m) = Map (I.convertKeys m) diff --git a/src/Data/Map/Interval/DBTSUU.hs b/src/Data/Map/Interval/DBTSUU.hs deleted file mode 100644 --- a/src/Data/Map/Interval/DBTSUU.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - -module Data.Map.Interval.DBTSUU - ( Map - , pure - , singleton - , lookup - , fromList - , unionWith - -- * Mapping - , map - , mapBijection - -- * Traversals - , traverseBijectionP - , traverseBijection - -- * Folds - , foldl' - , foldlM' - , foldMap - , foldrWithKey - , foldlWithKeyM' - , traverse_ - -- * Properties - , size - -- * Conversion - , elems - , toList - , fromLiftedLifted - ) where - -import Prelude hiding (lookup,map,pure,foldMap) - -import Data.Semigroup (Semigroup) -import Data.Primitive.Array (Array) -import Data.Primitive (PrimArray) -import Data.Primitive.Types (Prim) -import Control.Monad.Primitive (PrimMonad) -import qualified Data.Semigroup as SG -import qualified Data.Map.Interval.DBTS.Internal as I -import qualified Data.Map.Interval.DBTSLL as DBTSLL -import qualified GHC.Exts as E - --- | A total interval map from keys @k@ to values @v@. The key type must be discrete --- and bounded. This map is strict in the values. The key type and the value type --- must both have 'Prim' instances. -newtype Map k v = Map (I.Map PrimArray PrimArray k v) - -instance (Prim k, Prim v, Eq k, Eq v) => Eq (Map k v) where - Map x == Map y = I.equals x y - -instance (Prim k, Prim v, Ord k, Semigroup v, Eq v) => Semigroup (Map k v) where - Map x <> Map y = Map (I.union x y) - --- The redundant constraint is needed for GHC < 8.4 -instance (Prim k, Ord k, Bounded k, Prim v, Semigroup v, Monoid v, Eq v) => Monoid (Map k v) where - mappend = (SG.<>) - mempty = Map I.empty - mconcat = Map . I.concat . E.coerce - -instance (Prim k, Bounded k, Enum k, Show k, Prim v, Show v) => Show (Map k v) where - showsPrec p (Map m) = I.showsPrec p m - -instance (Prim k, Bounded k, Enum k, Ord k, Prim v, Eq v, Monoid v) => E.IsList (Map k v) where - type Item (Map k v) = (k,k,v) - fromList xs = Map (I.fromList mempty xs) - toList (Map m) = I.toList m - -pure :: (Prim k, Bounded k, Prim v) => v -> Map k v -pure = Map . I.pure - -singleton :: (Prim k, Bounded k, Enum k, Ord k, Prim v, Eq v) - => v -- ^ value outside of the interval - -> k -- ^ lower bound - -> k -- ^ upper bound - -> v -- ^ value inside the interval - -> Map k v -singleton def lo hi v = Map (I.singleton def lo hi v) - --- | /O(log n)/ Lookup a key. The value corresponding to the range --- that contains this key will be returned. -lookup :: (Ord k, Prim k, Prim v) => k -> Map k v -> v -lookup k (Map m) = I.lookup k m - --- | Create an interval map from a list of range-value triples. The first --- argument is a default value used everywhere outside of the given --- ranges. In the case of overlapping ranges, the leftmost value is --- used. -fromList :: (Prim k, Bounded k, Ord k, Enum k, Prim v, Eq v) - => v -- ^ value outside of the ranges - -> [(k,k,v)] -- ^ low-high inclusive ranges with their corresponding values - -> Map k v -fromList def xs = Map (I.fromList def xs) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijectionP :: (PrimMonad m, Prim v, Prim w) - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijectionP f (Map m) = fmap Map (I.traverseP f m) - --- | This only provides a correct result when the effectful mapping --- is a bijection. -traverseBijection :: (Applicative m, Prim v, Prim w) - => (v -> m w) -> Map k v -> m (Map k w) -traverseBijection f (Map m) = fmap Map (I.traverse f m) - -traverse_ :: (Applicative m, Prim v) => (v -> m w) -> Map k v -> m () -traverse_ f (Map m) = I.traverse_ f m - -mapBijection :: (Prim v, Prim w) => (v -> w) -> Map k v -> Map k w -mapBijection f (Map m) = Map (I.mapBijection f m) - -map :: (Prim k, Prim v, Prim w, Eq w) => (v -> w) -> Map k v -> Map k w -map f (Map m) = Map (I.map f m) - -foldl' :: (Prim k, Prim v) - => (b -> v -> b) - -> b - -> Map k v - -> b -foldl' f b0 (Map m) = I.foldl' f b0 m - -foldlM' :: (Monad m, Prim k, Prim v) - => (b -> v -> m b) - -> b - -> Map k v - -> m b -foldlM' f b0 (Map m) = I.foldlM' f b0 m - -foldMap :: (Monoid m, Prim k, Prim v) - => (v -> m) - -> Map k v - -> m -foldMap f (Map m) = I.foldMap f m - -unionWith :: (Ord k, Eq c, Prim k, Prim a, Prim b, Prim c) - => (a -> b -> c) - -> Map k a - -> Map k b - -> Map k c -unionWith f (Map a) (Map b) = Map (I.unionWith f a b) - -foldrWithKey :: (Bounded k, Enum k, Prim k, Prim v) - => (k -> k -> v -> b -> b) - -> b - -> Map k v - -> b -foldrWithKey f z (Map m) = I.foldrWithKey f z m - -foldlWithKeyM' :: (Bounded k, Enum k, Monad m, Prim k, Prim v) - => (b -> k -> k -> v -> m b) - -> b - -> Map k v - -> m b -foldlWithKeyM' f z (Map m) = I.foldlWithKeyM' f z m - --- | The number of values in the interval map. Also the number of --- contiguous key ranges in the map. -size :: Prim v => Map k v -> Int -size (Map m) = I.size m - -elems :: Map k v -> PrimArray v -elems (Map m) = I.elems m - -toList :: (Bounded k, Enum k, Prim k, Prim v) => Map k v -> [(k,k,v)] -toList (Map m) = I.toList m - -fromLiftedLifted :: (Prim k, Prim v) => DBTSLL.Map k v -> Map k v -fromLiftedLifted (DBTSLL.Map m) = Map (I.convertKeysValues m) diff --git a/src/Data/Map/Subset/Lazy/Internal.hs b/src/Data/Map/Subset/Lazy/Internal.hs --- a/src/Data/Map/Subset/Lazy/Internal.hs +++ b/src/Data/Map/Subset/Lazy/Internal.hs @@ -23,7 +23,7 @@ import Data.Bifunctor (first) import Data.Bool (bool) import Data.Primitive (Array) -import Data.Primitive.Contiguous (Contiguous,Element) +import Data.Primitive.Contiguous (ContiguousU,Element) import Data.Semigroup (Semigroup,(<>),First(..)) import Data.Set.Internal (Set(..)) @@ -61,12 +61,12 @@ showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (P.map (first SL.Set) (toList xs)) -toList :: (Contiguous arr, Element arr k) +toList :: (ContiguousU arr, Element arr k) => Map k v -> [(Set arr k,v)] toList = foldrWithKey (\k v xs -> (k,v) : xs) [] -fromList :: (Contiguous arr, Element arr k, Ord k) +fromList :: (ContiguousU arr, Element arr k, Ord k) => [(Set arr k,v)] -> Map k v fromList = fmap getFirst . concat . P.map (\(s,v) -> singleton s (First v)) @@ -76,7 +76,7 @@ -> Map k v concat = F.foldl' (\r x -> append r x) empty -foldrWithKey :: (Contiguous arr, Element arr k) +foldrWithKey :: (ContiguousU arr, Element arr k) => (Set arr k -> v -> b -> b) -> b -> Map k v @@ -90,27 +90,27 @@ empty :: Map k v empty = MapEmpty -singleton :: (Contiguous arr, Element arr k) +singleton :: (ContiguousU arr, Element arr k) => Set arr k -> v -> Map k v singleton s v = S.foldr (\k m -> MapElement k m empty) (MapValue v) s -antisingleton :: (Contiguous arr, Element arr k) +antisingleton :: (ContiguousU arr, Element arr k) => Set arr k -> v -> Map k v antisingleton s v = S.foldr (\k m -> MapElement k empty m) (MapValue v) s -fromPolarities :: (Contiguous karr, Element karr k) +fromPolarities :: (ContiguousU karr, Element karr k) => M.Map karr Array k Bool -> v -> Map k v fromPolarities s v = M.foldrWithKey (\k p m -> MapElement k (bool empty m p) (bool m empty p)) (MapValue v) s - -lookup :: forall arr k v. (Ord k, Contiguous arr, Element arr k) + +lookup :: forall arr k v. (Ord k, ContiguousU arr, Element arr k) => Set arr k -> Map k v -> Maybe v diff --git a/src/Data/Set/Internal.hs b/src/Data/Set/Internal.hs --- a/src/Data/Set/Internal.hs +++ b/src/Data/Set/Internal.hs @@ -50,14 +50,14 @@ import Control.Monad.ST (ST,runST) import Data.Hashable (Hashable) -import Data.Primitive.Contiguous (Contiguous,Mutable,Element) +import Data.Primitive.Contiguous (ContiguousU,Contiguous,Mutable,Element) import qualified Prelude as P import qualified Data.Primitive.Contiguous as A import qualified Data.Concatenation as C newtype Set arr a = Set (arr a) -append :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a +append :: (ContiguousU arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a append (Set x) (Set y) = Set (unionArr x y) null :: Contiguous arr => Set arr a -> Bool @@ -76,7 +76,7 @@ map :: (Contiguous arr, Element arr a, Element arr b) => (a -> b) -> Set arr a -> Set arr b map f (Set x) = Set (A.map f x) -fromListN :: (Contiguous arr, Element arr a, Ord a) => Int -> [a] -> Set arr a +fromListN :: (ContiguousU arr, Element arr a, Ord a) => Int -> [a] -> Set arr a fromListN n xs = -- fromList xs case xs of [] -> empty @@ -84,7 +84,7 @@ let (leftovers, result) = fromAscList (max 1 n) y ys in concat (result : P.map singleton leftovers) -fromList :: (Contiguous arr, Element arr a, Ord a) => [a] -> Set arr a +fromList :: (ContiguousU arr, Element arr a, Ord a) => [a] -> Set arr a fromList = fromListN 1 -- This is intended to be used with things like Word8,Int8,Word16,Int16,etc. @@ -116,7 +116,7 @@ else Set A.empty -difference :: forall a arr. (Contiguous arr, Element arr a, Ord a) +difference :: forall a arr. (ContiguousU arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a @@ -139,7 +139,7 @@ else return dstIx else do let !remaining = sz1 - ix1 - A.copy dst dstIx arr1 ix1 remaining + A.copy dst dstIx (A.slice arr1 ix1 remaining) return (dstIx + remaining) dstSz <- go 0 0 0 dstFrozen <- A.resize dst dstSz >>= A.unsafeFreeze @@ -174,7 +174,7 @@ !sz2 = size s2 {-# INLINEABLE intersects #-} -intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a) +intersection :: forall a arr. (ContiguousU arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a @@ -201,7 +201,7 @@ !sz1 = size s1 !sz2 = size s2 -fromAscList :: forall arr a. (Contiguous arr, Element arr a, Ord a) +fromAscList :: forall arr a. (ContiguousU arr, Element arr a, Ord a) => Int -- initial size of buffer, must be 1 or higher -> a -- first element -> [a] -- elements @@ -272,13 +272,14 @@ GT -> go (mid + 1) end {-# INLINEABLE lookupIndex #-} -concat :: forall arr a. (Contiguous arr, Element arr a, Ord a) => [Set arr a] -> Set arr a +concat :: forall arr a. (ContiguousU arr, Element arr a, Ord a) => [Set arr a] -> Set arr a concat = C.concatSized size empty append compareArr :: (Contiguous arr, Element arr a, Ord a) => arr a -> arr a -> Ordering +{-# INLINEABLE compareArr #-} compareArr arrA arrB = go 0 where go :: Int -> Ordering go !ix = if ix < A.size arrA @@ -290,15 +291,18 @@ else EQ singleton :: (Contiguous arr, Element arr a) => a -> Set arr a +{-# INLINEABLE singleton #-} singleton a = Set (A.singleton a) doubleton :: (Contiguous arr, Element arr a, Ord a) => a -> a -> Set arr a +{-# INLINEABLE doubleton #-} doubleton a b = case P.compare a b of LT -> Set (A.doubleton a b) GT -> Set (A.doubleton b a) EQ -> Set (A.singleton a) tripleton :: (Contiguous arr, Element arr a, Ord a) => a -> a -> a -> Set arr a +{-# INLINEABLE tripleton #-} tripleton a b c = case P.compare a b of LT -> case P.compare b c of LT -> Set (A.tripleton a b c) @@ -322,10 +326,11 @@ -- the other array instead of reconstructing it. -- * All elements in one array are smaller than all elements in the -- other. In this case, we can append the arrays, which uses memcpy. -unionArr :: forall arr a. (Contiguous arr, Element arr a, Ord a) +unionArr :: forall arr a. (ContiguousU arr, Element arr a, Ord a) => arr a -- array x -> arr a -- array y -> arr a +{-# INLINEABLE unionArr #-} unionArr arrA arrB | szA < 1 = arrB | szB < 1 = arrA @@ -348,11 +353,11 @@ A.write arrDst ixDst b go ixA (ixB + 1) (ixDst + 1) else do - A.copy arrDst ixDst arrA ixA (szA - ixA) + A.copy arrDst ixDst (A.slice arrA ixA (szA - ixA)) return (ixDst + (szA - ixA)) else if ixB < szB then do - A.copy arrDst ixDst arrB ixB (szB - ixB) + A.copy arrDst ixDst (A.slice arrB ixB (szB - ixB)) return (ixDst + (szB - ixB)) else return ixDst total <- go 0 0 0 @@ -441,6 +446,7 @@ => Set arr a -> Set arr a -> Bool +{-# INLINEABLE subset #-} subset (Set arrA) (Set arrB) = go 0 0 where !szA = A.size arrA diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -21,23 +21,15 @@ import Data.Word import Data.Int -import Control.Applicative (liftA2) -import Control.Monad (forM) -import Data.Bool (bool) import Data.Continuous.Set.Lifted (Inclusivity(..)) import Data.Functor.Const (Const(..)) -import Data.Kind (Type) -import Data.List.NonEmpty (NonEmpty((:|))) import Data.Primitive.Unlifted.Class (PrimUnlifted) import Data.Proxy (Proxy(..)) -import Data.Semigroup (Semigroup) import Test.HUnit.Base (assertEqual) -import Test.QuickCheck (Arbitrary,Gen,(===),(==>)) +import Test.QuickCheck (Arbitrary,(===)) import Test.Tasty (defaultMain,testGroup,TestTree) import Test.Tasty.HUnit (testCase,(@?=)) -import Text.Read (readMaybe) -import Unsafe.Coerce (unsafeCoerce) -import qualified Data.Text as T + import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Classes as QCC @@ -54,13 +46,8 @@ import qualified Data.Map.Lifted.Lifted as MLL import qualified Data.Map.Unboxed.Lifted as MUL import qualified Data.Map.Unboxed.Unboxed as MUU -import qualified Data.Diet.Map.Strict.Unboxed.Lifted as DMUL -import qualified Data.Diet.Map.Strict.Lifted.Lifted as DMLL -import qualified Data.Diet.Set.Lifted as DSL import qualified Data.Continuous.Set.Lifted as CSL -import qualified Data.Diet.Unbounded.Set.Lifted as DUSL import qualified Data.Map.Subset.Strict.Lifted as MSL -import qualified Data.Map.Interval.DBTSLL as MIDBTS main :: IO () main = defaultMain $ testGroup "Data" @@ -140,34 +127,6 @@ , TQC.testProperty "appendWithKey" appendWithKeyLiftedLiftedProp ] ] - , testGroup "Interval" - [ testGroup "DBTS" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer))) - , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer)))) - , lawsToTest (QCC.commutativeSemigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer)))) - , lawsToTest (QCC.idempotentSemigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer)))) - , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer))) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer))) - , TQC.testProperty "lookup" dbtsIntervalMapLookupProp - , testGroup "Unit" - [ testCase "A" $ do - let s = MIDBTS.singleton 102 (1 :: Word8) (2 :: Word8) (101 :: Integer) - show s @?= "fromList [(0,0,102),(1,2,101),(3,255,102)]" - , testCase "B" $ do - let s = MIDBTS.singleton 102 (2 :: Word8) (2 :: Word8) (101 :: Integer) - show s @?= "fromList [(0,1,102),(2,2,101),(3,255,102)]" - , testCase "C" $ do - let s = MIDBTS.singleton 102 (0 :: Word8) (0 :: Word8) (101 :: Integer) - show s @?= "fromList [(0,0,101),(1,255,102)]" - , testCase "D" $ do - let s = MIDBTS.fromList 102 [(1 :: Word8, 2 :: Word8, 100 :: Integer),(5,7,101)] - show s @?= "fromList [(0,0,102),(1,2,100),(3,4,102),(5,7,101),(8,255,102)]" - , testCase "E" $ do - let s = MIDBTS.fromList 102 [(5,7,101),(1 :: Word8, 2 :: Word8, 100 :: Integer)] - show s @?= "fromList [(0,0,102),(1,2,100),(3,4,102),(5,7,101),(8,255,102)]" - ] - ] - ] ] , testGroup "Continuous" [ testGroup "Set" @@ -198,88 +157,6 @@ ] ] ] - , testGroup "Diet" - [ testGroup "Unbounded" - [ testGroup "Set" - [ testGroup "Lifted" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DUSL.Set Word8))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DUSL.Set Word8))) - , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DUSL.Set Word8))) - ] - ] - ] - , testGroup "Set" - [ testGroup "Lifted" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DSL.Set Word16))) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DSL.Set Word16))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DSL.Set Word16))) - , 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 - , 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 - ] - -- 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" - [ testGroup "Subset" - [ testGroup "Lifted" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer)))) - , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MSL.Map Integer (SG.First Integer)))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer)))) - , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer)))) - , TQC.testProperty "lookup" subsetMapLookupProp - ] - ] - , testGroup "Lifted" - [ testGroup "Lifted" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMLL.Map Word8 Integer))) - , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMLL.Map Word8 Word))) - , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMLL.Map Word8 Int))) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMLL.Map Word8 Integer))) - , TQC.testProperty "lookup" (dietLookupPropA @Word8 @Int E.fromList DMLL.lookup) - , TQC.testProperty "doubleton" dietDoubletonProp - , TQC.testProperty "valid" dietValidProp - ] - ] - , testGroup "Unboxed" - [ testGroup "Lifted" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMUL.Map Word8 Integer))) - , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMUL.Map Word8 Word))) - , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMUL.Map Word8 Int))) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMUL.Map Word8 Integer))) - , TQC.testProperty "lookup" (dietLookupPropA @Word32 @Int E.fromList DMUL.lookup) - ] - ] - ] - ] ] int16 :: Proxy Int16 @@ -288,186 +165,6 @@ int32 :: Proxy Int32 int32 = Proxy -subsetMapLookupProp :: QC.Property -subsetMapLookupProp = QC.property $ \(xs :: MSL.Map Integer Integer) -> - let xs' = MSL.toList xs - in all (\(k,v) -> MSL.lookup k xs == Just v) xs' === True - -dietSetDifferenceProp :: QC.Property -dietSetDifferenceProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set 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'))) - -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 - (_,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)) - -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 - (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)) - -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 -> - 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 -> - 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 - 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)) - -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 - 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)) - ) - ) - -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 -dietSetToSet = DSL.foldr - (\lo hi s -> S.fromList (enumFromTo lo hi) SG.<> s) - mempty - differenceProp :: QC.Property differenceProp = QC.property $ \(xs :: S.Set Word8) (ys :: S.Set Word8) -> let xs' = SL.fromList (S.toList xs) @@ -578,33 +275,6 @@ lookupEmptyUnboxedLiftedMapProp = QC.property $ \(x :: Word16) -> MUL.lookup x (MUL.empty :: MUL.Map Word16 Integer) === Nothing -dietMemberProp :: forall a t. (Arbitrary a, Show a, Ord a, Arbitrary a, Show (t a)) => ([(a,a)] -> t a) -> (a -> t a -> Bool) -> QC.Property -dietMemberProp containerFromList containerLookup = QC.property $ \(xs :: [a]) -> - let c = containerFromList (map (\a -> (a,a)) xs) - in QC.counterexample ("original list: " ++ show xs ++ "; diet set: " ++ show c) (all (\x -> containerLookup x c == True) xs === True) - -dietLookupPropA :: forall k v t. (Arbitrary k, Show k, Ord k, Arbitrary v, Show v, Eq v, Show (t k v)) => ([(k,k,v)] -> t k v) -> (k -> t k v -> Maybe v) -> QC.Property -dietLookupPropA containerFromList containerLookup = QC.property $ \(xs :: [(k,v)]) -> - let ys = M.fromList xs - c = containerFromList (map (\(k,v) -> (k,k,v)) xs) - in QC.counterexample ("original list: " ++ show xs ++ "; diet map: " ++ show c) (all (\(x,_) -> containerLookup x c == M.lookup x ys) xs === True) - -dbtsIntervalMapLookupProp :: QC.Property -dbtsIntervalMapLookupProp = QC.property $ \(xs :: [(Word8,Word8,Integer)]) (k :: Word8) -> - let ys = MIDBTS.fromList Nothing (fmap (\(lo,hi,r) -> (lo,hi,Just r)) xs) - expected = fmap (\(_,_,r) -> r) (F.find (\(lo,hi,_) -> lo <= k && k <= hi) xs) - in expected === MIDBTS.lookup k ys - -dietDoubletonProp :: QC.Property -dietDoubletonProp = QC.property $ \(loA :: Word8) (hiA :: Word8) (valA :: Int) (loB :: Word8) (hiB :: Word8) (valB :: Int) -> - (hiA >= loA && hiB >= loB) - ==> - (simpleDoubletonToList loA hiA valA loB hiB valB === E.toList (DMLL.singleton loA hiA valA SG.<> DMLL.singleton loB hiB valB)) - -dietValidProp :: QC.Property -dietValidProp = QC.property $ \(xs :: DMLL.Map Word8 Int) -> - True === validDietTriples (E.toList xs) - intersectsSet :: Ord a => S.Set a -> S.Set a -> Bool intersectsSet s1 s2 = let s3 = s1 <> s2 @@ -616,53 +286,6 @@ intersectsWorksProp = QC.property $ \(xs :: S.Set Int) (ys :: S.Set Int) -> intersectsSet xs ys == SU.intersects (SU.fromList (S.toList xs)) (SU.fromList (S.toList ys)) -simpleDoubletonToList :: (Ord k, Enum k, Semigroup v, Eq v) => k -> k -> v -> k -> k -> v -> [(k,k,v)] -simpleDoubletonToList key1A key2A valA key1B key2B valB = - let loA = min key1A key2A - hiA = max key1A key2A - loB = min key1B key2B - hiB = max key1B key2B - in deduplicate $ case compare loA loB of - LT -> case compare hiA loB of - LT -> [(loA,hiA,valA),(loB,hiB,valB)] - EQ -> case compare hiA hiB of - LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)] - EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)] - GT -> error "simpleDoubletonToList: invariant violated" - GT -> case compare hiA hiB of - LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)] - EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)] - GT -> [(loA,pred loB,valA),(loB,hiB,valA SG.<> valB),(succ hiB,hiA,valA)] - EQ -> case compare hiA hiB of - LT -> [(loA,hiA,valA SG.<> valB),(succ hiA, hiB, valB)] - GT -> [(loB,hiB,valA SG.<> valB),(succ hiB, hiA, valA)] - EQ -> [(loA,hiA,valA SG.<> valB)] - GT -> case compare hiB loA of - LT -> [(loB,hiB,valB),(loA,hiA,valA)] - EQ -> case compare hiB hiA of - LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)] - EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)] - GT -> error "simpleDoubletonToList: invariant violated" - GT -> case compare hiB hiA of - LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)] - EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)] - GT -> [(loB,pred loA,valB),(loA,hiA,valA SG.<> valB),(succ hiA,hiB,valB)] - -validDietTriples :: (Enum k,Eq k,Eq v) => [(k,k,v)] -> Bool -validDietTriples xs = deduplicate xs == xs - -deduplicate :: (Enum k,Eq k, Eq v) => [(k,k,v)] -> [(k,k,v)] -deduplicate [] = [] -deduplicate (x : xs) = F.toList (deduplicateNonEmpty (x :| xs)) - -deduplicateNonEmpty :: (Enum k, Eq k, Eq v) => NonEmpty (k,k,v) -> NonEmpty (k,k,v) -deduplicateNonEmpty ((lo,hi,v) :| xs) = case xs of - y : ys -> case deduplicateNonEmpty (y :| ys) of - (lo',hi',v') :| xs' -> if v == v' && pred lo' == hi - then (lo,hi',v) :| xs' - else (lo,hi,v) :| ((lo',hi',v') : xs') - [] -> (lo,hi,v) :| [] - lawsToTest :: QCC.Laws -> TestTree lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) @@ -687,13 +310,6 @@ instance (Arbitrary k, Ord k, Arbitrary v) => Arbitrary (MLL.Map k v) where arbitrary = fmap E.fromList QC.arbitrary -instance (Arbitrary k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMLL.Map k v) where - arbitrary = DMLL.fromListAppend <$> QC.vectorOf 10 arbitraryOrderedPairValue - shrink x = map E.fromList (QC.shrink (E.toList x)) - -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) @@ -707,85 +323,6 @@ [ MSL.fromList (drop 1 y) ] where y = MSL.toList x - -instance (Arbitrary k, Prim k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMUL.Map k v) where - arbitrary = do - sz <- QC.choose (0,10) - k <- QC.arbitrary - xs <- increasingOrderedPairsHelper sz k - ys <- forM xs $ \(lo,hi) -> do - v <- QC.arbitrary - 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)) - -instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DUSL.Set a) where - arbitrary = do - 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 - Nothing -> return [] - Just vals -> do - lo <- QC.elements vals - hi <- QC.elements (equalToOrGreaterThan lo) - xs <- increasingOrderedPairsHelper (n - 1) hi - return ((lo,hi) : xs) - else return [] - -equalToOrGreaterThan :: (Ord a, Bounded a, Enum a) => a -> [a] -equalToOrGreaterThan a0 = - let a1 = if a0 < maxBound then succ a0 else a0 - a2 = if a1 < maxBound then succ a1 else a1 - a3 = if a2 < maxBound then succ a2 else a2 - in [a0,a1,a2,a3] - -atLeastTwoGreaterThan :: (Enum a, Bounded a, Ord a) => a -> Maybe [a] -atLeastTwoGreaterThan a0 = do - if a0 < maxBound - then - let a1 = succ a0 - in if a1 < maxBound - then - let a2 = succ a1 - a3 = if a2 < maxBound then succ a2 else a2 - a4 = if a3 < maxBound then succ a3 else a3 - in Just [a2,a3,a4] - else Nothing - else Nothing - -arbitraryOrderedPair :: (Ord k, Enum k, Bounded k, Arbitrary k) => Gen (k,k) -arbitraryOrderedPair = do - a0 <- QC.arbitrary - let a1 = if a0 < maxBound then succ a0 else a0 - a2 = if a1 < maxBound then succ a1 else a1 - a3 = if a2 < maxBound then succ a2 else a2 - a' <- QC.elements [a0,a1,a2,a3] - return (a0,a') - -arbitraryOrderedPairValue :: (Ord k, Enum k, Bounded k, Arbitrary k, Arbitrary v) => Gen (k,k,v) -arbitraryOrderedPairValue = do - (lo,hi) <- arbitraryOrderedPair - v <- QC.arbitrary - return (lo,hi,v) instance SG.Semigroup Word where w <> _ = w