{-# 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 = forall a. Bits a => a -> Int -> a
unsafeShiftR forall a. Bounded a => a
maxBound Int
1
key :: Field Label Key
key :: Field Label Key
key = forall {k} (s :: k) a. Int -> Field s a
field Int
0
{-# INLINE key #-}
next :: Slot Label Label
next :: Slot Label Label
next = 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 = 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
(==) = 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 :: forall (m :: * -> *).
PrimMonad m =>
Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel Key
a Label (PrimState m)
p Label (PrimState m)
n = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ do
Label (PrimState m)
this <- forall (m :: * -> *) (t :: * -> *).
(PrimMonad m, Struct t) =>
Int -> m (t (PrimState m))
alloc Int
3
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field Label Key
key Label (PrimState m)
this Key
a
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)
this Label (PrimState m)
n
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)
this Label (PrimState m)
p
forall (m :: * -> *) a. Monad m => a -> m a
return Label (PrimState m)
this
{-# INLINE makeLabel #-}
new :: PrimMonad m => m (Label (PrimState m))
new :: forall (m :: * -> *). PrimMonad m => m (Label (PrimState m))
new = forall (m :: * -> *).
PrimMonad m =>
Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel Key
midBound forall (t :: * -> *) s. Struct t => t s
Nil forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE new #-}
delete :: PrimMonad m => Label (PrimState m) -> m ()
delete :: forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m ()
delete Label (PrimState m)
this = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) forall a b. (a -> b) -> a -> b
$ do
Label (PrimState m)
p <- 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)
this
Label (PrimState m)
n <- 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)
this
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
p) forall a b. (a -> b) -> a -> b
$ do
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)
p Label (PrimState m)
n
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)
this forall (t :: * -> *) s. Struct t => t s
Nil
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) forall a b. (a -> b) -> a -> b
$ do
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)
n Label (PrimState m)
p
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)
this forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE delete #-}
insertAfter :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))
insertAfter :: forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> m (Label (PrimState m))
insertAfter Label (PrimState m)
this = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Key
v0 <- 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
Label (PrimState m)
n <- 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)
this
Key
v1 <- if forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Bounded a => a
maxBound
else forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label (PrimState m)
n
Label (PrimState m)
fresh <- forall (m :: * -> *).
PrimMonad m =>
Key
-> Label (PrimState m)
-> Label (PrimState m)
-> m (Label (PrimState m))
makeLabel (Key
v0 forall a. Num a => a -> a -> a
+ forall a. Bits a => a -> Int -> a
unsafeShiftR (Key
v1 forall a. Num a => a -> a -> a
- Key
v0) Int
1) Label (PrimState m)
this Label (PrimState m)
n
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)
this Label (PrimState m)
fresh
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) forall a b. (a -> b) -> a -> b
$ 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)
n Label (PrimState m)
fresh
forall s. Label s -> Key -> Label s -> Key -> ST s ()
growRight Label (PrimState m)
this Key
v0 Label (PrimState m)
n Key
2
forall (m :: * -> *) a. Monad m => a -> m a
return Label (PrimState m)
fresh
where
growRight :: Label s -> Key -> Label s -> Word64 -> ST s ()
growRight :: forall s. Label s -> Key -> Label s -> Key -> ST s ()
growRight !Label s
n0 !Key
_ Label s
Nil !Key
j = 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 <- forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label s
nj
if Key
vjforall a. Num a => a -> a -> a
-Key
v0 forall a. Ord a => a -> a -> Bool
< Key
jforall a. Num a => a -> a -> a
*Key
j
then do
Label s
nj' <- 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
nj
forall s. Label s -> Key -> Label s -> Key -> ST s ()
growRight Label s
n0 Key
v0 Label s
nj' (Key
jforall a. Num a => a -> a -> a
+Key
1)
else do
Label s
n1 <- 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
n0
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
n1 Key
v0 (Key -> Key -> Key
delta (Key
vjforall a. Num a => a -> a -> a
-Key
v0) Key
j) Key
j
growLeft :: Label s -> Word64 -> ST s ()
growLeft :: forall s. Label s -> Key -> ST s ()
growLeft !Label s
c !Key
j = do
Label s
p <- 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
c
if forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
p
then forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
c Key
0 (Key -> Key -> Key
delta forall a. Bounded a => a
maxBound Key
j) Key
j
else do
Key
vp <- forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
key Label s
p
Label s
p' <- 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
p
let !j' :: Key
j' = Key
jforall a. Num a => a -> a -> a
+Key
1
if forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Key
vp forall a. Ord a => a -> a -> Bool
< Key
j'forall a. Num a => a -> a -> a
*Key
j'
then forall s. Label s -> Key -> ST s ()
growLeft Label s
p' Key
j'
else forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
c Key
vp (Key -> Key -> Key
delta (forall a. Bounded a => a
maxBoundforall a. Num a => a -> a -> a
-Key
vp) Key
j') Key
j'
balance :: Label s -> Key -> Key -> Word64 -> ST s ()
balance :: forall s. Label s -> Key -> Key -> Key -> ST s ()
balance !Label s
_ !Key
_ !Key
_ Key
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
balance Label s
Nil Key
_ Key
_ Key
_ = 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 forall a. Num a => a -> a -> a
+ Key
dv
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field Label Key
key Label s
c Key
v'
Label s
n <- 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
c
forall s. Label s -> Key -> Key -> Key -> ST s ()
balance Label s
n Key
v' Key
dv (Key
jforall a. Num a => a -> a -> a
-Key
1)
{-# INLINE insertAfter #-}
cutAfter :: PrimMonad m => Label (PrimState m) -> m ()
cutAfter :: forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m ()
cutAfter Label (PrimState m)
this = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Label (PrimState m)
n <- 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)
this
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
n) forall a b. (a -> b) -> a -> b
$ do
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)
this forall (t :: * -> *) s. Struct t => t s
Nil
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)
n forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE cutAfter #-}
cutBefore :: PrimMonad m => Label (PrimState m) -> m ()
cutBefore :: forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m ()
cutBefore Label (PrimState m)
this = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this) forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
Label (PrimState m)
p <- 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)
this
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
p) forall a b. (a -> b) -> a -> b
$ do
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)
p forall (t :: * -> *) s. Struct t => t s
Nil
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)
this forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE cutBefore #-}
least :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))
least :: forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> m (Label (PrimState m))
least Label (PrimState m)
xs0
| forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
xs0 = forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ forall s. Label s -> ST s (Label s)
go Label (PrimState m)
xs0 where
go :: Label s -> ST s (Label s)
go :: forall s. Label s -> ST s (Label s)
go Label s
this = do
Label s
p <- 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
this
if forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
p
then forall (m :: * -> *) a. Monad m => a -> m a
return Label s
this
else 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 :: forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> m (Label (PrimState m))
greatest Label (PrimState m)
xs0
| forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
xs0 = forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$ forall s. Label s -> ST s (Label s)
go Label (PrimState m)
xs0 where
go :: Label s -> ST s (Label s)
go :: forall s. Label s -> ST s (Label s)
go Label s
this = do
Label s
n <- 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
this
if forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label s
n
then forall (m :: * -> *) a. Monad m => a -> m a
return Label s
this
else 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 :: forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> Label (PrimState m) -> m Ordering
compareM Label (PrimState m)
i Label (PrimState m)
j
| forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
i Bool -> Bool -> Bool
|| forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
j = forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
| Bool
otherwise = forall a. Ord a => a -> a -> Ordering
compare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall a. Ord a => a -> a -> a
max Key
1 forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> a -> a
quot Key
m (Key
jforall a. Num a => a -> a -> a
+Key
1)
{-# INLINE delta #-}
value :: PrimMonad m => Label (PrimState m) -> m Key
value :: forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m Key
value Label (PrimState m)
this = 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 :: forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m [Key]
keys Label (PrimState m)
this = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Label (PrimState m)
this
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Key
x <- 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
Label (PrimState m)
n <- 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)
this
[Key]
xs <- forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m [Key]
keys Label (PrimState m)
n
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
xforall a. a -> [a] -> [a]
:[Key]
xs)
{-# INLINE keys #-}