Roaring.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

{-| Keeps an off-heap Roaring 'Index' of a store's members next to the store itself.

Reads go straight to the wrapped store, so @Roaring (Cache n (Map c))@ keeps the cache's lookup speed.
Members come from the index, which lets queries over several indexed stores run as bitmap operations.

Only stores that behave like a plain map can be wrapped ('Cachable'), since the index must see every write and removal.
Put @Roaring@ outside any 'Apecs.Stores.Cache'.
-}
module Apecs.Stores.Roaring
  ( Roaring (..)
  ) where

import Apecs.Core (Elem, ExplDestroy (..), ExplGet (..), ExplInit (..), ExplMembers (..), ExplSet (..))
import Apecs.Stores (Cachable)
import Apecs.Stores.Index (HasIndex (..), Index)
import Apecs.Stores.Index qualified as Index
import Control.Monad.IO.Class (MonadIO (..))

data Roaring s = Roaring {-# UNPACK #-} !Index !s

type instance Elem (Roaring s) = Elem s

instance (MonadIO m, ExplInit m s, Cachable s) => ExplInit m (Roaring s) where
  explInit = Roaring <$> liftIO Index.new <*> explInit

instance (ExplGet m s) => ExplGet m (Roaring s) where
  explGet (Roaring _ s) = explGet s
  {-# INLINE explGet #-}
  explExists (Roaring _ s) = explExists s
  {-# INLINE explExists #-}

instance (MonadIO m, ExplSet m s) => ExplSet m (Roaring s) where
  explSet (Roaring index s) ety c = do
    explSet s ety c
    liftIO $ Index.insert index ety
  {-# INLINE explSet #-}

instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Roaring s) where
  explDestroy (Roaring index s) ety = do
    explDestroy s ety
    liftIO $ Index.delete index ety
  {-# INLINE explDestroy #-}

instance (MonadIO m) => ExplMembers m (Roaring s) where
  explMembers (Roaring index _) = liftIO $ Index.toVector index
  {-# INLINE explMembers #-}

instance HasIndex (Roaring s) where
  getIndex (Roaring index _) = index