{-# LANGUAGE CPP #-}
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
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

-- $setup
-- >>> import Data.Struct.Internal
-- >>> import Data.Struct.Internal.Label

#ifdef HLINT
{-# ANN module "HLint: ignore Eta reduce" #-}
#endif

------------------------------------------------------------------------------------
-- * List Labeling: Maintain n keys each labeled with n^2 bits w/ log n update time.
--
-- After about 2^32 elements, this structure will continue to work, but will become
-- unacceptably slow and the asymptotic analysis will become wrong.
------------------------------------------------------------------------------------

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 #-}

-- | Logarithmic time list labeling solution
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

-- | Construct an explicit list labeling structure.
--
-- >>> x <- makeLabel 0 Nil Nil
-- >>> isNil x
-- False
-- >>> n <- get next x
-- >>> isNil n
-- True
-- >>> p <- get prev x
-- >>> isNil p
-- True

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 #-}

-- | O(1). Create a new labeling structure. Labels from different list labeling structures are incomparable.
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 #-}

-- | O(1). Remove a label
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 #-}

-- | O(log n) amortized. Insert a new label after a given label.
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 -- start at the fresh node
      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 -- it moves over

  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 -- full rebuild
    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 () -- error "balanced past the end" -- 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 #-}

-- | O(1). Split off all labels after the current label.
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 #-}

-- | O(1). Split off all labels before the current label.
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 #-}

-- | O(n). Retrieve the least label
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 #-}

-- | O(n). Retrieve the greatest label
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 #-}

-- | O(1). Compare two labels for ordering.
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 #-}

-- | O(1). Extract the current value assignment for this label. Any label mutation, even on other labels in this label structure, may change this answer.
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 #-}

-- | O(n). Get the keys of every label from here to the right.
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 #-}