{-# LANGUAGE CPP #-}
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK not-home #-}
module Data.Struct.Internal.Label where
import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Bits
import Data.Struct.Internal
import Data.Word
#ifdef HLINT
{-# ANN module "HLint: ignore Eta reduce" #-}
#endif
type Key = Word64
midBound :: Key
midBound :: Key
midBound = Key -> Int -> Key
forall a. Bits a => a -> Int -> a
unsafeShiftR Key
forall a. Bounded a => a
maxBound Int
1
key :: Field Label Key
key :: Field Label Key
key = Int -> Field Label Key
forall k (s :: k) a. Int -> Field s a
field Int
0
{-# INLINE key #-}
next :: Slot Label Label
next :: Slot Label Label
next = Int -> Slot Label Label
forall k1 k2 (s :: k1) (t :: k2). Int -> Slot s t
slot Int
1
{-# INLINE next #-}
prev :: Slot Label Label
prev :: Slot Label Label
prev = Int -> Slot Label Label
forall k1 k2 (s :: k1) (t :: k2). Int -> Slot s t
slot Int
2
{-# INLINE prev #-}
newtype Label s = Label (Object s)
instance Eq (Label s) where == :: Label s -> Label s -> Bool
(==) = Label s -> Label s -> Bool
forall (t :: * -> *) s. Struct t => t s -> t s -> Bool
eqStruct
instance Struct Label
makeLabel :: PrimMonad m => Key -> Label (PrimState m) -> Label (PrimState m) -> m (Label (PrimState m))
makeLabel :: Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel Key
a Label (PrimState m)
p Label (PrimState m)
n = ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m)))
-> ST (PrimState m) (Label (PrimState m))
-> m (Label (PrimState m))
forall a b. (a -> b) -> a -> b
$ do
Label (PrimState m)
this <- Int -> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (t :: * -> *).
(PrimMonad m, Struct t) =>
Int -> m (t (PrimState m))
alloc Int
3
Field Label Key
-> Label (PrimState (ST (PrimState m)))
-> Key
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field Label Key
key Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Key
a
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState m)
Label (PrimState (ST (PrimState m)))
p
Label (PrimState m) -> ST (PrimState m) (Label (PrimState m))
forall (m :: * -> *) a. Monad m => a -> m a
return Label (PrimState m)
this
{-# INLINE makeLabel #-}
new :: PrimMonad m => m (Label (PrimState m))
new :: m (Label (PrimState m))
new = Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel Key
midBound Label (PrimState m)
forall (t :: * -> *) s. Struct t => t s
Nil Label (PrimState m)
forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE new #-}
delete :: PrimMonad m => Label (PrimState m) -> m ()
delete :: Label (PrimState m) -> m ()
delete Label (PrimState m)
this = ST (PrimState m) () -> m ()
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
Label (PrimState m)
p <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Label (PrimState m)
n <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
p) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
p Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n Label (PrimState m)
Label (PrimState (ST (PrimState m)))
p
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE delete #-}
insertAfter :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))
insertAfter :: Label (PrimState m) -> m (Label (PrimState m))
insertAfter Label (PrimState m)
this = ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m)))
-> ST (PrimState m) (Label (PrimState m))
-> m (Label (PrimState m))
forall a b. (a -> b) -> a -> b
$ do
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ NullPointerException -> ST (PrimState m) ()
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Key
v0 <- Field Label Key
-> Label (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Label (PrimState m)
n <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Key
v1 <- if Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n
then Key -> ST (PrimState m) Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
forall a. Bounded a => a
maxBound
else Field Label Key
-> Label (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n
Label (PrimState m)
fresh <- Key
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *).
PrimMonad m =>
Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel (Key
v0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key -> Int -> Key
forall a. Bits a => a -> Int -> a
unsafeShiftR (Key
v1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
v0) Int
1) Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState m)
Label (PrimState (ST (PrimState m)))
fresh
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n Label (PrimState m)
Label (PrimState (ST (PrimState m)))
fresh
Label (PrimState m)
-> Key -> Label (PrimState m) -> Key -> ST (PrimState m) ()
forall s. Label s -> Key -> Label s -> Key -> ST s ()
growRight Label (PrimState m)
this Key
v0 Label (PrimState m)
n Key
2
Label (PrimState m) -> ST (PrimState m) (Label (PrimState m))
forall (m :: * -> *) a. Monad m => a -> m a
return Label (PrimState m)
fresh
where
growRight :: Label s -> Key -> Label s -> Word64 -> ST s ()
growRight :: Label s -> Key -> Label s -> Key -> ST s ()
growRight !Label s
n0 !Key
_ Label s
Nil !Key
j = Label s -> Key -> ST s ()
forall s. Label s -> Key -> ST s ()
growLeft Label s
n0 Key
j
growRight Label s
n0 Key
v0 Label s
nj Key
j = do
Key
vj <- Field Label Key -> Label (PrimState (ST s)) -> ST s Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label s
Label (PrimState (ST s))
nj
if Key
vjKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
v0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
jKey -> Key -> Key
forall a. Num a => a -> a -> a
*Key
j
then do
Label s
nj' <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label s
Label (PrimState (ST s))
nj
Label s -> Key -> Label s -> Key -> ST s ()
forall s. Label s -> Key -> Label s -> Key -> ST s ()
growRight Label s
n0 Key
v0 Label s
nj' (Key
jKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1)
else do
Label s
n1 <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label s
Label (PrimState (ST s))
n0
Label s -> Key -> Key -> Key -> ST s ()
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
n1 Key
v0 (Key -> Key -> Key
delta (Key
vjKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
v0) Key
j) Key
j
growLeft :: Label s -> Word64 -> ST s ()
growLeft :: Label s -> Key -> ST s ()
growLeft !Label s
c !Key
j = do
Label s
p <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
prev Label s
Label (PrimState (ST s))
c
if Label s -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
p
then Label s -> Key -> Key -> Key -> ST s ()
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
c Key
0 (Key -> Key -> Key
delta Key
forall a. Bounded a => a
maxBound Key
j) Key
j
else do
Key
vp <- Field Label Key -> Label (PrimState (ST s)) -> ST s Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label s
Label (PrimState (ST s))
p
Label s
p' <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
prev Label s
Label (PrimState (ST s))
p
let !j' :: Key
j' = Key
jKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1
if Key
forall a. Bounded a => a
maxBound Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
vp Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
j'Key -> Key -> Key
forall a. Num a => a -> a -> a
*Key
j'
then Label s -> Key -> ST s ()
forall s. Label s -> Key -> ST s ()
growLeft Label s
p' Key
j'
else Label s -> Key -> Key -> Key -> ST s ()
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
c Key
vp (Key -> Key -> Key
delta (Key
forall a. Bounded a => a
maxBoundKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
vp) Key
j') Key
j'
balance :: Label s -> Key -> Key -> Word64 -> ST s ()
balance :: Label s -> Key -> Key -> Key -> ST s ()
balance !Label s
_ !Key
_ !Key
_ Key
0 = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
balance Label s
Nil Key
_ Key
_ Key
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
balance Label s
c Key
v Key
dv Key
j = do
let !v' :: Key
v' = Key
v Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
dv
Field Label Key -> Label (PrimState (ST s)) -> Key -> ST s ()
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field Label Key
key Label s
Label (PrimState (ST s))
c Key
v'
Label s
n <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label s
Label (PrimState (ST s))
c
Label s -> Key -> Key -> Key -> ST s ()
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
n Key
v' Key
dv (Key
jKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1)
{-# INLINE insertAfter #-}
cutAfter :: PrimMonad m => Label (PrimState m) -> m ()
cutAfter :: Label (PrimState m) -> m ()
cutAfter Label (PrimState m)
this = ST (PrimState m) () -> m ()
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ NullPointerException -> ST (PrimState m) ()
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Label (PrimState m)
n <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE cutAfter #-}
cutBefore :: PrimMonad m => Label (PrimState m) -> m ()
cutBefore :: Label (PrimState m) -> m ()
cutBefore Label (PrimState m)
this = ST (PrimState m) () -> m ()
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ NullPointerException -> ST (PrimState m) ()
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Label (PrimState m)
p <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
p) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
p Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot Label Label
prev Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this Label (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE cutBefore #-}
least :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))
least :: Label (PrimState m) -> m (Label (PrimState m))
least Label (PrimState m)
xs0
| Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
xs0 = NullPointerException -> m (Label (PrimState m))
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m)))
-> ST (PrimState m) (Label (PrimState m))
-> m (Label (PrimState m))
forall a b. (a -> b) -> a -> b
$ Label (PrimState m) -> ST (PrimState m) (Label (PrimState m))
forall s. Label s -> ST s (Label s)
go Label (PrimState m)
xs0 where
go :: Label s -> ST s (Label s)
go :: Label s -> ST s (Label s)
go Label s
this = do
Label s
p <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
prev Label s
Label (PrimState (ST s))
this
if Label s -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
p
then Label s -> ST s (Label s)
forall (m :: * -> *) a. Monad m => a -> m a
return Label s
this
else Label s -> ST s (Label s)
forall s. Label s -> ST s (Label s)
go Label s
p
{-# INLINE least #-}
greatest :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))
greatest :: Label (PrimState m) -> m (Label (PrimState m))
greatest Label (PrimState m)
xs0
| Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
xs0 = NullPointerException -> m (Label (PrimState m))
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Label (PrimState m)) -> m (Label (PrimState m)))
-> ST (PrimState m) (Label (PrimState m))
-> m (Label (PrimState m))
forall a b. (a -> b) -> a -> b
$ Label (PrimState m) -> ST (PrimState m) (Label (PrimState m))
forall s. Label s -> ST s (Label s)
go Label (PrimState m)
xs0 where
go :: Label s -> ST s (Label s)
go :: Label s -> ST s (Label s)
go Label s
this = do
Label s
n <- Slot Label Label
-> Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label s
Label (PrimState (ST s))
this
if Label s -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
n
then Label s -> ST s (Label s)
forall (m :: * -> *) a. Monad m => a -> m a
return Label s
this
else Label s -> ST s (Label s)
forall s. Label s -> ST s (Label s)
go Label s
n
{-# INLINE greatest #-}
compareM :: PrimMonad m => Label (PrimState m) -> Label (PrimState m) -> m Ordering
compareM :: Label (PrimState m) -> Label (PrimState m) -> m Ordering
compareM Label (PrimState m)
i Label (PrimState m)
j
| Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
i Bool -> Bool -> Bool
|| Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
j = NullPointerException -> m Ordering
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = Key -> Key -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Key -> Key -> Ordering) -> m Key -> m (Key -> Ordering)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field Label Key -> Label (PrimState m) -> m Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
i m (Key -> Ordering) -> m Key -> m Ordering
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field Label Key -> Label (PrimState m) -> m Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
j
{-# INLINE compareM #-}
delta :: Key -> Word64 -> Key
delta :: Key -> Key -> Key
delta Key
m Key
j = Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
1 (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Integral a => a -> a -> a
quot Key
m (Key
jKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1)
{-# INLINE delta #-}
value :: PrimMonad m => Label (PrimState m) -> m Key
value :: Label (PrimState m) -> m Key
value Label (PrimState m)
this = Field Label Key -> Label (PrimState m) -> m Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
this
{-# INLINE value #-}
keys :: PrimMonad m => Label (PrimState m) -> m [Key]
keys :: Label (PrimState m) -> m [Key]
keys Label (PrimState m)
this = ST (PrimState m) [Key] -> m [Key]
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) [Key] -> m [Key])
-> ST (PrimState m) [Key] -> m [Key]
forall a b. (a -> b) -> a -> b
$
if Label (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this
then [Key] -> ST (PrimState m) [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Key
x <- Field Label Key
-> Label (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
Label (PrimState m)
n <- Slot Label Label
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot Label Label
next Label (PrimState m)
Label (PrimState (ST (PrimState m)))
this
[Key]
xs <- Label (PrimState (ST (PrimState m))) -> ST (PrimState m) [Key]
forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m [Key]
keys Label (PrimState m)
Label (PrimState (ST (PrimState m)))
n
[Key] -> ST (PrimState m) [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
xKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
xs)
{-# INLINE keys #-}