Created
May 11, 2024 06:46
-
-
Save kindaro/7f39d9be7cb9dfed77fd1301ba773f62 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
diff --git a/src/Data/IntervalSet/ByteString.hs b/src/Data/IntervalSet/ByteString.hs | |
index 0e569e5..de3a7e8 100644 | |
--- a/src/Data/IntervalSet/ByteString.hs | |
+++ b/src/Data/IntervalSet/ByteString.hs | |
@@ -24,6 +24,7 @@ import qualified Data.ByteString as BS | |
import qualified Data.ByteString.Internal as BS | |
import Control.Monad as CM | |
import Foreign | |
+import System.IO.Unsafe | |
import Data.IntervalSet.Internal as S | |
@@ -45,7 +46,7 @@ import Data.IntervalSet.Internal as S | |
fromByteString :: ByteString -> IntSet | |
fromByteString bs = | |
let (fptr, off, len) = BS.toForeignPtr bs in | |
- BS.inlinePerformIO $ withForeignPtr fptr $ \_ptr -> do | |
+ unsafePerformIO $ withForeignPtr fptr $ \_ptr -> do | |
let ptr = _ptr `advancePtr` off | |
let !s = goFrom (castPtr ptr) len | |
return $! s | |
@@ -57,7 +58,7 @@ fromByteString bs = | |
go :: Int -> IntSet -> IntSet | |
go !x !acc | |
| x + wordSize <= len = do | |
- let !bm = BS.inlinePerformIO (peekByteOff ptr x) -- TODO read little endian | |
+ let !bm = unsafePerformIO (peekByteOff ptr x) -- TODO read little endian | |
let !s = unionBM (x * wordSize) bm acc | |
go (x + wordSize) s | |
| otherwise = goBytes x acc | |
@@ -67,7 +68,7 @@ fromByteString bs = | |
goBytes :: Int -> IntSet -> IntSet | |
goBytes !i !s | |
| i < len = | |
- let wbm = BS.inlinePerformIO (peekByteOff ptr i) | |
+ let wbm = unsafePerformIO (peekByteOff ptr i) | |
s' = foldrWord (i * 8) insert s wbm | |
in goBytes (i + 1) s' | |
| otherwise = s | |
@@ -88,7 +89,7 @@ fromByteString bs = | |
bin px msk (goTree l mid) (goTree mid r) | |
| r - l == wordSize = | |
- let bm = BS.inlinePerformIO (peekByteOff ptr l) | |
+ let bm = unsafePerformIO (peekByteOff ptr l) | |
in tip (l * wordSize) bm | |
| otherwise = goBytes l r empty | |
diff --git a/src/Data/IntervalSet/Internal.hs b/src/Data/IntervalSet/Internal.hs | |
index 00b7900..d3b5600 100644 | |
--- a/src/Data/IntervalSet/Internal.hs | |
+++ b/src/Data/IntervalSet/Internal.hs | |
@@ -8,6 +8,7 @@ | |
-- See documentation for module header in Data.IntSet.Buddy. | |
-- | |
{-# LANGUAGE CPP #-} | |
+{-# LANGUAGE DeriveGeneric #-} | |
#if __GLASGOW_HASKELL__ | |
{-# LANGUAGE DeriveDataTypeable #-} | |
@@ -125,6 +126,7 @@ import qualified Data.List as L | |
import Data.Monoid | |
import Data.Ord | |
import Data.Word | |
+import GHC.Generics (Generic) | |
-- machine specific properties of basic types | |
@@ -201,7 +203,7 @@ data IntSet | |
deriving | |
( Eq | |
#if defined(__GLASGOW_HASKELL__) | |
- , Typeable, Data | |
+ , Typeable, Data, Generic | |
#endif | |
) | |
@@ -266,9 +268,11 @@ instance Ord IntSet where | |
compare = comparing toList | |
-- TODO make it faster | |
+instance Semigroup IntSet where | |
+ (<>) = union | |
+ | |
instance Monoid IntSet where | |
mempty = empty | |
- mappend = union | |
mconcat = unions | |
instance Num IntSet where | |
@@ -298,9 +302,11 @@ instance NFData IntSet where | |
newtype Union = Union { getUnion :: IntSet } | |
deriving (Show, Read, Eq, Ord) | |
+instance Semigroup Union where | |
+ a <> b = Union (getUnion a `union` getUnion b) | |
+ | |
instance Monoid Union where | |
mempty = Union empty | |
- mappend a b = Union (getUnion a `union` getUnion b) | |
mconcat = Union . unions . L.map getUnion | |
-- | Monoid under 'intersection'. | |
@@ -310,9 +316,11 @@ instance Monoid Union where | |
newtype Intersection = Intersection { getIntersection :: IntSet } | |
deriving (Show, Read, Eq, Ord) | |
+instance Semigroup Intersection where | |
+ a <> b = Intersection (getIntersection a `intersection` getIntersection b) | |
+ | |
instance Monoid Intersection where | |
mempty = Intersection universe | |
- mappend a b = Intersection (getIntersection a `intersection` getIntersection b) | |
mconcat = Intersection . intersections . L.map getIntersection | |
-- | Monoid under 'symDiff'. | |
@@ -322,9 +330,11 @@ instance Monoid Intersection where | |
newtype Difference = Difference { getDifference :: IntSet } | |
deriving (Show, Read, Eq, Ord) | |
+instance Semigroup Difference where | |
+ a <> b = Difference (getDifference a `symDiff` getDifference b) | |
+ | |
instance Monoid Difference where | |
mempty = Difference empty | |
- mappend a b = Difference (getDifference a `symDiff` getDifference b) | |
{-------------------------------------------------------------------- | |
Query | |
@@ -591,9 +601,9 @@ union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | |
| zero p1 m2 = binI p2 m2 (t1 `union` l2) r2 | |
| otherwise = binI p2 m2 l2 (t1 `union` r2) | |
-union t@ Bin {} (Tip p bm) = insertBM p bm t | |
-union t@ Bin {} (Fin p m ) = insertFin p m t | |
-union t@ Bin {} Nil = t | |
+union t@Bin {} (Tip p bm) = insertBM p bm t | |
+union t@Bin {} (Fin p m ) = insertFin p m t | |
+union t@Bin {} Nil = t | |
union (Fin p m ) t = insertFin p m t | |
union (Tip p bm) t = insertBM p bm t | |
union Nil t = t | |
@@ -667,8 +677,8 @@ intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | |
| zero p1 m2 = intersection t1 l2 | |
| otherwise = intersection t1 r2 | |
-intersection t@ Bin {} (Tip p bm) = intersectBM p bm t | |
-intersection t@ Bin {} (Fin p m) = intersectFin p m t | |
+intersection t@Bin {} (Tip p bm) = intersectBM p bm t | |
+intersection t@Bin {} (Fin p m) = intersectFin p m t | |
intersection Bin {} Nil = Nil | |
intersection (Tip p bm) t = intersectBM p bm t | |
intersection (Fin p m) t = intersectFin p m t | |
@@ -752,7 +762,7 @@ difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | |
| zero p1 m2 = difference t1 l2 | |
| otherwise = difference t1 r2 | |
-difference t1@ Bin {} (Tip p bm) = deleteBM p bm t1 | |
+difference t1@Bin {} (Tip p bm) = deleteBM p bm t1 | |
difference t1@(Bin p1 m1 _ _) (Fin p2 m2) | |
| m1 `shorter` finMask m2 | |
= if match p2 p1 m1 | |
@@ -767,13 +777,13 @@ difference t1@(Bin p1 m1 _ _) (Fin p2 m2) | |
| p1 == p2 = Nil | |
| otherwise = t1 | |
-difference t1@ Bin {} Nil = t1 | |
+difference t1@Bin {} Nil = t1 | |
difference t1@(Tip p _ ) (Bin p2 m2 l r) | |
| nomatch p p2 m2 = t1 | |
| zero p m2 = difference t1 l | |
| otherwise = difference t1 r | |
-difference t1@ Tip {} (Tip p bm) = deleteBM p bm t1 | |
+difference t1@Tip {} (Tip p bm) = deleteBM p bm t1 | |
difference t1@(Tip p1 _) (Fin p2 m2 ) -- | |
| nomatch p1 p2 (finMask m2) = t1 -- | |
| otherwise = Nil -- | |
@@ -844,9 +854,9 @@ symDiff t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | |
| zero p1 m2 = bin p2 m2 (symDiff l2 t1) r2 -- TODO tune (symDiff l1 t2) | |
| otherwise = bin p2 m2 l2 (symDiff r2 t1) | |
-symDiff t1@ Bin {} (Tip p2 bm2 ) = symDiffTip p2 bm2 t1 | |
-symDiff t1@ Bin {} (Fin p2 m2 ) = symDiffFin p2 m2 t1 | |
-symDiff t1@ Bin {} Nil = t1 | |
+symDiff t1@Bin {} (Tip p2 bm2 ) = symDiffTip p2 bm2 t1 | |
+symDiff t1@Bin {} (Fin p2 m2 ) = symDiffFin p2 m2 t1 | |
+symDiff t1@Bin {} Nil = t1 | |
symDiff (Tip p1 bm1 ) t2 = symDiffTip p1 bm1 t2 | |
symDiff (Fin p1 m1 ) t2 = symDiffFin p1 m1 t2 | |
symDiff Nil t2 = t2 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment