{-| Registry implementation using hashtable
-}
module Data.Registry.HashTable where

import Control.Monad.IO.Class
import qualified Data.HashTable.IO as H
import Data.Foldable (foldlM)
import Data.Maybe (fromJust)
import Data.Registry.Class
import qualified Data.Text as T
import qualified Data.Vector.Mutable.PushBack as VMP

data HashTableImpl k v = HashTableImpl (H.BasicHashTable k Int) (VMP.IOVector v)

instance IRegistry (HashTableImpl T.Text) where
  !? :: HashTableImpl Text v -> Text -> m (Maybe v)
(!?) (HashTableImpl reg :: BasicHashTable Text Int
reg vec :: IOVector v
vec) k :: Text
k = IO (Maybe v) -> m (Maybe v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> m (Maybe v)) -> IO (Maybe v) -> m (Maybe v)
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int
i <- BasicHashTable Text Int -> Text -> IO (Maybe Int)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup BasicHashTable Text Int
reg Text
k
    IO (Maybe v) -> (Int -> IO (Maybe v)) -> Maybe Int -> IO (Maybe v)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe v -> IO (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing) ((v -> Maybe v) -> IO v -> IO (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Maybe v
forall a. a -> Maybe a
Just (IO v -> IO (Maybe v)) -> (Int -> IO v) -> Int -> IO (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOVector v -> Int -> IO v
forall a. IOVector a -> Int -> IO a
VMP.read IOVector v
vec) Maybe Int
i

  write :: HashTableImpl Text v -> Text -> v -> m ()
write (HashTableImpl ht :: BasicHashTable Text Int
ht vec :: IOVector v
vec) k :: Text
k v :: v
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- (Maybe Int -> Int) -> IO (Maybe Int) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (IO (Maybe Int) -> IO Int) -> IO (Maybe Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ IO (Maybe Int) -> IO (Maybe Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> IO (Maybe Int))
-> IO (Maybe Int) -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ BasicHashTable Text Int -> Text -> IO (Maybe Int)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup BasicHashTable Text Int
ht Text
k
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOVector v -> Int -> v -> IO ()
forall a. IOVector a -> Int -> a -> IO ()
VMP.write IOVector v
vec Int
i v
v

  register :: HashTableImpl Text v -> Text -> v -> m ()
register (HashTableImpl ht :: BasicHashTable Text Int
ht vec :: IOVector v
vec) k :: Text
k v :: v
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int
len <- IOVector v -> IO Int
forall a. IOVector a -> IO Int
VMP.safeLength IOVector v
vec
    IOVector v -> v -> IO ()
forall a. IOVector a -> a -> IO ()
VMP.push IOVector v
vec v
v
    BasicHashTable Text Int -> Text -> Int -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert BasicHashTable Text Int
ht Text
k Int
len

  delete :: HashTableImpl Text v -> Text -> m ()
delete (HashTableImpl ht :: BasicHashTable Text Int
ht vec :: IOVector v
vec) k :: Text
k = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Just i :: Int
i <- BasicHashTable Text Int -> Text -> IO (Maybe Int)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup BasicHashTable Text Int
ht Text
k
    IOVector v -> Int -> IO ()
forall a. IOVector a -> Int -> IO ()
VMP.delete IOVector v
vec Int
i
    BasicHashTable Text Int -> Text -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO ()
H.delete BasicHashTable Text Int
ht Text
k

  insert :: HashTableImpl Text v -> Int -> Text -> v -> m ()
insert (HashTableImpl ht :: BasicHashTable Text Int
ht vec :: IOVector v
vec) i :: Int
i k :: Text
k v :: v
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    IOVector v -> Int -> v -> IO ()
forall a. IOVector a -> Int -> a -> IO ()
VMP.insert IOVector v
vec Int
i v
v
    BasicHashTable Text Int -> Text -> Int -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert BasicHashTable Text Int
ht Text
k Int
i

  asVec :: HashTableImpl Text v -> IOVector v
asVec (HashTableImpl _ vec :: IOVector v
vec) = IOVector v -> IOVector v
forall a. IOVector a -> IOVector a
VMP.asUnsafeIOVector IOVector v
vec

fromListImpl :: MonadIO m => [(T.Text, v)] -> m (HashTableImpl T.Text v)
fromListImpl :: [(Text, v)] -> m (HashTableImpl Text v)
fromListImpl xs :: [(Text, v)]
xs =
  IO (HashTableImpl Text v) -> m (HashTableImpl Text v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO (HashTableImpl Text v) -> m (HashTableImpl Text v))
-> IO (HashTableImpl Text v) -> m (HashTableImpl Text v)
forall a b. (a -> b) -> a -> b
$   HashTable RealWorld Text Int -> IOVector v -> HashTableImpl Text v
forall k v. BasicHashTable k Int -> IOVector v -> HashTableImpl k v
HashTableImpl
    (HashTable RealWorld Text Int
 -> IOVector v -> HashTableImpl Text v)
-> IO (HashTable RealWorld Text Int)
-> IO (IOVector v -> HashTableImpl Text v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( IO (HashTable RealWorld Text Int)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new IO (HashTable RealWorld Text Int)
-> (HashTable RealWorld Text Int
    -> IO (HashTable RealWorld Text Int))
-> IO (HashTable RealWorld Text Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \h :: HashTable RealWorld Text Int
h -> (HashTable RealWorld Text Int
 -> (Int, Text) -> IO (HashTable RealWorld Text Int))
-> HashTable RealWorld Text Int
-> [(Int, Text)]
-> IO (HashTable RealWorld Text Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
          (\acc :: HashTable RealWorld Text Int
acc (i :: Int
i, k :: Text
k) -> BasicHashTable Text Int -> Text -> Int -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld Text Int
BasicHashTable Text Int
acc Text
k Int
i IO ()
-> IO (HashTable RealWorld Text Int)
-> IO (HashTable RealWorld Text Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HashTable RealWorld Text Int -> IO (HashTable RealWorld Text Int)
forall (m :: * -> *) a. Monad m => a -> m a
return HashTable RealWorld Text Int
acc)
          HashTable RealWorld Text Int
h
          ([Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 ..] ([Text] -> [(Int, Text)]) -> [Text] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ ((Text, v) -> Text) -> [(Text, v)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, v) -> Text
forall a b. (a, b) -> a
fst [(Text, v)]
xs)
        )
    IO (IOVector v -> HashTableImpl Text v)
-> IO (IOVector v) -> IO (HashTableImpl Text v)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([v] -> IO (IOVector v)
forall a. [a] -> IO (IOVector a)
VMP.fromList ([v] -> IO (IOVector v)) -> [v] -> IO (IOVector v)
forall a b. (a -> b) -> a -> b
$ ((Text, v) -> v) -> [(Text, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (Text, v) -> v
forall a b. (a, b) -> b
snd [(Text, v)]
xs)