primitive-containers 0.4.1 → 0.5.0
raw patch · 20 files changed
+135/−2995 lines, 20 filesdep ~contiguousdep ~primitive-sort
Dependency ranges changed: contiguous, primitive-sort
Files
- primitive-containers.cabal +4/−16
- src/Data/Continuous/Set/Internal.hs +10/−10
- src/Data/Diet/Map/Strict/Internal.hs +26/−51
- src/Data/Diet/Map/Strict/Lifted/Lifted.hs +0/−77
- src/Data/Diet/Map/Strict/Unboxed/Lifted.hs +0/−10
- src/Data/Diet/Set.hs +0/−27
- src/Data/Diet/Set/Internal.hs +0/−638
- src/Data/Diet/Set/Lifted.hs +0/−134
- src/Data/Diet/Set/Unboxed.hs +0/−139
- src/Data/Diet/Unbounded/Set/Internal.hs +0/−254
- src/Data/Diet/Unbounded/Set/Lifted.hs +0/−46
- src/Data/Map/Internal.hs +66/−71
- src/Data/Map/Interval.hs +0/−64
- src/Data/Map/Interval/DBTS/Internal.hs +0/−453
- src/Data/Map/Interval/DBTSLL.hs +0/−173
- src/Data/Map/Interval/DBTSUL.hs +0/−173
- src/Data/Map/Interval/DBTSUU.hs +0/−173
- src/Data/Map/Subset/Lazy/Internal.hs +9/−9
- src/Data/Set/Internal.hs +18/−12
- test/Main.hs +2/−465
primitive-containers.cabal view
@@ -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
src/Data/Continuous/Set/Internal.hs view
@@ -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
src/Data/Diet/Map/Strict/Internal.hs view
@@ -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 ')'-
− src/Data/Diet/Map/Strict/Lifted/Lifted.hs
@@ -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
src/Data/Diet/Map/Strict/Unboxed/Lifted.hs view
@@ -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)
− src/Data/Diet/Set.hs
@@ -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-<http://web.engr.oregonstate.edu/~erwig/diet/ Discrete Interval Encoding Trees>-(DIETs). This implementation is discussed in-<http://web.engr.oregonstate.edu/~erwig/papers/Diet_JFP98.pdf Diets for Fat Sets>,-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
− src/Data/Diet/Set/Internal.hs
@@ -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)-
− src/Data/Diet/Set/Lifted.hs
@@ -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)-
− src/Data/Diet/Set/Unboxed.hs
@@ -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)-
− src/Data/Diet/Unbounded/Set/Internal.hs
@@ -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))-
− src/Data/Diet/Unbounded/Set/Lifted.hs
@@ -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---
src/Data/Map/Internal.hs view
@@ -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) ())
− src/Data/Map/Interval.hs
@@ -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
− src/Data/Map/Interval/DBTS/Internal.hs
@@ -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)-
− src/Data/Map/Interval/DBTSLL.hs
@@ -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
− src/Data/Map/Interval/DBTSUL.hs
@@ -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)
− src/Data/Map/Interval/DBTSUU.hs
@@ -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)
src/Data/Map/Subset/Lazy/Internal.hs view
@@ -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
src/Data/Set/Internal.hs view
@@ -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
test/Main.hs view
@@ -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