rangeset 0.0.1.0 → 0.1.0.0

raw patch · 25 files changed

+1173/−498 lines, 25 filesdep +randomdep +random-shuffledep −selectivePVP ok

version bump matches the API change (PVP)

Dependencies added: random, random-shuffle

Dependencies removed: selective

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• benchmarks/BenchmarkUtils.hs +24/−3
• benchmarks/ComplexityBench.hs +93/−0
• benchmarks/ContiguityBench.hs +216/−0
• benchmarks/Data/EnumSet.hs +356/−0
• benchmarks/Data/Patricia.hs +38/−0
• benchmarks/RangeSetBench.hs +2/−136
• rangeset.cabal +24/−13
• src/ghc-8.6+/Data/RangeSet/Internal/Types.hs +61/−0
• src/ghc-9.2+/Data/RangeSet/Internal/Types.hs +67/−0
• src/ghc/Data/RangeSet.hs +15/−15
• src/ghc/Data/RangeSet/Builders.hs +9/−2
• src/ghc/Data/RangeSet/Internal.hs +45/−47
• src/ghc/Data/RangeSet/Internal/Enum.hs +2/−2
• src/ghc/Data/RangeSet/Internal/Extractors.hs +19/−19
• src/ghc/Data/RangeSet/Internal/Heuristics.hs +4/−23
• src/ghc/Data/RangeSet/Internal/Inserters.hs +24/−24
• src/ghc/Data/RangeSet/Internal/Lumpers.hs +27/−25
• src/ghc/Data/RangeSet/Internal/SmartConstructors.hs +49/−54
• src/ghc/Data/RangeSet/Internal/Splitters.hs +28/−20
• src/ghc/Data/RangeSet/Internal/TestingUtils.hs +4/−9
• src/ghc/Data/RangeSet/Internal/Types.hs +0/−67
• src/ghc/Data/RangeSet/Internal/Unsafe.hs +9/−0
• src/ghc/Data/RangeSet/Primitives.hs +1/−1
• src/ghc/Data/RangeSet/SetCrossSet.hs +50/−37

@@ -1,5 +1,10 @@ # Revision history for `rangeset` -## 0.0.1.0 -- 2022-06-22+## 0.0.1.0 -- 2022-08-03  * First version. Released on an unsuspecting world.++## 0.1.0.0 -- 2023-04-14++* Removed constant time size operation for performance, now O(n)+* Removed some unneeded constraints on some function signatures

@@ -1,7 +1,28 @@+{-# LANGUAGE StandaloneDeriving, DeriveAnyClass, DeriveGeneric, BangPatterns #-} module BenchmarkUtils where  import Gauge.Main         (Benchmark, defaultMainWith)-import Gauge.Main.Options (Config(displayMode), defaultConfig, DisplayMode(Condensed))+import Gauge.Main.Options (Config(..), defaultConfig, DisplayMode(Condensed), Verbosity(..)) -condensedMain :: [Benchmark] -> IO ()-condensedMain = defaultMainWith (defaultConfig {displayMode = Condensed})+import GHC.Generics (Generic)++import Data.RangeSet.Internal (RangeSet(..))+import Control.DeepSeq++condensedMain :: Maybe FilePath -> [Benchmark] -> IO ()+condensedMain csv = defaultMainWith $ defaultConfig { displayMode = Condensed+                                                    , timeLimit = Just 60+                                                    , includeFirstIter = False+                                                    , csvFile = csv+                                                    --, iters = Just 100+                                                    }++nfList :: [a] -> [a]+nfList xs = go xs xs+  where+    go [] xs = xs+    go ((!x) : (!xs)) orig = go xs orig++instance NFData (RangeSet a) where+    rnf Tip           = ()+    rnf (Fork _ l u lt rt) = rnf l `seq` rnf u `seq` rnf lt `seq` rnf rt

@@ -0,0 +1,93 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, BlockArguments, AllowAmbiguousTypes #-}+module Main where++import Gauge+import BenchmarkUtils++import Data.RangeSet (RangeSet)++import Control.Monad+import Control.DeepSeq+import System.Random.Shuffle++import GHC.Generics (Generic)++import qualified Data.RangeSet as RangeSet+import qualified Data.RangeSet.Internal as RangeSet++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Array++import Data.List (foldl', transpose)++xs, ys, zs :: [Int]+xs = [0, 2..99999]+ys = [0, 4..19999]+zs = [2, 6..19999]++chunks :: Int -> [a] -> [[a]]+chunks n xs = reverse (take n (iterate (drop (m `div` n)) xs))+  where m = length xs++main :: IO ()+main = do+  condensedMain (Just "complexity.csv") [+      bgroup "disjoint" [ unionB id ys zs+                        , intersectB id ys zs+                        , differenceB id ys zs+                        ],+      bgroup "overlap"  [ unionB id ys ys+                        , intersectB id ys ys+                        , differenceB id ys ys+                        ]+    ]++{-insertB :: [[Int]] -> Benchmark+insertB xss =+  env (return dat) $ \edat -> bgroup "RangeSet.insert" (map (fbench edat) is)+  where+    !dat = listArray (0, n-1) (map (map prepare) (chunks n xss))+    !is = force (indices dat)+    n = 10+    !sz = length (head xss) `div` n++    fbench dat i = bench (show $ (i + 1) * sz) (whnf insertF (dat ! i))++    prepare (x:xs) = (x, RangeSet.fromList xs)++    insertF = nfList . map (uncurry RangeSet.insert)+    nothingF = snd-}++unionB :: ([Int] -> [Int]) -> [Int] -> [Int] -> Benchmark+unionB = mkBench "RangeSet.union" RangeSet.union++intersectB :: ([Int] -> [Int]) -> [Int] -> [Int] -> Benchmark+intersectB = mkBench "RangeSet.intersection" RangeSet.intersection++differenceB :: ([Int] -> [Int]) -> [Int] -> [Int] -> Benchmark+differenceB = mkBench "RangeSet.difference" RangeSet.difference++{-# INLINE mkBench #-}+mkBench :: String -> (RangeSet Int -> RangeSet Int -> RangeSet Int) -> ([Int] -> [Int]) -> [Int] -> [Int] -> Benchmark+mkBench name f adjust xs ys =+  env dat $ \edat -> bgroup name (map (fbench edat) is)+  where+    !n = 10++    dat :: IO (Array (Int, Int) (RangeSet Int, RangeSet Int))+    dat = do+      xss <- traverse shuffleM (chunks n xs)+      yss <- traverse shuffleM (chunks n ys)+      return $ array rng+        [ ((i, j), (RangeSet.fromList xs, RangeSet.fromList (adjust ys)))+        | (i, xs) <- zip [1..n] xss+        , (j, ys) <- zip [1..n] yss+        ]++    !rng = ((1, 1), (n, n))+    !is = force (range rng)+    !sz = length xs `div` n++    fbench dat ij@(i, j) = bench (show (i * sz, j * sz)) (whnf (uncurry f) (dat ! ij))

@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns, TypeApplications, ScopedTypeVariables, BlockArguments, AllowAmbiguousTypes  #-}+module Main where++import Gauge+import BenchmarkUtils++import Data.RangeSet (RangeSet)+import Data.EnumSet (EnumSet)+import Data.Set (Set)+import Data.Patricia (Patricia)+import qualified Data.RangeSet as RangeSet+import qualified Data.EnumSet as EnumSet+import qualified Data.Patricia as Patricia+import qualified Data.Set as Set++import Control.Monad+import Control.DeepSeq+import Data.List+import System.Random.Shuffle+import System.Random.Stateful++import qualified Data.List as List+import GHC.Real (Fractional, (%))+import Data.Ratio (denominator, numerator)++main :: IO ()+main = do+  --(ratios, bins) <- unzip <$> fillBins @Word+  (ratios, bins) <- unzip <$> fillBins' @Word+  condensedMain (Just "contiguity.csv") [+      contiguityBench ratios bins+    ]++-- This benchmark generates bunches of random data with a contiguity measure of 0.0 to 1.0+-- this is defined as $1 - m/n$ where $n$ is the number of elements in the set and $m$ the number+-- of ranges. For each of these random sets, each element is queried in turn, and the average+-- time is taken. This comparison is done between the rangeset and the data.set++contiguity :: RangeSet a -> Rational+contiguity s = 1 - fromIntegral (RangeSet.sizeRanges s) % fromIntegral (RangeSet.size s)++numContBins :: Int+numContBins = 20++binSize :: Int+binSize = 100 --for full bench++approxSetSize :: Int+approxSetSize = 1000++fillBins' :: forall a. (Ord a, Enum a, Bounded a, Num a, UniformRange a) => IO [(Rational, [(RangeSet a, Set a, EnumSet a, Patricia a, [a], [a])])]+fillBins' =+  do let granulation = 1 % fromIntegral numContBins+     let toRatio = (* granulation) . fromIntegral+     let cs = map toRatio [0..numContBins-1]++     forM cs $ \c -> do+        let xs = buildWithContiguity approxSetSize c+        xss <- (xs :) <$> replicateM (binSize-1) do+          xs' <- shuffleM xs+          -- allow the elements to shift so they may overlap partially, or even not at all with those in the original+          -- this is important for good distribution when testing union, intersection, difference but should be+          -- invariant for the other benchmarks+          shift <- uniformRM (0, fromIntegral approxSetSize) globalStdGen :: IO a+          return (map (+ shift) xs')+        return (c, map (\xs -> (RangeSet.fromList xs, Set.fromList xs, EnumSet.fromList xs, Patricia.fromList xs, xs, sort xs)) xss)++buildWithContiguity :: forall a. (Bounded a, Enum a) => Int -> Rational -> [a]+buildWithContiguity atLeast c = go [minBound @a .. maxBound @a] ranges+  where+    go xs []     = []+    go xs (n:ns) = let (r, xs') = splitAt n xs in r ++ go (tail xs') ns++    ranges = replicate numBig bigSize ++ replicate numSmall smallSize++    w = 1 / (1 - c)+    numElems = fromInteger $ numerator w+    numRangesUnscaled = fromInteger $ denominator w+    (smallSize, numBigUnscaled) = quotRem numElems numRangesUnscaled+    numSmallUnscaled = numRangesUnscaled - numBigUnscaled++    (q, r) = quotRem atLeast (smallSize * numSmallUnscaled + bigSize * numBigUnscaled)+    scale = q + (if r == 0 then 0 else 1)+    numBig = numBigUnscaled * scale+    numSmall = numSmallUnscaled * scale+    bigSize = smallSize + 1++contiguityBench :: forall a. (NFData a, Ord a, Enum a) => [Rational] -> [[(RangeSet a, Set a, EnumSet a, Patricia a, [a], [a])]] -> Benchmark+contiguityBench ratios bins = {-es `deepseq`-} env (return (map unzip6 bins)) $ \dat ->+    bgroup "contiguity" (concatMap (mkBench dat) (zip ratios [0..]))++  where+    --es = elems @a+    mkBench dat (ratio, i) = let ~(rs, ss, es, ps, xss, sxss) = dat !! i in [+        bench ("overhead from (" ++ show ratio ++ ")") $ whnf overheadFromList sxss,+        bench ("rangeset-from (" ++ show ratio ++ ")") $ whnf rangeSetFromList sxss,+        bench ("set-from (" ++ show ratio ++ ")") $ whnf setFromList sxss,+        bench ("set-opt-from (" ++ show ratio ++ ")") $ whnf enumSetFromList sxss,+        bench ("patricia-from (" ++ show ratio ++ ")") $ whnf patriciaFromList sxss,+        --bench ("overhead rangeset-all (" ++ show ratio ++ ")") $ whnf (overheadRangeSetAllMember es) rs,+        --bench ("overhead set-all (" ++ show ratio ++ ")") $ whnf (overheadSetAllMember es) ss,+        --bench ("rangeset-all (" ++ show ratio ++ ")") $ whnf (rangeSetAllMember es) rs,+        --bench ("set-all (" ++ show ratio ++ ")") $ whnf (setAllMember es) ss,+        bench ("overhead union (" ++ show ratio ++ ")") $ whnf overheadSetCrossSet rs,+        bench ("rangeset-union (" ++ show ratio ++ ")") $ whnf rangeSetUnion rs,+        bench ("set-union (" ++ show ratio ++ ")") $ whnf setUnion ss,+        bench ("set-opt-union (" ++ show ratio ++ ")") $ whnf enumSetUnion es,+        bench ("patricia-union (" ++ show ratio ++ ")") $ whnf patriciaUnion ps,+        bench ("overhead intersection (" ++ show ratio ++ ")") $ whnf overheadSetCrossSet rs,+        bench ("rangeset-intersection (" ++ show ratio ++ ")") $ whnf rangeSetIntersection rs,+        bench ("set-intersection (" ++ show ratio ++ ")") $ whnf setIntersection ss,+        bench ("set-opt-intersection (" ++ show ratio ++ ")") $ whnf enumSetIntersection es,+        bench ("patricia-intersection (" ++ show ratio ++ ")") $ whnf patriciaIntersection ps,+        bench ("overhead difference (" ++ show ratio ++ ")") $ whnf overheadSetCrossSet rs,+        bench ("rangeset-difference (" ++ show ratio ++ ")") $ whnf rangeSetDifference rs,+        bench ("set-difference (" ++ show ratio ++ ")") $ whnf setDifference ss,+        bench ("set-opt-difference (" ++ show ratio ++ ")") $ whnf enumSetDifference es,+        bench ("patricia-difference (" ++ show ratio ++ ")") $ whnf patriciaDifference ps,+        bench ("overhead mem (" ++ show ratio ++ ")") $ whnf (uncurry overheadMember) (xss, rs),+        bench ("rangeset-mem (" ++ show ratio ++ ")") $ whnf (uncurry rangeSetMember) (xss, rs),+        bench ("set-mem (" ++ show ratio ++ ")") $ whnf (uncurry setMember) (xss, ss),+        bench ("set-opt-mem (" ++ show ratio ++ ")") $ whnf (uncurry enumSetMember) (xss, es),+        bench ("patricia-mem (" ++ show ratio ++ ")") $ whnf (uncurry patriciaMember) (xss, ps),+        bench ("overhead ins (" ++ show ratio ++ ")") $ whnf overheadInsert xss,+        bench ("rangeset-ins (" ++ show ratio ++ ")") $ whnf rangeSetInsert xss,+        bench ("set-ins (" ++ show ratio ++ ")") $ whnf setInsert xss,+        bench ("set-opt-ins (" ++ show ratio ++ ")") $ whnf enumSetInsert xss,+        bench ("patricia-ins (" ++ show ratio ++ ")") $ whnf patriciaInsert xss,+        bench ("rangeset-ins-sorted (" ++ show ratio ++ ")") $ whnf rangeSetInsert sxss,+        bench ("set-ins-sorted (" ++ show ratio ++ ")") $ whnf setInsert sxss,+        bench ("set-opt-ins-sorted (" ++ show ratio ++ ")") $ whnf enumSetInsert sxss,+        bench ("patricia-ins-sorted (" ++ show ratio ++ ")") $ whnf patriciaInsert sxss,+        bench ("overhead del (" ++ show ratio ++ ")") $ whnf (uncurry overheadDelete) (xss, rs),+        bench ("rangeset-del (" ++ show ratio ++ ")") $ whnf (uncurry rangeSetDelete) (xss, rs),+        bench ("set-del (" ++ show ratio ++ ")") $ whnf (uncurry setDelete) (xss, ss),+        bench ("set-opt-del (" ++ show ratio ++ ")") $ whnf (uncurry enumSetDelete) (xss, es),+        bench ("patricia-del (" ++ show ratio ++ ")") $ whnf (uncurry patriciaDelete) (xss, ps),+        bench ("rangeset-del-sorted (" ++ show ratio ++ ")") $ whnf (uncurry rangeSetDelete) (sxss, rs),+        bench ("set-del-sorted (" ++ show ratio ++ ")") $ whnf (uncurry setDelete) (sxss, ss),+        bench ("set-opt-del-sorted (" ++ show ratio ++ ")") $ whnf (uncurry enumSetDelete) (sxss, es),+        bench ("patricia-del-sorted (" ++ show ratio ++ ")") $ whnf (uncurry patriciaDelete) (sxss, ps)+      ]++    overheadMember xss ys = nfList [False | (y, xs) <- zip ys xss, x <- xs]+    rangeSetMember xss rs = nfList [RangeSet.member x r | (r, xs) <- zip rs xss, x <- xs]+    setMember xss ss = nfList [Set.member x s | (s, xs) <- zip ss xss, x <- xs]+    patriciaMember xss ss = nfList [Patricia.member x s | (s, xs) <- zip ss xss, x <- xs]+    enumSetMember xss ss = nfList [EnumSet.member x s | (s, xs) <- zip ss xss, x <- xs]++    overheadInsert = nfList . map (foldr @[] @a (const id) ())+    rangeSetInsert = nfList . map (foldr @[] @a RangeSet.insert RangeSet.empty)+    setInsert = nfList . map (foldr @[] @a Set.insert Set.empty)+    patriciaInsert = nfList . map (foldr @[] @a Patricia.insert Patricia.empty)+    enumSetInsert = nfList . map (foldr @[] @a EnumSet.insert EnumSet.empty)++    overheadDelete xss ys = nfList $ zipWith (foldr (const id)) ys xss+    rangeSetDelete xss rs = nfList $ zipWith (foldr RangeSet.delete) rs xss+    setDelete xss ss = nfList $ zipWith (foldr Set.delete) ss xss+    patriciaDelete xss rs = nfList $ zipWith (foldr Patricia.delete) rs xss+    enumSetDelete xss ss = nfList $ zipWith (foldr EnumSet.delete) ss xss++    overheadSetCrossSet xs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ const <$> xs' <*> xs'++    rangeSetUnion rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ RangeSet.union <$> rs' <*> rs'+    setUnion ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ Set.union <$> ss' <*> ss'+    patriciaUnion rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ Patricia.union <$> rs' <*> rs'+    enumSetUnion ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ EnumSet.union <$> ss' <*> ss'++    rangeSetIntersection rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ RangeSet.intersection <$> rs' <*> rs'+    setIntersection ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ Set.intersection <$> ss' <*> ss'+    patriciaIntersection rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ Patricia.intersection <$> rs' <*> rs'+    enumSetIntersection ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ EnumSet.intersection <$> ss' <*> ss'++    rangeSetDifference rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ RangeSet.difference <$> rs' <*> rs'+    setDifference ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ Set.difference <$> ss' <*> ss'+    patriciaDifference rs' = {-let rs' = take (binSize `div` 2) rs in -}nfList $ Patricia.difference <$> rs' <*> rs'+    enumSetDifference ss' = {-let ss' = take (binSize `div` 2) ss in -}nfList $ EnumSet.difference <$> ss' <*> ss'++    overheadFromList = nfList . map (const ())+    rangeSetFromList = nfList . map RangeSet.fromList+    setFromList = nfList . map Set.fromList+    patriciaFromList = nfList . map Patricia.fromList+    enumSetFromList = nfList . map EnumSet.fromList++{-+maxElem :: Enum a => a+maxElem = toEnum (approxSetSize - 1)++minElem :: Enum a => a+minElem = toEnum 0++elems :: forall a. Enum a => [a]+elems = [minElem @a .. maxElem @a]++fillBins :: forall a. (Ord a, Enum a) => IO [(Rational, [(RangeSet a, Set a, [a], [a])])]+fillBins = do+  bins <- newArray (0, numContBins-1) [] :: IO (IOArray Int [(RangeSet a, [a])])+  let granulation = 1 % fromIntegral numContBins+  let toRatio = (* granulation) . fromIntegral+  let idxs = map toRatio [0..numContBins-1]+  --print idxs++  whileS do+    shuffled <- shuffleM (elems @a)+    let sets = scanr (\x -> bimap (RangeSet.insert x) (x:)) (RangeSet.empty, []) shuffled+    forM_ (init sets) $ \set -> do+      let c = contiguity (fst set)+      let idx = maybe (numContBins-1) (subtract 1) (findIndex (> c) idxs)+      when (RangeSet.sizeRanges (fst set) >= 2) do+        binC <- readArray bins idx+        writeArray bins idx (set : binC)+    szs <- map length <$> getElems bins+    print szs+    return (any (< binSize) szs)++  map (bimap toRatio (map (\(r, xs) -> (r, Set.fromList xs, xs, sort xs)))) <$> getAssocs bins-}

@@ -0,0 +1,356 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wunused-binds -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Eta reduce" #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Set.Internal+-- Copyright   :  (c) Daan Leijen 2002+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable++module Data.EnumSet (+              EnumSet       -- instance Eq+            , Size++            , size+            , member++            , empty+            , singleton+            , insert+            , delete++            , union+            , difference+            , intersection++            , fromList+            ) where++import Prelude hiding (foldr, foldl)+import Data.Bits (shiftL, shiftR)+import qualified Data.Foldable as Foldable+import Control.DeepSeq (NFData(rnf))+import GHC.Exts  ( reallyUnsafePtrEquality#, isTrue#, lazy )++type EnumSet = Set++instance NFData a => NFData (Set a) where+    rnf Tip           = ()+    rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r+++data StrictPair a b = !a :*: !b+infixr 1 :*:++ptrEq :: a -> a -> Bool+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)+{-# INLINE ptrEq #-}++infix 4 `ptrEq`++toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}+++data Set a    = Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Int !(Set a) !(Set a)+              | Tip+type Size     = Int+type role Set nominal++size :: Set a -> Int+size Tip = 0+size (Bin sz _ _ _) = sz+{-# INLINE size #-}++member :: Enum a => a -> Set a -> Bool+member x = go (fromEnum x)+  where+    go !_ Tip = False+    go x (Bin _ y l r) = case compare x y of+      LT -> go x l+      GT -> go x r+      EQ -> True+{-# INLINABLE member #-}++empty  :: Set a+empty = Tip+{-# INLINE empty #-}++singleton :: Int -> Set a+singleton x = Bin 1 x Tip Tip+{-# INLINE singleton #-}++insert :: Enum a => a -> Set a -> Set a+insert x = insertE (fromEnum x)++insertE :: Int -> Set a -> Set a+insertE x0 = go x0 x0+  where+    go :: Int -> Int -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin sz y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ | lazy orig `seq` (orig `ptrEq` y) -> t+           | otherwise -> Bin sz (lazy orig) l r+{-# INLINABLE insertE #-}++insertR :: Int -> Set a -> Set a+insertR x0 = go (fromEnum x0) (fromEnum x0)+  where+    go :: Int -> Int -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ -> t+{-# INLINABLE insertR #-}++delete :: Enum a => a -> Set a -> Set a+delete x = go (fromEnum x)+  where+    go :: Int -> Set a -> Set a+    go !_ Tip = Tip+    go x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceR y l' r+           where !l' = go x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceL y l r'+           where !r' = go x r+        EQ -> glue l r+{-# INLINABLE delete #-}++union :: Set a -> Set a -> Set a+union t1 Tip  = t1+union t1 (Bin 1 x _ _) = insertR x t1+union (Bin 1 x _ _) t2 = insertE x t2+union Tip t2  = t2+union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of+  (l2 :*: r2)+    | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+    | otherwise -> link x l1l2 r1r2+    where !l1l2 = l1 `union` l2+          !r1r2 = r1 `union` r2+{-# INLINABLE union #-}++difference :: Set a -> Set a -> Set a+difference Tip _   = Tip+difference t1 Tip  = t1+difference t1 (Bin _ x l2 r2) = case split x t1 of+   (l1, r1)+     | size l1l2 + size r1r2 == size t1 -> t1+     | otherwise -> merge l1l2 r1r2+     where !l1l2 = difference l1 l2+           !r1r2 = difference r1 r2+{-# INLINABLE difference #-}++intersection :: Set a -> Set a -> Set a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ x l1 r1) t2+  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+        then t1+        else link x l1l2 r1r2+  | otherwise = merge l1l2 r1r2+  where+    !(l2, b, r2) = splitMember x t2+    !l1l2 = intersection l1 l2+    !r1r2 = intersection r1 r2+{-# INLINABLE intersection #-}++fromList :: (Ord a, Enum a) => [a] -> Set a+fromList [] = Tip+fromList [x] = Bin 1 (fromEnum x) Tip Tip+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 (fromEnum x0) Tip Tip) xs0+                    | otherwise = go (1::Size) (Bin 1 (fromEnum x0) Tip Tip) xs0+  where+    not_ordered _ [] = False+    not_ordered x (y : _) = x >= y+    {-# INLINE not_ordered #-}++    fromList' t0 xs = Foldable.foldl' ins t0 xs+      where ins t x = insert x t++    go :: (Enum a, Ord a) => Size -> Set a -> [a] -> Set a+    go !_ t [] = t+    go _ t [x] = insertMax (fromEnum x) t+    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs+                        | otherwise = case create s xss of+                            (r, ys, []) -> go (s `shiftL` 1) (link (fromEnum x) l r) ys+                            (r, _,  ys) -> fromList' (link (fromEnum x) l r) ys++    create :: (Enum a, Ord a) => Size -> [a] -> (Set a, [a], [a])+    create !_ [] = (Tip, [], [])+    create s xs@(x : xss)+      | s == 1 = if not_ordered x xss then (Bin 1 (fromEnum x) Tip Tip, [], xss)+                                      else (Bin 1 (fromEnum x) Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [y], zs) -> (insertMax (fromEnum y) l, [], zs)+                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)+                                         | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> (link (fromEnum y) l r, zs, ws)+{-# INLINABLE fromList #-}++instance (Enum a, Eq a) => Eq (Set a) where+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)++foldr :: Enum a => (a -> b -> b) -> b -> Set a -> b+foldr f z = go z+  where+    go z' Tip           = z'+    go z' (Bin _ x l r) = go (f (toEnum x) (go z' r)) l+{-# INLINE foldr #-}++toAscList :: Enum a => Set a -> [a]+toAscList = foldr (:) []++split :: Int -> Set a -> (Set a,Set a)+split x t = toPair $ splitS x t+{-# INLINABLE split #-}++splitS :: Int -> Set a -> StrictPair (Set a) (Set a)+splitS _ Tip = Tip :*: Tip+splitS x (Bin _ y l r)+      = case compare x y of+          LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)+          GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)+          EQ -> l :*: r+{-# INLINABLE splitS #-}++splitMember :: Int -> Set a -> (Set a,Bool,Set a)+splitMember _ Tip = (Tip, False, Tip)+splitMember x (Bin _ y l r)+   = case compare x y of+       LT -> let (lt, found, gt) = splitMember x l+                 !gt' = link y gt r+             in (lt, found, gt')+       GT -> let (lt, found, gt) = splitMember x r+                 !lt' = link y l lt+             in (lt', found, gt)+       EQ -> (l, True, r)+{-# INLINABLE splitMember #-}++link :: Int -> Set a -> Set a -> Set a+link x Tip r  = insertMin x r+link x l Tip  = insertMax x l+link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)+  | delta*sizeL < sizeR  = balanceL z (link x l lz) rz+  | delta*sizeR < sizeL  = balanceR y ly (link x ry r)+  | otherwise            = bin x l r++insertMax,insertMin :: Int -> Set a -> Set a+insertMax x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceR y l (insertMax x r)++insertMin x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceL y (insertMin x l) r++merge :: Set a -> Set a -> Set a+merge Tip r   = r+merge l Tip   = l+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)+  | delta*sizeL < sizeR = balanceL y (merge l ly) ry+  | delta*sizeR < sizeL = balanceR x lx (merge rx r)+  | otherwise           = glue l r++glue :: Set a -> Set a -> Set a+glue Tip r = r+glue l Tip = l+glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)+  | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r+  | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'++minViewSure :: Int -> Set a -> Set a -> StrictPair Int (Set a)+minViewSure = go+  where+    go !x Tip r = x :*: r+    go x (Bin _ xl ll lr) r =+      case go xl ll lr of+        xm :*: l' -> xm :*: balanceR x l' r++maxViewSure :: Int -> Set a -> Set a -> StrictPair Int (Set a)+maxViewSure = go+  where+    go !x l Tip = x :*: l+    go x l (Bin _ xr rl rr) =+      case go xr rl rr of+        xm :*: r' -> xm :*: balanceL x l r'++delta,ratio :: Int+delta = 3+ratio = 2++balanceL :: Int -> Set a -> Set a -> Set a+balanceL x l r = case r of+  Tip -> case l of+           Tip -> Bin 1 x Tip Tip+           (Bin _ _ Tip Tip) -> Bin 2 x l Tip+           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)+           (Bin _ lx ll@Bin{} Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)+           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)+             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)++  (Bin rs _ _ _) -> case l of+           Tip -> Bin (1+rs) x Tip r++           (Bin ls lx ll lr)+              | ls > delta*rs  -> case (ll, lr) of+                   (Bin lls _ _ _, Bin lrs lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)+                     | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)+                   (_, _) -> error "Failure in Data.Set.balanceL"+              | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceL #-}++balanceR :: Int -> Set a -> Set a -> Set a+balanceR x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 x Tip Tip+           (Bin _ _ Tip Tip) -> Bin 2 x Tip r+           (Bin _ rx Tip rr@Bin{}) -> Bin 3 rx (Bin 1 x Tip Tip) rr+           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)+           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr+             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)++  (Bin ls _ _ _) -> case r of+           Tip -> Bin (1+ls) x l Tip++           (Bin rs rx rl rr)+              | rs > delta*ls  -> case (rl, rr) of+                   (Bin rls rlx rll rlr, Bin rrs _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)+                   (_, _) -> error "Failure in Data.Set.balanceR"+              | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceR #-}++bin :: Int -> Set a -> Set a -> Set a+bin x l r+  = Bin (size l + size r + 1) x l r+{-# INLINE bin #-}

@@ -0,0 +1,38 @@+module Data.Patricia where++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++type Patricia a = IntSet++{-# INLINABLE member #-}+member :: Enum a => a -> Patricia a -> Bool+member x = IntSet.member (fromEnum x)++{-# INLINABLE insert #-}+insert :: Enum a => a -> Patricia a -> Patricia a+insert x = IntSet.insert (fromEnum x)++{-# INLINABLE delete #-}+delete :: Enum a => a -> Patricia a -> Patricia a+delete x = IntSet.delete (fromEnum x)++{-# INLINABLE fromList #-}+fromList :: Enum a => [a] -> Patricia a+fromList = IntSet.fromList . map fromEnum++{-# INLINABLE union #-}+union :: Patricia a -> Patricia a -> Patricia a+union = IntSet.union++{-# INLINABLE intersection #-}+intersection :: Patricia a -> Patricia a -> Patricia a+intersection = IntSet.intersection++{-# INLINABLE difference #-}+difference :: Patricia a -> Patricia a -> Patricia a+difference = IntSet.difference++{-# INLINABLE empty #-}+empty :: Patricia a+empty = IntSet.empty

@@ -1,57 +1,29 @@-{-# LANGUAGE StandaloneDeriving, DeriveAnyClass, DeriveGeneric, BangPatterns, TypeApplications, ScopedTypeVariables, BlockArguments, AllowAmbiguousTypes, CPP #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables, BlockArguments, AllowAmbiguousTypes #-} module Main where --- #define USE_ENUM- import Gauge import BenchmarkUtils  import Data.RangeSet (RangeSet)-#ifdef USE_ENUM-import Data.EnumSet (Set)-#else import Data.Set (Set)-#endif import Test.QuickCheck  import Control.Monad import Control.DeepSeq -import Data.Array.IO- import Data.List-import Data.Maybe -import Data.Bifunctor (bimap)--import Control.Selective (whileS)--import GHC.Generics (Generic)- import qualified Data.RangeSet as RangeSet import qualified Data.RangeSet.Internal as RangeSet-#ifdef USE_ENUM-import qualified Data.EnumSet as Set-#else import qualified Data.Set as Set-#endif import qualified Data.List as List import GHC.Real (Fractional, (%)) -deriving instance (Generic a, NFData a) => NFData (RangeSet a)-deriving instance Generic a => Generic (RangeSet a)-deriving instance Generic Int-deriving instance Generic Word-deriving instance Generic Char- main :: IO () main = do   xss <- forM [1..10] $ \n -> generate (vectorOf (n * 10) (chooseInt (0, n * 20)))-  (ratios, bins) <- unzip <$> fillBins @Word-  --print bins -  condensedMain [-      --contiguityBench ratios bins,+  condensedMain Nothing [       rangeFromList,       rangeMemberDeleteBench,       rangeUnionBench,@@ -179,112 +151,6 @@       bench "disjoint" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_3 t),       bench "messy" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_4 t)   ]---- Density benchmark--- This benchmark generates bunches of random data with a contiguity measure of 0.0 to 1.0--- this is defined as $1 - m/n$ where $n$ is the number of elements in the set and $m$ the number--- of ranges. For each of these random sets, each element is queried in turn, and the average--- time is taken. This comparison is done between the rangeset and the data.set--contiguity :: Enum a => RangeSet a -> Rational-contiguity s = 1 - fromIntegral (RangeSet.sizeRanges s) % fromIntegral (RangeSet.size s)--numContBins :: Int-numContBins = 20--binSize :: Int-binSize = 50--approxSetSize :: Int-approxSetSize = 100--maxElem :: Enum a => a-maxElem = toEnum (approxSetSize - 1)--minElem :: Enum a => a-minElem = toEnum 0--elems :: forall a. Enum a => [a]-elems = [minElem @a .. maxElem @a]--fillBins :: forall a. (Ord a, Enum a) => IO [(Rational, [(RangeSet a, Set a, [a])])]-fillBins = do-  bins <- newArray (0, numContBins-1) [] :: IO (IOArray Int [(RangeSet a, [a])])-  let granulation = 1 % fromIntegral numContBins-  let toRatio = (* granulation) . fromIntegral-  let idxs = map toRatio [0..numContBins-1]-  print idxs--  whileS do-    shuffled <- generate (shuffle (elems @a))-    let sets = scanr (\x -> bimap (RangeSet.insert x) (x:)) (RangeSet.empty, []) shuffled-    forM_ (init sets) $ \set -> do-      let c = contiguity (fst set)-      let idx = fromMaybe 0 (findIndex (>= c) idxs)-      binC <- readArray bins idx-      writeArray bins idx (set : binC)-    szs <- map length <$> getElems bins-    print szs-    return (any (< binSize) szs)--  map (bimap toRatio (map (\(r, xs) -> (r, Set.fromList xs, sort xs)))) <$> getAssocs bins--contiguityBench :: forall a. (NFData a, Ord a, Enum a, Generic a) => [Rational] -> [[(RangeSet a, Set a, [a])]] -> Benchmark-contiguityBench ratios bins = es `deepseq` env (return (map unzip3 bins)) $ \dat ->-    bgroup "contiguity" (concatMap (mkBench dat) (zip ratios [0..]))--  where-    es = elems @a-    mkBench dat (ratio, i) = let ~(rs, ss, xss) = dat !! i in [-        bench ("overhead rangeset-all (" ++ show ratio ++ ")") $ nf (overheadRangeSetAllMember es) rs,-        bench ("overhead set-all (" ++ show ratio ++ ")") $ nf (overheadSetAllMember es) ss,-        bench ("rangeset-all (" ++ show ratio ++ ")") $ nf (rangeSetAllMember es) rs,-        bench ("set-all (" ++ show ratio ++ ")") $ nf (setAllMember es) ss,-        bench ("overhead rangeset-mem (" ++ show ratio ++ ")") $ nf (uncurry overheadRangeSetMember) (xss, rs),-        bench ("overhead set-mem (" ++ show ratio ++ ")") $ nf (uncurry overheadSetMember) (xss, ss),-        bench ("rangeset-mem (" ++ show ratio ++ ")") $ nf (uncurry rangeSetMember) (xss, rs),-        bench ("set-mem (" ++ show ratio ++ ")") $ nf (uncurry setMember) (xss, ss),-        bench ("overhead rangeset-ins (" ++ show ratio ++ ")") $ nf overheadRangeSetInsert xss,-        bench ("overhead set-ins (" ++ show ratio ++ ")") $ nf overheadSetInsert xss,-        bench ("rangeset-ins (" ++ show ratio ++ ")") $ nf rangeSetInsert xss,-        bench ("set-ins (" ++ show ratio ++ ")") $ nf setInsert xss-      ]--    overheadRangeSetAllMember :: [a] -> [RangeSet a] -> [Bool]-    overheadRangeSetAllMember !elems rs = [False | r <- rs, x <- elems]--    overheadSetAllMember :: [a] -> [Set a] -> [Bool]-    overheadSetAllMember !elems ss = [False | s <- ss, x <- elems]--    rangeSetAllMember :: [a] -> [RangeSet a] -> [Bool]-    rangeSetAllMember !elems rs = [RangeSet.member x r | r <- rs, x <- elems]--    setAllMember :: [a] -> [Set a] -> [Bool]-    setAllMember !elems ss = [Set.member x s | s <- ss, x <- elems]--    overheadRangeSetMember :: [[a]] -> [RangeSet a] -> [Bool]-    overheadRangeSetMember xss rs = [False | (r, xs) <- zip rs xss, x <- xs]--    overheadSetMember :: [[a]] -> [Set a] -> [Bool]-    overheadSetMember xss ss = [False | (s, xs) <- zip ss xss, x <- xs]--    rangeSetMember :: [[a]] -> [RangeSet a] -> [Bool]-    rangeSetMember xss rs = [RangeSet.member x r | (r, xs) <- zip rs xss, x <- xs]--    setMember :: [[a]] -> [Set a] -> [Bool]-    setMember xss ss = [Set.member x s | (s, xs) <- zip ss xss, x <- xs]--    overheadRangeSetInsert :: [[a]] -> [RangeSet a]-    overheadRangeSetInsert = map (foldr (flip const) RangeSet.empty)--    overheadSetInsert :: [[a]] -> [Set a]-    overheadSetInsert = map (foldr (flip const) Set.empty)--    rangeSetInsert :: [[a]] -> [RangeSet a]-    rangeSetInsert = map (foldr RangeSet.insert RangeSet.empty)--    setInsert :: [[a]] -> [Set a]-    setInsert = map (foldr Set.insert Set.empty)  makeBench :: NFData a => (a -> String) -> [(String, a -> Benchmarkable)] -> a -> Benchmark makeBench caseName cases x = env (return x) (\x ->

@@ -5,7 +5,7 @@ --                   | +------- breaking changes --                   | | +----- non-breaking additions --                   | | | +--- code changes with no API change-version:             0.0.1.0+version:             0.1.0.0 synopsis:            Efficient sets for semi-contiguous data description:         Exposes the range-set datastructure, which can encode                      enumerable data efficiently by compressing contiguous@@ -28,11 +28,6 @@                      GHC == 9.0.2,                      GHC == 9.2.3 -flag safe-haskell-rangeset-  description: Make the RangeSet implementation use only safe-haskell things-  default:     False-  manual:      True- library   exposed-modules:     Data.RangeSet                        Data.RangeSet.Builders@@ -49,10 +44,14 @@                        Data.RangeSet.Internal.Lumpers                        Data.RangeSet.Internal.Splitters                        Data.RangeSet.Internal.Heuristics+                       Data.RangeSet.Internal.Unsafe    build-depends:       base                 >= 4.10    && < 5-  build-tool-depends:  cpphs:cpphs          >= 1.18.8  && < 1.21   hs-source-dirs:      src/ghc+  if impl(ghc >= 9.2)+    hs-source-dirs:    src/ghc-9.2++  else+    hs-source-dirs:    src/ghc-8.6+   default-language:    Haskell2010   ghc-options:         -Wall -Weverything -Wcompat                        -Wno-name-shadowing@@ -60,15 +59,12 @@                        -Wno-unsafe                        -Wno-all-missed-specialisations                        -Wno-incomplete-uni-patterns-                       -pgmP cpphs -optP --cpp                        -freverse-errors    if impl(ghc >= 8.10)     ghc-options:       -Wno-missing-safe-haskell-mode   if impl(ghc >= 9.2)     ghc-options:       -Wno-missing-kind-signatures-  if flag(safe-haskell-rangeset)-    cpp-options:       -DSAFE  common test-common   build-depends:       base >=4.10 && <5,@@ -97,11 +93,26 @@   import:              benchmark-common   type:                exitcode-stdio-1.0   build-depends:       containers,-                       QuickCheck,-                       array,-                       selective+                       QuickCheck   main-is:             RangeSetBench.hs   --other-modules:       Data.EnumSet++benchmark complexity-bench+  import:              benchmark-common+  type:                exitcode-stdio-1.0+  build-depends:       array,+                       random-shuffle,+                       containers,+  main-is:             ComplexityBench.hs++benchmark contiguity-bench+  import:              benchmark-common+  type:                exitcode-stdio-1.0+  build-depends:       containers,+                       random-shuffle,+                       random+  main-is:             ContiguityBench.hs+  other-modules:       Data.EnumSet, Data.Patricia  source-repository head   type:                git

@@ -0,0 +1,61 @@+{-# LANGUAGE DerivingStrategies, RoleAnnotations, Trustworthy, BangPatterns #-}+module Data.RangeSet.Internal.Types (module Data.RangeSet.Internal.Types) where++import Prelude++import GHC.Word (Word8)++import Data.RangeSet.Internal.Unsafe++type E = Int+type H = Word8+{-|+A @Set@ type designed for types that are `Enum` as well as `Ord`. This allows the `RangeSet` to+compress the data when it is contiguous, reducing memory-footprint and enabling otherwise impractical+operations like `complement` for `Bounded` types.++@since 0.0.1.0+-}+data RangeSet a = Fork {-# UNPACK #-} !H {-# UNPACK #-} !E {-# UNPACK #-} !E !(RangeSet a) !(RangeSet a)+                | Tip+                deriving stock Show+type role RangeSet nominal++{-|+Return the number of /elements/ in the set.++@since 0.0.1.0+-}+{-# INLINE size #-}+size :: RangeSet a -> Int+size = foldE (\l u szl szr -> szl + szr + (u - l + 1)) 0++{-# INLINE height #-}+height :: RangeSet a -> H+height Tip = 0+height (Fork h _ _ _ _) = h++{-# INLINEABLE foldE #-}+foldE :: (E -> E -> b -> b -> b) -- ^ Function that combines the lower and upper values (inclusive) for a range with the folded left- and right-subtrees.+      -> b                       -- ^ Value to be substituted at the leaves.+      -> RangeSet a+      -> b+foldE _ tip Tip = tip+foldE fork tip (Fork _ l u lt rt) = fork l u (foldE fork tip lt) (foldE fork tip rt)++data StrictMaybeE = SJust {-# UNPACK #-} !E | SNothing+data SRangeList = SRangeCons {-# UNPACK #-} !E {-# UNPACK #-} !E !SRangeList | SNil++absDiff :: H -> H -> H+absDiff !h1 !h2+  | h1 > h2   = h1 - h2+  | otherwise = h2 - h1++-- Instances+instance Eq (RangeSet a) where+  {-# INLINABLE (==) #-}+  t1 == t2 = ptrEq t1 t2 || (absDiff (height t1) (height t2) <= 1 && ranges t1 == ranges t2)+    where+      {-# INLINE ranges #-}+      ranges :: RangeSet a -> [(E, E)]+      ranges t = foldE (\l u lt rt -> lt . ((l, u) :) . rt) id t []

@@ -0,0 +1,67 @@+{-# LANGUAGE DerivingStrategies, RoleAnnotations, Trustworthy, BangPatterns #-}+{-# LANGUAGE UnliftedDatatypes #-}+module Data.RangeSet.Internal.Types (module Data.RangeSet.Internal.Types) where++import Prelude++import GHC.Exts (UnliftedType)++import GHC.Word (Word8)++import Data.RangeSet.Internal.Unsafe++type E = Int+type H = Word8+{-|+A @Set@ type designed for types that are `Enum` as well as `Ord`. This allows the `RangeSet` to+compress the data when it is contiguous, reducing memory-footprint and enabling otherwise impractical+operations like `complement` for `Bounded` types.++@since 0.0.1.0+-}+data RangeSet a = Fork {-# UNPACK #-} !H {-# UNPACK #-} !E {-# UNPACK #-} !E !(RangeSet a) !(RangeSet a)+                | Tip+                deriving stock Show+type role RangeSet nominal++{-|+Return the number of /elements/ in the set.++@since 0.0.1.0+-}+{-# INLINE size #-}+size :: RangeSet a -> Int+size = foldE (\l u szl szr -> szl + szr + (u - l + 1)) 0++{-# INLINE height #-}+height :: RangeSet a -> H+height Tip = 0+height (Fork h _ _ _ _) = h++{-# INLINEABLE foldE #-}+foldE :: (E -> E -> b -> b -> b) -- ^ Function that combines the lower and upper values (inclusive) for a range with the folded left- and right-subtrees.+      -> b                       -- ^ Value to be substituted at the leaves.+      -> RangeSet a+      -> b+foldE _ tip Tip = tip+foldE fork tip (Fork _ l u lt rt) = fork l u (foldE fork tip lt) (foldE fork tip rt)++type StrictMaybeE :: UnliftedType+data StrictMaybeE = SJust {-# UNPACK #-} !E | SNothing++type SRangeList :: UnliftedType+data SRangeList = SRangeCons {-# UNPACK #-} !E {-# UNPACK #-} !E !SRangeList | SNil++absDiff :: H -> H -> H+absDiff !h1 !h2+  | h1 > h2   = h1 - h2+  | otherwise = h2 - h1++-- Instances+instance Eq (RangeSet a) where+  {-# INLINABLE (==) #-}+  t1 == t2 = ptrEq t1 t2 || (absDiff (height t1) (height t2) <= 1 && ranges t1 == ranges t2)+    where+      {-# INLINE ranges #-}+      ranges :: RangeSet a -> [(E, E)]+      ranges t = foldE (\l u lt rt -> lt . ((l, u) :) . rt) id t []

@@ -35,7 +35,7 @@ @since 0.0.1.0 -} singleton :: Enum a => a -> RangeSet a-singleton x = single 1 (fromEnum x) (fromEnum x)+singleton x = single (fromEnum x) (fromEnum x)  {-| Is this set empty?@@ -53,7 +53,7 @@ -} full :: forall a. (Enum a, Bounded a) => RangeSet a -> Bool full Tip = False-full (Fork _ _ l u _ _) = l == fromEnum @a minBound && fromEnum @a maxBound == u+full (Fork _ l u _ _) = l == fromEnum @a minBound && fromEnum @a maxBound == u  {-| Does this set contain a single element?@@ -61,7 +61,7 @@ @since 0.0.1.0 -} isSingle :: RangeSet a -> Bool-isSingle (Fork _ 1 _ _ _ _) = True+isSingle (Fork 1 l u _ _) = l == u isSingle _ = False  {-|@@ -70,16 +70,16 @@ @since 0.0.1.0 -} extractSingle :: Enum a => RangeSet a -> Maybe a-extractSingle (Fork _ 1 x _ _ _) = Just (toEnum x)-extractSingle _                  = Nothing+extractSingle (Fork 1 x y _ _) | x == y = Just (toEnum x)+extractSingle _ = Nothing  {-| Return the number of /contiguous ranges/ that populate the set.  @since 0.0.1.0 -}-sizeRanges :: Enum a => RangeSet a -> Int-sizeRanges = fold (\_ _ szl szr -> szl + szr + 1) 0+sizeRanges :: RangeSet a -> Int+sizeRanges = foldE (\_ _ szl szr -> szl + szr + 1) 0  {-| Test whether or not a given value is not found within the set.@@ -98,7 +98,7 @@ {-# INLINE findMin #-} findMin :: Enum a => RangeSet a -> Maybe a findMin Tip = Nothing-findMin (Fork _ _ l u lt _) = let (# !m, !_ #) = minRange l u lt in Just (toEnum m)+findMin (Fork _ l u lt _) = let (# !m, !_ #) = minRange l u lt in Just (toEnum m)  {-| Find the maximum value within the set, if one exists.@@ -108,7 +108,7 @@ {-# INLINE findMax #-} findMax :: Enum a => RangeSet a -> Maybe a findMax Tip = Nothing-findMax (Fork _ _ l u _ rt) = let (# !_, !m #) = maxRange l u rt in Just (toEnum m)+findMax (Fork _ l u _ rt) = let (# !_, !m #) = maxRange l u rt in Just (toEnum m)  {-| Filters a set by removing all values greater than or equal to the given value.@@ -136,18 +136,18 @@ -} {-# INLINEABLE complement #-} complement :: forall a. (Bounded a, Enum a) => RangeSet a -> RangeSet a-complement Tip = single (diffE minBoundE maxBoundE) minBoundE maxBoundE+complement Tip = single minBoundE maxBoundE   where     !minBoundE = fromEnum @a minBound     !maxBoundE = fromEnum @a maxBound complement t | full t = Tip-complement t@(Fork _ sz l u lt rt) = case maxl of-  SJust x -> unsafeInsertR (diffE x maxBoundE) x maxBoundE t'+complement t@(Fork _ l u lt rt) = case maxl of+  SJust x -> unsafeInsertR x maxBoundE t'   SNothing -> t'   where     !minBoundE = fromEnum @a minBound     !maxBoundE = fromEnum @a maxBound-    (# !minl, !minu, !rest #) = minDelete sz l u lt rt+    (# !minl, !minu, !rest #) = minDelete l u lt rt      -- The complement of a tree is at most 1 larger or smaller than the original     -- if both min and max are minBound and maxBound, it will shrink@@ -166,10 +166,10 @@     -- the return /must/ be the next correct lower bound     push :: E -> RangeSet a -> (# RangeSet a, StrictMaybeE #)     push !maxl Tip = (# Tip, SJust maxl #)-    push min (Fork _ _ u max lt Tip) =+    push min (Fork _ u max lt Tip) =       let (# !lt', SJust l #) = push min lt       in  (# fork l (pred u) lt' Tip, safeSucc max #)-    push min (Fork _ _ u l' lt rt@Fork{}) =+    push min (Fork _ u l' lt rt@Fork{}) =       let (# !lt', SJust l #) = push min lt           -- this is safe, because we know the right-tree contains elements larger than l'           !(# !rt', !max #) = push (succ l') rt

@@ -4,10 +4,13 @@ import Prelude hiding (id, (.)) import Data.RangeSet.Internal import Data.RangeSet.Primitives+import Data.List (foldl') +{-# INLINE id #-} id :: SRangeList -> SRangeList id ss = ss +{-# INLINE (.) #-} (.) :: (SRangeList -> SRangeList) -> (SRangeList -> SRangeList) -> SRangeList -> SRangeList (f . g) ss = f (g ss) @@ -16,6 +19,7 @@  @since 0.0.1.0 -}+{-# INLINABLE fromRanges #-} fromRanges :: forall a. Enum a => [(a, a)] -> RangeSet a fromRanges [] = Tip fromRanges ((x, y):rs) = go rs ey (SRangeCons ex ey) 1@@ -26,7 +30,7 @@     go [] !_ k !n = fromDistinctAscRangesSz (k SNil) n     go ((x, y):rs) z k n       -- ordering and disjointness of the ranges broken-      | ex <= z || ey <= z = insertRangeE ex ey (foldr (uncurry insertRange) (fromDistinctAscRangesSz (k SNil) n) rs)+      | ex <= z || ey <= z = insertRangeE ex ey (foldl' (flip (uncurry insertRange)) (fromDistinctAscRangesSz (k SNil) n) rs)       | otherwise          = go rs ey (k . SRangeCons ex ey) (n + 1)       where         !ex = fromEnum x@@ -37,6 +41,7 @@  @since 0.0.1.0 -}+{-# INLINABLE fromDistinctAscRanges #-} fromDistinctAscRanges :: forall a. Enum a => [(a, a)] -> RangeSet a fromDistinctAscRanges rs = go rs id 0   where@@ -61,6 +66,7 @@  @since 0.0.1.0 -}+{-# INLINABLE fromList #-} fromList :: forall a. Enum a => [a] -> RangeSet a fromList [] = Tip fromList (x:xs) = go xs (fromEnum x) (fromEnum x) id 1@@ -69,7 +75,7 @@     go [] !l !u k !n = fromDistinctAscRangesSz (k (SRangeCons l u SNil)) n     go (!x:xs) l u k n       -- ordering or uniqueness is broken-      | ex <= u      = insertE ex (foldr insert (fromDistinctAscRangesSz (k (SRangeCons l u SNil)) n) xs)+      | ex <= u      = insertE ex (foldl' (flip insert) (fromDistinctAscRangesSz (k (SRangeCons l u SNil)) n) xs)       -- the current range is expanded       | ex == succ u = go xs l ex k n       -- a new range begins@@ -83,6 +89,7 @@  @since 0.0.1.0 -}+{-# INLINABLE fromDistinctAscList #-} fromDistinctAscList :: forall a. Enum a => [a] -> RangeSet a fromDistinctAscList [] = Tip fromDistinctAscList (x:xs) = go xs (fromEnum x) (fromEnum x) id 1

@@ -1,9 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples, MultiWayIf, BangPatterns, CPP #-}-#ifdef SAFE-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE UnboxedTuples, MultiWayIf, BangPatterns, Trustworthy #-} module Data.RangeSet.Internal (     module Data.RangeSet.Internal,     RangeSet(..), E, SRangeList(..), StrictMaybeE(..),@@ -27,96 +22,99 @@ import Data.RangeSet.Internal.Lumpers import Data.RangeSet.Internal.Splitters import Data.RangeSet.Internal.Heuristics+import Data.Bits (shiftR)  {-# INLINEABLE insertE #-} insertE :: E -> RangeSet a -> RangeSet a-insertE !x Tip = single 1 x x-insertE x t@(Fork h sz l u lt rt)+insertE !x Tip = single x x+insertE x t@(Fork h l u lt rt)   -- Nothing happens when it's already in range   | l <= x = if     | x <= u -> t   -- If it is adjacent to the upper range, it may fuse-    | x == succ u -> fuseRight h (sz + 1) l x lt rt                                         -- we know x > u since x <= l && not x <= u+    | x == succ u -> fuseRight h l x lt rt                                         -- we know x > u since x <= l && not x <= u   -- Otherwise, insert and balance for right-    | otherwise -> ifStayedSame rt (insertE x rt) t (balance (sz + 1) l u lt)               -- cannot be biased, because fusion can shrink a tree+    | otherwise -> ifStayedSame rt (insertE x rt) t (balance l u lt)               -- cannot be biased, because fusion can shrink a tree   | {- x < l -} otherwise = if   -- If it is adjacent to the lower, it may fuse-    x == pred l then fuseLeft h (sz + 1) x u lt rt                                          -- the equality must be guarded by an existence check+    x == pred l then fuseLeft h x u lt rt                                          -- the equality must be guarded by an existence check   -- Otherwise, insert and balance for left-                else ifStayedSame lt (insertE x lt) t $ \lt' -> balance (sz + 1) l u lt' rt -- cannot be biased, because fusion can shrink a tree+                else ifStayedSame lt (insertE x lt) t $ \lt' -> balance l u lt' rt -- cannot be biased, because fusion can shrink a tree   where     {-# INLINE fuseLeft #-}-    fuseLeft !h !sz !x !u Tip !rt = Fork h sz x u Tip rt-    fuseLeft h sz x u (Fork _ lsz ll lu llt lrt) rt-      | (# !l, !x', lt' #) <- maxDelete lsz ll lu llt lrt+    fuseLeft !h !x !u Tip !rt = Fork h x u Tip rt+    fuseLeft h x u lt@(Fork _ ll lu llt lrt) rt+      | (# !l, !x', lt' #) <- maxDelete ll lu llt lrt       -- we know there exists an element larger than x'       -- if x == x' + 1, we fuse (x != x' since that breaks disjointness, x == pred l)-      , x == succ x' = balanceR sz l u lt' rt-      | otherwise    = Fork h sz x u lt rt+      , x == succ x' = balanceR l u lt' rt+      | otherwise    = Fork h x u lt rt     {-# INLINE fuseRight #-}-    fuseRight !h !sz !l !x !lt Tip = Fork h sz l x lt Tip-    fuseRight h sz l x lt (Fork _ rsz rl ru rlt rrt)-      | (# !x', !u, rt' #) <- minDelete rsz rl ru rlt rrt+    fuseRight !h !l !x !lt Tip = Fork h l x lt Tip+    fuseRight h l x lt rt@(Fork _ rl ru rlt rrt)+      | (# !x', !u, rt' #) <- minDelete rl ru rlt rrt       -- we know there exists an element smaller than x'       -- if x == x' - 1, we fuse (x != x' since that breaks disjointness, as x == succ u)-      , x == pred x' = balanceL sz l u lt rt'-      | otherwise    = Fork h sz l x lt rt+      , x == pred x' = balanceL l u lt rt'+      | otherwise    = Fork h l x lt rt  {-# INLINEABLE deleteE #-} deleteE :: E -> RangeSet a -> RangeSet a deleteE !_ Tip = Tip-deleteE x t@(Fork h sz l u lt rt) =+deleteE x t@(Fork h l u lt rt) =   case compare l x of     -- If its the only part of the range, the node is removed-    EQ | x == u    -> glue (sz - 1) lt rt+    EQ | x == u    -> glue lt rt     -- If it's at an extreme, it shrinks the range-       | otherwise -> Fork h (sz - 1) (succ l) u lt rt+       | otherwise -> Fork h (succ l) u lt rt     LT -> case compare x u of     -- If it's at an extreme, it shrinks the range-       EQ          -> Fork h (sz - 1) l (pred u) lt rt+       EQ          -> Fork h l (pred u) lt rt     -- Otherwise, if it's still in range, the range undergoes fission-       LT          -> fission (sz - 1) l x u lt rt+       LT          -> fission l x u lt rt     -- Otherwise delete and balance for one of the left or right-       GT          -> ifStayedSame rt (deleteE x rt) t $ balance (sz - 1) l u lt             -- cannot be biased, because fisson can grow a tree-    GT             -> ifStayedSame lt (deleteE x lt) t $ \lt' -> balance (sz - 1) l u lt' rt -- cannot be biased, because fisson can grow a tree+       GT          -> ifStayedSame rt (deleteE x rt) t $ balance l u lt             -- cannot be biased, because fisson can grow a tree+    GT             -> ifStayedSame lt (deleteE x lt) t $ \lt' -> balance l u lt' rt -- cannot be biased, because fisson can grow a tree   where     {- Fission breaks a node into two new ranges        we'll push the range down into the smallest child, ensuring it's balanced -}     {-# INLINE fission #-}-    fission :: Size -> E -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-    fission !sz !l1 !x !u2 !lt !rt-      | height lt > height rt = forkSz sz l1 u1 lt (unsafeInsertL sz' l2 u2 rt)-      | otherwise = forkSz sz l1 u1 (unsafeInsertR sz' l2 u2 lt) rt+    fission :: E -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+    fission !l1 !x !u2 !lt !rt+      | height lt > height rt = fork l1 u1 lt (unsafeInsertL l2 u2 rt)+      | otherwise = fork l1 u1 (unsafeInsertR l2 u2 lt) rt       where         !u1 = pred x         !l2 = succ x-        !sz' = diffE l2 u2  uncheckedSubsetOf :: RangeSet a -> RangeSet a -> Bool uncheckedSubsetOf Tip _ = True uncheckedSubsetOf _ Tip = False-uncheckedSubsetOf (Fork _ _ l u lt rt) t = case splitOverlap l u t of-  (# lt', Fork 1 _ x y _ _, rt' #) ->-       x == l && y == u-    && size lt <= size lt' && size rt <= size rt'-    && uncheckedSubsetOf lt lt' && uncheckedSubsetOf rt rt'-  _                                -> False+uncheckedSubsetOf (Fork _ ll lu llt lrt) (Fork _ rl ru rlt rrt) = case splitOverlapFork ll lu rl ru rlt rrt of+  (# lt', Fork 1 x y _ _, rt' #) ->+       x == ll && y == lu+    && uncheckedSubsetOf llt lt' && uncheckedSubsetOf lrt rt'+  _                              -> False +{-# INLINEABLE fromDistinctAscRangesSz #-} fromDistinctAscRangesSz :: SRangeList -> Int -> RangeSet a-fromDistinctAscRangesSz rs !n = case go rs 0 (n - 1) of (# t, _ #) -> t+fromDistinctAscRangesSz rs !n = case go rs 0 (n - 1) of (# _, t, _ #) -> t   where-    go :: SRangeList -> Int -> Int -> (# RangeSet a, SRangeList #)+    go :: SRangeList -> Int -> Int -> (# H, RangeSet a, SRangeList #)     go rs !i !j-      | i > j     = (# Tip, rs #)+      | i > j     = (# 1, Tip, rs #)       | otherwise =-        let !mid = (i + j) `div` 2+        let !mid = (i + j) `shiftR` 1         in case go rs i (mid - 1) of-             (# lt, rs' #) ->+             (# _, lt, rs' #) ->                 let !(SRangeCons l u rs'') = rs'                 in case go rs'' (mid + 1) j of-                      (# rt, rs''' #) -> (# fork l u lt rt, rs''' #)+                      -- there is a height bias to the right, so the height of the right tree is all we need+                      -- perhaps this can be computed though from mid somehow instead of passing back?+                      (# !h, rt, rs''' #) -> (# h + 1, Fork h l u lt rt, rs''' #)  {-# INLINE insertRangeE #-} -- This could be improved, but is OK insertRangeE :: E -> E -> RangeSet a -> RangeSet a-insertRangeE !l !u t = let (# lt, rt #) = split l u t in link l u lt rt+insertRangeE !l !u Tip = single l u+insertRangeE l u (Fork _ l' u' lt rt) = let (# lt', rt' #) = splitFork l u l' u' lt rt in link l u lt' rt'

@@ -3,12 +3,12 @@  import Prelude -import Data.RangeSet.Internal.Types (E, Size)+import Data.RangeSet.Internal.Types (E)  {-# INLINE range #-} range :: Enum a => a -> a -> [a] range l u = [l..u]  {-# INLINE diffE #-}-diffE :: E -> E -> Size+diffE :: E -> E -> Int diffE !l !u = u - l + 1

@@ -1,37 +1,37 @@ {-# LANGUAGE BangPatterns, UnboxedTuples, Safe #-} module Data.RangeSet.Internal.Extractors (module Data.RangeSet.Internal.Extractors) where -import Prelude+import Prelude ()  import Data.RangeSet.Internal.Types import Data.RangeSet.Internal.SmartConstructors  {-# INLINEABLE minRange #-} minRange :: E -> E -> RangeSet a -> (# E, E #)-minRange !l !u Tip                 = (# l, u #)-minRange _  _  (Fork _ _ l u lt _) = minRange l u lt+minRange !l !u Tip               = (# l, u #)+minRange _  _  (Fork _ l u lt _) = minRange l u lt  {-# INLINEABLE maxRange #-} maxRange :: E -> E -> RangeSet a -> (# E, E #)-maxRange !l !u Tip                 = (# l, u #)-maxRange _  _  (Fork _ _ l u _ rt) = maxRange l u rt+maxRange !l !u Tip               = (# l, u #)+maxRange _  _  (Fork _ l u _ rt) = maxRange l u rt  {-# INLINE minDelete #-}-minDelete :: Size -> E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)-minDelete !sz !l !u !lt !rt = let (# !ml, !mu, !_, t' #) = go sz l u lt rt in (# ml, mu, t' #)+minDelete :: E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)+minDelete !l !u !lt !rt = let (# !ml, !mu, t' #) = go l u lt rt in (# ml, mu, t' #)   where-    go :: Size -> E -> E -> RangeSet a -> RangeSet a -> (# E, E, Size, RangeSet a #)-    go !sz !l !u Tip !rt = (# l, u, sz - size rt, rt #)-    go sz l u (Fork _ lsz ll lu llt lrt) rt =-      let (# !ml, !mu, !msz, lt' #) = go lsz ll lu llt lrt-      in (# ml, mu, msz, balanceR (sz - msz) l u lt' rt #)+    go :: E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)+    go !l !u Tip !rt = (# l, u, rt #)+    go l u (Fork _ ll lu llt lrt) rt =+      let (# !ml, !mu, lt' #) = go ll lu llt lrt+      in (# ml, mu, balanceR l u lt' rt #)  {-# INLINE maxDelete #-}-maxDelete :: Size -> E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)-maxDelete !sz !l !u !lt !rt = let (# !ml, !mu, !_, t' #) = go sz l u lt rt in (# ml, mu, t' #)+maxDelete :: E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)+maxDelete !l !u !lt !rt = let (# !ml, !mu, t' #) = go l u lt rt in (# ml, mu, t' #)   where-    go :: Size -> E -> E -> RangeSet a -> RangeSet a -> (# E, E, Size, RangeSet a #)-    go !sz !l !u !lt Tip = (# l, u, sz - size lt, lt #)-    go sz l u lt (Fork _ rsz rl ru rlt rrt) =-      let (# !ml, !mu, !msz, rt' #) = go rsz rl ru rlt rrt-      in (# ml, mu, msz, balanceL (sz - msz) l u lt rt' #)+    go :: E -> E -> RangeSet a -> RangeSet a -> (# E, E, RangeSet a #)+    go !l !u !lt Tip = (# l, u, lt #)+    go l u lt (Fork _ rl ru rlt rrt) =+      let (# !ml, !mu, rt' #) = go rl ru rlt rrt+      in (# ml, mu, balanceL l u lt rt' #)

@@ -1,24 +1,10 @@-{-# LANGUAGE BangPatterns, MagicHash, CPP #-}-#ifdef SAFE-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Unsafe #-}-#endif+{-# LANGUAGE BangPatterns, Unsafe #-} module Data.RangeSet.Internal.Heuristics (stayedSame, ifStayedSame) where  import Prelude -#ifndef SAFE-import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)-#endif- import Data.RangeSet.Internal.Types--#ifndef SAFE-{-# INLINE ptrEq #-}-ptrEq :: a -> a -> Bool-ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)-#endif+import Data.RangeSet.Internal.Unsafe  {-# INLINE stayedSame #-} {-|@@ -29,13 +15,8 @@ stayedSame :: RangeSet a -- ^ the original set            -> RangeSet a -- ^ the same (?) set post modification            -> Bool-stayedSame before after =-#ifdef SAFE-    size before == size after-#else-    before `ptrEq` after-#endif+stayedSame !before !after = before `ptrEq` after  {-# INLINE ifStayedSame #-} ifStayedSame :: RangeSet a -> RangeSet a -> RangeSet a -> (RangeSet a -> RangeSet a) -> RangeSet a-ifStayedSame !x !x' y f = if size x == size x' then y else f x'+ifStayedSame !x !x' y f = if x `ptrEq` x' then y else f x'

@@ -13,12 +13,12 @@ It *must* be /known/ not to exist within the tree. -} {-# INLINEABLE unsafeInsertL #-}-unsafeInsertL :: Size -> E -> E -> RangeSet a -> RangeSet a-unsafeInsertL !newSz !l !u = go+unsafeInsertL :: E -> E -> RangeSet a -> RangeSet a+unsafeInsertL !l !u = go   where     go :: RangeSet a -> RangeSet a-    go Tip = single newSz l u-    go (Fork _ sz l' u' lt rt) = balanceL (sz + newSz) l' u' (go lt) rt+    go Tip = single l u+    go (Fork _ l' u' lt rt) = balanceL l' u' (go lt) rt  {-| Inserts an range at the right-most position in the tree.@@ -26,33 +26,33 @@ It *must* be /known/ not to exist within the tree. -} {-# INLINEABLE unsafeInsertR #-}-unsafeInsertR :: Size -> E -> E -> RangeSet a -> RangeSet a-unsafeInsertR !newSz !l !u = go+unsafeInsertR :: E -> E -> RangeSet a -> RangeSet a+unsafeInsertR !l !u = go   where     go :: RangeSet a -> RangeSet a-    go Tip = single newSz l u-    go (Fork _ sz l' u' lt rt) = balanceR (sz + newSz) l' u' lt (go rt)+    go Tip = single l u+    go (Fork _ l' u' lt rt) = balanceR l' u' lt (go rt)  {-# INLINEABLE insertLAdj #-}-insertLAdj :: Size -> E -> E -> Int -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-insertLAdj !newSz !l !u !th !tsz !tl !tu !tlt !trt = case minRange tl tu tlt of-  (# !l', _ #) | l' == succ u -> fuseL newSz l th tsz tl tu tlt trt-               | otherwise    -> balanceL (tsz + newSz) tl tu (unsafeInsertL newSz l u tlt) trt+insertLAdj :: E -> E -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+insertLAdj !l !u !th !tl !tu !tlt !trt = case minRange tl tu tlt of+  (# !l', _ #) | l' == succ u -> fuseL l th tl tu tlt trt+               | otherwise    -> balanceL tl tu (unsafeInsertL l u tlt) trt   where     {-# INLINEABLE fuseL #-}-    fuseL :: Size -> E -> Int -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-    fuseL !newSz !l' !h !sz !l !u lt rt = case lt of-      Tip -> Fork h (newSz + sz) l' u Tip rt-      Fork lh lsz ll lu llt lrt  -> Fork h (newSz + sz) l u (fuseL newSz l' lh lsz ll lu llt lrt) rt+    fuseL :: E -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+    fuseL !l' !h !l !u lt rt = case lt of+      Tip -> Fork h l' u Tip rt+      Fork lh ll lu llt lrt  -> Fork h l u (fuseL l' lh ll lu llt lrt) rt  {-# INLINEABLE insertRAdj #-}-insertRAdj :: Size -> E -> E -> Int -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-insertRAdj !newSz !l !u !th !tsz !tl !tu !tlt !trt = case maxRange tl tu trt of-  (# _, !u' #) | u' == pred l -> fuseR newSz u th tsz tl tu tlt trt-               | otherwise    -> balanceR (tsz + newSz) tl tu tlt (unsafeInsertR newSz l u trt)+insertRAdj :: E -> E -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+insertRAdj !l !u !th !tl !tu !tlt !trt = case maxRange tl tu trt of+  (# _, !u' #) | u' == pred l -> fuseR u th tl tu tlt trt+               | otherwise    -> balanceR tl tu tlt (unsafeInsertR l u trt)   where     {-# INLINEABLE fuseR #-}-    fuseR :: Size -> E -> Int -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-    fuseR !newSz !u' !h !sz !l !u lt rt = case rt of-      Tip -> Fork h (newSz + sz) l u' lt Tip-      Fork rh rsz rl ru rlt rrt  -> Fork h (newSz + sz) l u lt (fuseR newSz u' rh rsz rl ru rlt rrt)+    fuseR :: E -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+    fuseR !u' !h !l !u lt rt = case rt of+      Tip -> Fork h l u' lt Tip+      Fork rh rl ru rlt rrt  -> Fork h l u lt (fuseR u' rh rl ru rlt rrt)

@@ -7,19 +7,18 @@ import Data.RangeSet.Internal.SmartConstructors import Data.RangeSet.Internal.Inserters import Data.RangeSet.Internal.Extractors-import Data.RangeSet.Internal.Enum  {-# INLINABLE link #-} link :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a-link !l !u Tip Tip = single (diffE l u) l u-link l u Tip (Fork rh rsz rl ru rlt rrt) = insertLAdj (diffE l u) l u rh rsz rl ru rlt rrt-link l u (Fork lh lsz ll lu llt lrt) Tip = insertRAdj (diffE l u) l u lh lsz ll lu llt lrt-link l u lt@(Fork _ lsz ll lu llt lrt) rt@(Fork _ rsz rl ru rlt rrt) =-  disjointLink (diffE l' u') l' u' lt'' rt''+link !l !u Tip Tip = single l u+link l u Tip (Fork rh rl ru rlt rrt) = insertLAdj l u rh rl ru rlt rrt+link l u (Fork lh ll lu llt lrt) Tip = insertRAdj l u lh ll lu llt lrt+link l u lt@(Fork _ ll lu llt lrt) rt@(Fork _ rl ru rlt rrt) =+  disjointLink l' u' lt'' rt''   where     -- we have to check for fusion up front-    (# !lmaxl, !lmaxu, lt' #) = maxDelete lsz ll lu llt lrt-    (# !rminl, !rminu, rt' #) = minDelete rsz rl ru rlt rrt+    (# !lmaxl, !lmaxu, lt' #) = maxDelete ll lu llt lrt+    (# !rminl, !rminu, rt' #) = minDelete rl ru rlt rrt      (# !l', !lt'' #) | lmaxu == pred l = (# lmaxl, lt' #)                      | otherwise       = (# l, lt #)@@ -28,13 +27,13 @@                      | otherwise       = (# u, rt #)  {-# INLINEABLE disjointLink #-}-disjointLink :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-disjointLink !newSz !l !u Tip rt = unsafeInsertL newSz l u rt-disjointLink newSz l u lt Tip = unsafeInsertR newSz l u lt-disjointLink newSz l u lt@(Fork hl szl ll lu llt lrt) rt@(Fork hr szr rl ru rlt rrt)-  | hl < hr + 1 = balanceL (newSz + szl + szr) rl ru (disjointLink newSz l u lt rlt) rrt-  | hr < hl + 1 = balanceR (newSz + szl + szr) ll lu llt (disjointLink newSz l u lrt rt)-  | otherwise   = forkH (newSz + szl + szr) l u hl lt hr rt+disjointLink :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a+disjointLink !l !u Tip rt = unsafeInsertL l u rt+disjointLink l u lt Tip = unsafeInsertR l u lt+disjointLink l u lt@(Fork hl ll lu llt lrt) rt@(Fork hr rl ru rlt rrt)+  | hl < hr + 1 = balanceL rl ru (disjointLink l u lt rlt) rrt+  | hr < hl + 1 = balanceR ll lu llt (disjointLink l u lrt rt)+  | otherwise   = forkH l u hl lt hr rt  -- This version checks for fusion between the two trees to be merged {-{-# INLINEABLE merge #-}@@ -53,17 +52,20 @@ disjointMerge :: RangeSet a -> RangeSet a -> RangeSet a disjointMerge Tip rt = rt disjointMerge lt Tip = lt-disjointMerge lt@(Fork hl szl ll lu llt lrt) rt@(Fork hr szr rl ru rlt rrt)-  | hl < hr + 1 = balanceL (szl + szr) rl ru (disjointMerge lt rlt) rrt-  | hr < hl + 1 = balanceR (szl + szr) ll lu llt (disjointMerge lrt rt)-  | otherwise   = glue (szl + szr) lt rt+disjointMerge lt@(Fork hl ll lu llt lrt) rt@(Fork hr rl ru rlt rrt)+  | hl < hr + 1 = balanceL rl ru (disjointMerge lt rlt) rrt+  | hr < hl + 1 = balanceR ll lu llt (disjointMerge lrt rt)+  | otherwise   = glue' lt hl ll lu llt lrt rt hr rl ru rlt rrt  -- Trees must be balanced with respect to eachother, since we pull from the tallest, no balancing is required {-# INLINEABLE glue #-}-glue :: Size -> RangeSet a -> RangeSet a -> RangeSet a-glue !_ Tip rt = rt-glue _ lt Tip  = lt-glue sz lt@(Fork lh lsz ll lu llt lrt) rt@(Fork rh rsz rl ru rlt rrt)-  | lh < rh = let (# !l, !u, !rt' #) = minDelete rsz rl ru rlt rrt in forkSz sz l u lt rt'-  | otherwise = let (# !l, !u, !lt' #) = maxDelete lsz ll lu llt lrt in forkSz sz l u lt' rt+glue :: RangeSet a -> RangeSet a -> RangeSet a+glue Tip rt = rt+glue lt Tip  = lt+glue lt@(Fork lh ll lu llt lrt) rt@(Fork rh rl ru rlt rrt) = glue' lt lh ll lu llt lrt rt rh rl ru rlt rrt +{-# INLINEABLE glue' #-}+glue' :: RangeSet a -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -> H -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+glue' lt lh ll lu llt lrt rt rh rl ru rlt rrt+  | lh < rh = let (# !l, !u, !rt' #) = minDelete rl ru rlt rrt in fork l u lt rt'+  | otherwise = let (# !l, !u, !lt' #) = maxDelete ll lu llt lrt in fork l u lt' rt

@@ -1,114 +1,109 @@ {-# LANGUAGE BangPatterns, Safe #-} module Data.RangeSet.Internal.SmartConstructors (     single,-    fork, forkSz, forkH,+    fork, forkH,     balance, balanceL, balanceR,     uncheckedBalanceL, uncheckedBalanceR   ) where  import Prelude import Data.RangeSet.Internal.Types-import Data.RangeSet.Internal.Enum  -- Basic tree constructors {-# INLINE single #-}-single :: Size -> E -> E -> RangeSet a-single !sz !l !u = Fork 1 sz l u Tip Tip+single :: E -> E -> RangeSet a+single !l !u = Fork 1 l u Tip Tip  {-# INLINE heightOfFork #-}-heightOfFork :: Int -> Int -> Int+heightOfFork :: H -> H -> H heightOfFork lh rh = max lh rh + 1  {-# INLINE fork #-} fork :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a-fork !l !u !lt !rt = forkSz (size lt + size rt + diffE l u) l u lt rt----{-# INLINE forkSz #-} -- this does bad things-forkSz :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-forkSz !sz !l !u !lt !rt = forkH sz l u (height lt) lt (height rt) rt+fork !l !u !lt !rt = forkH l u (height lt) lt (height rt) rt  {-# INLINE forkH #-}-forkH :: Size -> E -> E -> Int -> RangeSet a -> Int -> RangeSet a -> RangeSet a-forkH !sz !l !u !lh !lt !rh !rt =  Fork (heightOfFork lh rh) sz l u lt rt+forkH :: E -> E -> H -> RangeSet a -> H -> RangeSet a -> RangeSet a+forkH !l !u !lh !lt !rh !rt =  Fork (heightOfFork lh rh) l u lt rt  -- Balancers {-# NOINLINE balance #-}-balance :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-balance !sz !l !u Tip Tip = single sz l u-balance sz l u lt@(Fork lh lsz ll lu llt lrt) Tip-  | lh == 1   = Fork (lh + 1) sz l u lt Tip-  | otherwise = uncheckedBalanceL sz l u lsz ll lu llt lrt Tip-balance sz l u Tip rt@(Fork rh rsz rl ru rlt rrt)-  | rh == 1   = Fork (rh + 1) sz l u Tip rt-  | otherwise = uncheckedBalanceR sz l u Tip rsz rl ru rlt rrt-balance sz l u lt@(Fork lh lsz ll lu llt lrt) rt@(Fork rh rsz rl ru rlt rrt)-  | height lt > height rt + 1 = uncheckedBalanceL sz l u lsz ll lu llt lrt rt-  | height rt > height lt + 1 = uncheckedBalanceR sz l u lt rsz rl ru rlt rrt-  | otherwise = forkH sz l u lh lt rh rt+balance :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a+balance !l !u Tip Tip = single l u+balance l u lt@(Fork lh ll lu llt lrt) Tip+  | lh == 1   = Fork (lh + 1) l u lt Tip+  | otherwise = uncheckedBalanceL l u ll lu llt lrt Tip+balance l u Tip rt@(Fork rh rl ru rlt rrt)+  | rh == 1   = Fork (rh + 1) l u Tip rt+  | otherwise = uncheckedBalanceR l u Tip rl ru rlt rrt+balance l u lt@(Fork lh ll lu llt lrt) rt@(Fork rh rl ru rlt rrt)+  | height lt > height rt + 1 = uncheckedBalanceL l u ll lu llt lrt rt+  | height rt > height lt + 1 = uncheckedBalanceR l u lt rl ru rlt rrt+  | otherwise = forkH l u lh lt rh rt  {-# INLINEABLE balanceL #-}-balanceL :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+balanceL :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a -- PRE: left grew or right shrank, difference in height at most 2 biasing to the left-balanceL !sz !l1 !u1 lt@(Fork lh lsz l2 u2 llt lrt) !rt+balanceL !l1 !u1 lt@(Fork lh l2 u2 llt lrt) !rt   -- both sides are equal height or off by one-  | dltrt <= 1 = forkH sz l1 u1 lh lt rh rt+  | dltrt <= 1 = forkH l1 u1 lh lt rh rt   -- The bias is 2 (dltrt == 2)-  | otherwise  = uncheckedBalanceL sz l1 u1 lsz l2 u2 llt lrt rt+  | otherwise  = uncheckedBalanceL l1 u1 l2 u2 llt lrt rt   where     !rh = height rt-    !dltrt = lh - rh+    !dltrt = absDiff lh rh -- If the right shrank (or nothing changed), we have to be prepared to handle the Tip case for lt-balanceL sz l u Tip rt = Fork (height rt + 1) sz l u Tip rt+balanceL l u Tip rt = Fork (height rt + 1) l u Tip rt  {-# INLINEABLE balanceR #-}-balanceR :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+balanceR :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a -- PRE: left shrank or right grew, difference in height at most 2 biasing to the right-balanceR !sz !l1 !u1 !lt rt@(Fork rh rsz l2 u2 rlt rrt)+balanceR !l1 !u1 !lt rt@(Fork rh l2 u2 rlt rrt)   -- both sides are equal height or off by one-  | dltrt <= 1 = forkH sz l1 u1 lh lt rh rt-  | otherwise  = uncheckedBalanceR sz l1 u1 lt rsz l2 u2 rlt rrt+  | dltrt <= 1 = forkH l1 u1 lh lt rh rt+  | otherwise  = uncheckedBalanceR l1 u1 lt l2 u2 rlt rrt   where     !lh = height lt-    !dltrt = rh - lh+    !dltrt = absDiff rh lh -- If the left shrank (or nothing changed), we have to be prepared to handle the Tip case for rt-balanceR sz l u lt Tip = Fork (height lt + 1) sz l u lt Tip+balanceR l u lt Tip = Fork (height lt + 1) l u lt Tip  {-# NOINLINE uncheckedBalanceL #-} -- PRE: left grew or right shrank, difference in height at most 2 biasing to the left-uncheckedBalanceL :: Size -> E -> E -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -> RangeSet a-uncheckedBalanceL !sz !l1 !u1 !szl !l2 !u2 !llt !lrt !rt+uncheckedBalanceL :: E -> E -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -> RangeSet a+uncheckedBalanceL !l1 !u1 !l2 !u2 !llt !lrt !rt   -- The bias is 2 (dltrt == 2)-  | hllt >= hlrt = rotr' sz l1 u1 szl l2 u2 llt lrt rt-  | otherwise    = rotr sz l1 u1 (rotl szl l2 u2 llt lrt) rt+  | hllt >= hlrt = rotr' l1 u1 l2 u2 llt lrt rt+  | otherwise    = rotr l1 u1 (rotl l2 u2 llt lrt) rt   where     !hllt = height llt     !hlrt = height lrt  {-# NOINLINE uncheckedBalanceR #-}-uncheckedBalanceR :: Size -> E -> E -> RangeSet a -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+uncheckedBalanceR :: E -> E -> RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -- PRE: left shrank or right grew, difference in height at most 2 biasing to the right-uncheckedBalanceR !sz !l1 !u1 !lt !szr !l2 !u2 !rlt !rrt+uncheckedBalanceR !l1 !u1 !lt !l2 !u2 !rlt !rrt   -- The bias is 2 (drtlt == 2)-  | hrrt >= hrlt = rotl' sz l1 u1 lt szr l2 u2 rlt rrt-  | otherwise    = rotl sz l1 u1 lt (rotr szr l2 u2 rlt rrt)+  | hrrt >= hrlt = rotl' l1 u1 lt l2 u2 rlt rrt+  | otherwise    = rotl l1 u1 lt (rotr l2 u2 rlt rrt)   where     !hrlt = height rlt     !hrrt = height rrt  {-# INLINE rotr #-}-rotr :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-rotr !sz !l1 !u1 (Fork _ szl l2 u2 p q) !r = rotr' sz l1 u1 szl l2 u2 p q r-rotr _ _ _ _ _ = error "rotr on Tip"+rotr :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a+rotr !l1 !u1 (Fork _ l2 u2 p q) !r = rotr' l1 u1 l2 u2 p q r+rotr _ _ _ _ = error "rotr on Tip"  {-# INLINE rotl #-}-rotl :: Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-rotl !sz !l1 !u1 !p (Fork _ szr l2 u2 q r) = rotl' sz l1 u1 p szr l2 u2 q r-rotl _ _ _ _ _ = error "rotr on Tip"+rotl :: E -> E -> RangeSet a -> RangeSet a -> RangeSet a+rotl !l1 !u1 !p (Fork _ l2 u2 q r) = rotl' l1 u1 p l2 u2 q r+rotl _ _ _ _ = error "rotr on Tip"  {-# INLINE rotr' #-}-rotr' :: Size -> E -> E -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -> RangeSet a-rotr' !sz !l1 !u1 !szl !l2 !u2 !p !q !r = forkSz sz l2 u2 p (forkSz (sz - szl + size q) l1 u1 q r)+rotr' :: E -> E -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a -> RangeSet a+rotr' !l1 !u1 !l2 !u2 !p !q !r = fork l2 u2 p (fork l1 u1 q r)  {-# INLINE rotl' #-}-rotl' :: Size -> E -> E -> RangeSet a -> Size -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a-rotl' !sz !l1 !u1 !p !szr !l2 !u2 !q !r = forkSz sz l2 u2 (forkSz (sz - szr + size q) l1 u1 p q) r+rotl' :: E -> E -> RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+rotl' !l1 !u1 !p !l2 !u2 !q !r = fork l2 u2 (fork l1 u1 p q) r

@@ -6,79 +6,87 @@ import Data.RangeSet.Internal.Types import Data.RangeSet.Internal.SmartConstructors import Data.RangeSet.Internal.Inserters-import Data.RangeSet.Internal.Enum import Data.RangeSet.Internal.Lumpers  {-# INLINEABLE allLessE #-} allLessE :: E -> RangeSet a -> RangeSet a allLessE !_ Tip = Tip-allLessE x (Fork _ _ l u lt rt) = case compare x l of+allLessE x (Fork _ l u lt rt) = case compare x l of   EQ          -> lt   LT          -> allLessE x lt-  GT | x <= u -> unsafeInsertR (diffE l (pred x)) l (pred x) (allLessE x lt)+  GT | x <= u -> unsafeInsertR l (pred x) (allLessE x lt)   GT          -> link l u lt (allLessE x rt)  {-# INLINEABLE allMoreE #-} allMoreE :: E -> RangeSet a -> RangeSet a allMoreE !_ Tip = Tip-allMoreE x (Fork _ _ l u lt rt) = case compare u x of+allMoreE x (Fork _ l u lt rt) = case compare u x of   EQ          -> rt   LT          -> allMoreE x rt-  GT | l <= x -> unsafeInsertL (diffE (succ x) u) (succ x) u (allMoreE x rt)+  GT | l <= x -> unsafeInsertL (succ x) u (allMoreE x rt)   GT          -> link l u (allMoreE x lt) rt  {-# INLINEABLE split #-} split :: E -> E -> RangeSet a -> (# RangeSet a, RangeSet a #) split !_ !_ Tip = (# Tip, Tip #)-split l u (Fork _ _ l' u' lt rt)+split l u (Fork _ l' u' lt rt) = splitFork l u l' u' lt rt++{-# INLINEABLE splitFork #-}+splitFork :: E -> E -> E -> E -> RangeSet a -> RangeSet a -> (# RangeSet a, RangeSet a #)+splitFork l u l' u' lt rt   | u < l' = let (# !llt, !lgt #) = split l u lt in (# llt, link l' u' lgt rt #)   | u' < l = let (# !rlt, !rgt #) = split l u rt in (# link l' u' lt rlt, rgt #)   -- The ranges overlap in some way   | otherwise = let !lt' = case compare l' l of                       EQ -> lt-                      LT -> unsafeInsertR (diffE l' (pred l)) l' (pred l) lt+                      LT -> unsafeInsertR l' (pred l) lt                       GT -> allLessE l lt                     !rt' = case compare u u' of                       EQ -> rt-                      LT -> unsafeInsertL (diffE (succ u) u') (succ u) u' rt+                      LT -> unsafeInsertL (succ u) u' rt                       GT -> allMoreE u rt                 in (# lt', rt' #) -{-# INLINE splitOverlap #-}-splitOverlap :: E -> E -> RangeSet a -> (# RangeSet a, RangeSet a, RangeSet a #)-splitOverlap !l !u !t = let (# lt', rt' #) = split l u t in (# lt', overlapping l u t, rt' #)+{-# INLINE splitOverlapFork #-}+-- TODO: the double iteration here slows down intersection... can we fuse the iterations of split and overlapping?+splitOverlapFork :: E -> E -> E -> E -> RangeSet a -> RangeSet a -> (# RangeSet a, RangeSet a, RangeSet a #)+splitOverlapFork !l !u !l' !u' !lt !rt =+  let (# lt', rt' #) = splitFork l u l' u' lt rt  in (# lt', overlappingFork l u l' u' lt rt, rt' #)  {-# INLINABLE overlapping #-} overlapping :: E -> E -> RangeSet a -> RangeSet a overlapping !_ !_ Tip = Tip-overlapping x y (Fork _ sz l u lt rt) =+overlapping x y (Fork _ l u lt rt) = overlappingFork x y l u lt rt++{-# INLINABLE overlappingFork #-}+overlappingFork :: E -> E -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+overlappingFork x y l u lt rt =   case compare l x of     -- range is outside to the left     GT -> let !lt' = {-allMoreEqX-} overlapping x y lt           in case cmpY of                -- range is totally outside-               GT -> disjointLink nodeSz l u lt' rt'-               EQ -> unsafeInsertR nodeSz l u lt'-               LT | y >= l -> unsafeInsertR (diffE l y) l y lt'+               GT -> disjointLink l u lt' rt'+               EQ -> unsafeInsertR l u lt'+               LT | y >= l -> unsafeInsertR l y lt'                LT          -> lt' {-overlapping x y lt-}     -- range is inside on the left     EQ -> case cmpY of       -- range is outside on the right-      GT -> unsafeInsertL nodeSz l u rt'+      GT -> unsafeInsertL l u rt'       LT -> t'-      EQ -> single nodeSz l u+      EQ -> single l u     LT -> case cmpY of       -- range is outside on the right-      GT | x <= u -> unsafeInsertL (diffE x u) x u rt'+      GT | x <= u -> unsafeInsertL x u rt'       GT          -> rt' {-overlapping x y rt-}       _           -> t'   where     !cmpY = compare y u-    !nodeSz = sz - size lt - size rt     -- leave lazy!     rt' = {-allLessEqY-} overlapping x y rt     t' :: RangeSet a-    t' = single (diffE x y) x y+    t' = single x y      {-allLessEqY Tip = Tip     allLessEqY (Fork _ sz l u lt rt) = case compare y l of

@@ -6,31 +6,26 @@ import Control.Applicative (liftA2)  import Data.RangeSet.Internal.Types-import Data.RangeSet.Internal.Enum (diffE)  -- Testing Utilities valid :: RangeSet a -> Bool-valid t = balanced t && wellSized t && orderedNonOverlappingAndCompressed True t+valid t = balanced t && orderedNonOverlappingAndCompressed True t  balanced :: RangeSet a -> Bool balanced Tip = True-balanced (Fork h _ _ _ lt rt) =+balanced (Fork h _ _ lt rt) =   h == max (height lt) (height rt) + 1 &&   height rt < h &&-  abs (height lt - height rt) <= 1 &&+  absDiff (height lt) (height rt) <= 1 &&   balanced lt &&   balanced rt -wellSized :: RangeSet a -> Bool-wellSized Tip = True-wellSized (Fork _ sz l u lt rt) = sz == size lt + size rt + diffE l u && wellSized lt && wellSized rt- orderedNonOverlappingAndCompressed :: Bool -> RangeSet a -> Bool orderedNonOverlappingAndCompressed checkCompressed = bounded (const True) (const True)   where     bounded :: (E -> Bool) -> (E -> Bool) -> RangeSet a -> Bool     bounded _ _ Tip = True-    bounded lo hi (Fork _ _ l u lt rt) =+    bounded lo hi (Fork _ l u lt rt) =       l <= u &&       lo l &&       hi u &&

@@ -1,67 +0,0 @@-{-# LANGUAGE DerivingStrategies, RoleAnnotations, CPP, Trustworthy #-}-#if __GLASGOW_HASKELL__ > 900-{-# LANGUAGE UnliftedDatatypes #-}-#endif-module Data.RangeSet.Internal.Types (module Data.RangeSet.Internal.Types) where--import Prelude--#if __GLASGOW_HASKELL__ > 900-import GHC.Exts (UnliftedType)-#endif--type Size = Int-type E = Int-{-|-A @Set@ type designed for types that are `Enum` as well as `Ord`. This allows the `RangeSet` to-compress the data when it is contiguous, reducing memory-footprint and enabling otherwise impractical-operations like `complement` for `Bounded` types.--@since 0.0.1.0--}-data RangeSet a = Fork {-# UNPACK #-} !Int {-# UNPACK #-} !Size {-# UNPACK #-} !E {-# UNPACK #-} !E !(RangeSet a) !(RangeSet a)-                | Tip-                deriving stock Show-type role RangeSet nominal--{-|-Return the number of /elements/ in the set.--@since 0.0.1.0--}-{-# INLINE size #-}-size :: RangeSet a -> Int-size Tip = 0-size (Fork _ sz _ _ _ _) = sz--{-# INLINE height #-}-height :: RangeSet a -> Int-height Tip = 0-height (Fork h _ _ _ _ _) = h--{-# INLINEABLE foldE #-}-foldE :: (E -> E -> b -> b -> b) -- ^ Function that combines the lower and upper values (inclusive) for a range with the folded left- and right-subtrees.-      -> b                       -- ^ Value to be substituted at the leaves.-      -> RangeSet a-      -> b-foldE _ tip Tip = tip-foldE fork tip (Fork _ _ l u lt rt) = fork l u (foldE fork tip lt) (foldE fork tip rt)--#if __GLASGOW_HASKELL__ > 900-type StrictMaybeE :: UnliftedType-#endif-data StrictMaybeE = SJust {-# UNPACK #-} !E | SNothing--#if __GLASGOW_HASKELL__ > 900-type SRangeList :: UnliftedType-#endif-data SRangeList = SRangeCons {-# UNPACK #-} !E {-# UNPACK #-} !E !SRangeList | SNil---- Instances-instance Eq (RangeSet a) where-  {-# INLINABLE (==) #-}-  t1 == t2 = size t1 == size t2 && ranges t1 == ranges t2-    where-      {-# INLINE ranges #-}-      ranges :: RangeSet a -> [(E, E)]-      ranges t = foldE (\l u lt rt -> lt . ((l, u) :) . rt) id t []

@@ -0,0 +1,9 @@+{-# LANGUAGE BangPatterns, MagicHash, Unsafe #-}+module Data.RangeSet.Internal.Unsafe (ptrEq) where++import Prelude+import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)++{-# INLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq !x !y = isTrue# (reallyUnsafePtrEquality# x y)

@@ -24,7 +24,7 @@   where     !x' = fromEnum x     go :: RangeSet a -> Bool-    go (Fork _ _ l u lt rt)+    go (Fork _ l u lt rt)       | l <= x'   = x' <= u || go rt       | otherwise = go lt     go Tip = False

@@ -10,51 +10,67 @@  @since 0.0.1.0 -}-{-# INLINABLE union #-}-union :: Enum a => RangeSet a -> RangeSet a -> RangeSet a-union t Tip = t-union Tip t = t-union t@(Fork _ _ l u lt rt) t' = case split l u t' of-  (# lt', rt' #)-    | stayedSame lt ltlt', stayedSame rt rtrt' -> t-    | otherwise                                -> link l u ltlt' rtrt'-    where !ltlt' = lt `union` lt'-          !rtrt' = rt `union` rt'+union :: RangeSet a -> RangeSet a -> RangeSet a+union = optimalForHeight+  where+    optimalForHeight :: RangeSet a -> RangeSet a -> RangeSet a+    optimalForHeight t Tip =  t+    optimalForHeight Tip t = t+    optimalForHeight lt@(Fork lh ll lu llt lrt) rt@(Fork rh rl ru rlt rrt)+      | lh < rh = doUnion rt rl ru rlt rrt ll lu llt lrt+      | otherwise = doUnion lt ll lu llt lrt rl ru rlt rrt +    doUnion :: RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+    doUnion t ll lu llt lrt rl ru rlt rrt = case splitFork ll lu rl ru rlt rrt of+      (# lt', rt' #)+        | stayedSame llt ltlt', stayedSame lrt rtrt' -> t+        | otherwise                                  -> link ll lu ltlt' rtrt'+        where !ltlt' = llt `optimalForHeight` lt'+              !rtrt' = lrt `optimalForHeight` rt'+ {-| Intersects two sets such that an element appears in the result if and only if it is present in both of the provided sets.  @since 0.0.1.0 -}-{-# INLINABLE intersection #-}-intersection :: Enum a => RangeSet a -> RangeSet a -> RangeSet a-intersection Tip _ = Tip-intersection _ Tip = Tip-intersection t1@(Fork _ _ l1 u1 lt1 rt1) t2 =-  case overlap of-    Tip -> disjointMerge lt1lt2 rt1rt2-    Fork 1 sz x y _ _-      | x == l1, y == u1-      , stayedSame lt1 lt1lt2, stayedSame rt1 rt1rt2 -> t1-      | otherwise -> disjointLink sz x y lt1lt2 rt1rt2-    Fork _ sz x y lt' rt' -> disjointLink (sz - size lt' - size rt') x y (disjointMerge lt1lt2 lt') (disjointMerge rt' rt1rt2)+intersection :: RangeSet a -> RangeSet a -> RangeSet a+intersection = optimalForHeight   where-    (# !lt2, !overlap, !rt2 #) = splitOverlap l1 u1 t2-    !lt1lt2 = intersection lt1 lt2-    !rt1rt2 = intersection rt1 rt2+    -- until splitOverlapFork is optimised, this picks the best configuration for performance+    -- this is because more work is done on the right tree than the left tree, so making the+    -- right tree the shallowest saves work in long run+    optimalForHeight :: RangeSet a -> RangeSet a -> RangeSet a+    optimalForHeight Tip _ = Tip+    optimalForHeight _ Tip = Tip+    optimalForHeight lt@(Fork lh ll lu llt lrt) rt@(Fork rh rl ru rlt rrt)+      | lh < rh = doIntersect rt rl ru rlt rrt ll lu llt lrt+      | otherwise = doIntersect lt ll lu llt lrt rl ru rlt rrt +    doIntersect :: RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> E -> E -> RangeSet a -> RangeSet a -> RangeSet a+    doIntersect !lt !ll !lu !llt !lrt !rl !ru !rlt !rrt =+      case overlap of+        Tip -> disjointMerge lltrlt lrtrrt+        Fork 1 x y _ _+          | x == ll, y == lu+          , stayedSame llt lltrlt, stayedSame lrt lrtrrt -> lt+          | otherwise -> disjointLink x y lltrlt lrtrrt+        Fork _ x y lt' rt' -> disjointLink x y (disjointMerge lltrlt lt') (disjointMerge rt' lrtrrt)+      where+        (# !lt', !overlap, !rt' #) = splitOverlapFork ll lu rl ru rlt rrt+        !lltrlt = optimalForHeight llt lt'+        !lrtrrt = optimalForHeight lrt rt'+ {-| Do two sets have no elements in common?  @since 0.0.1.0 -}-{-# INLINE disjoint #-}-disjoint :: Enum a => RangeSet a -> RangeSet a -> Bool+disjoint :: RangeSet a -> RangeSet a -> Bool disjoint Tip _ = True disjoint _ Tip = True-disjoint (Fork _ _ l u lt rt) t = case splitOverlap l u t of-  (# lt', Tip, rt' #) -> disjoint lt lt' && disjoint rt rt'+disjoint (Fork _ ll lu llt lrt) (Fork _ rl ru rlt rrt) = case splitOverlapFork ll lu rl ru rlt rrt of+  (# lt', Tip, rt' #) -> disjoint llt lt' && disjoint lrt rt'   _                   -> False  {-|@@ -62,14 +78,11 @@  @since 0.0.1.0 -}-{-# INLINEABLE difference #-}-difference :: Enum a => RangeSet a -> RangeSet a -> RangeSet a+difference :: RangeSet a -> RangeSet a -> RangeSet a difference Tip _ = Tip difference t Tip = t-difference t (Fork _ _ l u lt rt) = case split l u t of-  (# lt', rt' #)-    | size lt'lt + size rt'rt == size t -> t-    | otherwise -> disjointMerge lt'lt rt'rt+difference (Fork _ ll lu llt lrt) (Fork _ rl ru rlt rrt) = case splitFork rl ru ll lu llt lrt of+  (# lt', rt' #) -> disjointMerge lt'lt rt'rt     where-      !lt'lt = difference lt' lt-      !rt'rt = difference rt' rt+      !lt'lt = difference lt' rlt+      !rt'rt = difference rt' rrt