{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-- | Store a stable pointer in a foreign context to be retrieved
-- later. Persists through GHCi reloads. Not thread-safe.

module Foreign.Store
  (-- * Foreign stores
   writeStore
  ,newStore
  ,lookupStore
  ,readStore
  ,deleteStore
  ,storeAction
  ,withStore
  ,Store(..)
  ,StoreException(..))
  where

import Control.Exception
import Data.Typeable
import Data.Word
import Foreign.Ptr
import Foreign.StablePtr

-- | An exception when working with stores.
data StoreException
  = StoreNotFound
  deriving (Int -> StoreException -> ShowS
[StoreException] -> ShowS
StoreException -> String
(Int -> StoreException -> ShowS)
-> (StoreException -> String)
-> ([StoreException] -> ShowS)
-> Show StoreException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreException -> ShowS
showsPrec :: Int -> StoreException -> ShowS
$cshow :: StoreException -> String
show :: StoreException -> String
$cshowList :: [StoreException] -> ShowS
showList :: [StoreException] -> ShowS
Show,StoreException -> StoreException -> Bool
(StoreException -> StoreException -> Bool)
-> (StoreException -> StoreException -> Bool) -> Eq StoreException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreException -> StoreException -> Bool
== :: StoreException -> StoreException -> Bool
$c/= :: StoreException -> StoreException -> Bool
/= :: StoreException -> StoreException -> Bool
Eq,Typeable)

instance Exception StoreException

-- | A hideously unsafe store. Only for use if you are suave.
newtype Store a =
  Store Word32
  deriving (Int -> Store a -> ShowS
[Store a] -> ShowS
Store a -> String
(Int -> Store a -> ShowS)
-> (Store a -> String) -> ([Store a] -> ShowS) -> Show (Store a)
forall a. Int -> Store a -> ShowS
forall a. [Store a] -> ShowS
forall a. Store a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Store a -> ShowS
showsPrec :: Int -> Store a -> ShowS
$cshow :: forall a. Store a -> String
show :: Store a -> String
$cshowList :: forall a. [Store a] -> ShowS
showList :: [Store a] -> ShowS
Show,Store a -> Store a -> Bool
(Store a -> Store a -> Bool)
-> (Store a -> Store a -> Bool) -> Eq (Store a)
forall a. Store a -> Store a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Store a -> Store a -> Bool
== :: Store a -> Store a -> Bool
$c/= :: forall a. Store a -> Store a -> Bool
/= :: Store a -> Store a -> Bool
Eq)

-- | Lookup from the store if an index is allocated.
--
-- Not thread-safe.
lookupStore :: Word32 -> IO (Maybe (Store a))
lookupStore :: forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
i =
  do Word32
r <- Word32 -> IO Word32
x_lookup Word32
i
     if Word32
r Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
        then Maybe (Store a) -> IO (Maybe (Store a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Store a)
forall a. Maybe a
Nothing
        else Maybe (Store a) -> IO (Maybe (Store a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Store a -> Maybe (Store a)
forall a. a -> Maybe a
Just (Word32 -> Store a
forall a. Word32 -> Store a
Store Word32
i))

-- | Allocates or finds an unallocated store. The index is random. The
-- internal vector of stores grows in size. When stores are deleted
-- the vector does not shrink, but old slots are re-used.
--
-- Not thread-safe.
newStore :: a -> IO (Store a)
newStore :: forall a. a -> IO (Store a)
newStore a
a =
  do StablePtr a
sptr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
a
     Word32
i <- StablePtr a -> IO Word32
forall a. StablePtr a -> IO Word32
x_store StablePtr a
sptr
     Store a -> IO (Store a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Store a
forall a. Word32 -> Store a
Store Word32
i)

-- | Write to the store at the given index. If a store doesn't exist,
-- creates one and resizes the store vector to fit. If there is
-- already a store at the given index, deletes that store with
-- 'deleteStore' before replacing it.
--
-- Not thread-safe.
writeStore :: Store a -> a -> IO ()
writeStore :: forall a. Store a -> a -> IO ()
writeStore (Store Word32
i) a
a =
  do Maybe (Store Any)
existing <- Word32 -> IO (Maybe (Store Any))
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
i
     IO () -> (Store Any -> IO ()) -> Maybe (Store Any) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Store Any -> IO ()
forall a. Store a -> IO ()
deleteStore Maybe (Store Any)
existing
     StablePtr a
sptr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
a
     Word32 -> StablePtr a -> IO ()
forall a. Word32 -> StablePtr a -> IO ()
x_set Word32
i StablePtr a
sptr
     () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Read from the store. If the store has been deleted or is
-- unallocated, this will throw an exception.
--
-- Not thread-safe.
readStore :: Store a -> IO a
readStore :: forall a. Store a -> IO a
readStore (Store Word32
i) =
  do StablePtr a
sptr <- Word32 -> IO (StablePtr a)
forall a. Word32 -> IO (StablePtr a)
x_get Word32
i
     if StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
sptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
        then StoreException -> IO a
forall a e. Exception e => e -> a
throw StoreException
StoreNotFound
        else StablePtr a -> IO a
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr a
sptr

-- | Frees the stable pointer for GC and frees up the slot in the
-- store. Deleting an already deleted store is a no-op. But remember
-- that store numbers are re-used.
--
-- Not thread-safe.
deleteStore :: Store a -> IO ()
deleteStore :: forall a. Store a -> IO ()
deleteStore (Store Word32
i) = do
  StablePtr Any
sptr <- Word32 -> IO (StablePtr Any)
forall a. Word32 -> IO (StablePtr a)
x_get Word32
i
  if StablePtr Any -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr Any
sptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
     then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else do StablePtr Any -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr Any
sptr
             Word32 -> IO ()
x_delete Word32
i

-- | Run the action and store the result.
--
-- Not thread-safe.
storeAction :: Store a -> IO a -> IO a
storeAction :: forall a. Store a -> IO a -> IO a
storeAction Store a
s IO a
m =
  do a
v <- IO a
m
     Store a -> a -> IO ()
forall a. Store a -> a -> IO ()
writeStore Store a
s a
v
     a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Run the action with the value in the store.
--
-- Not thread-safe.
withStore :: Store a -> (a -> IO b) -> IO b
withStore :: forall a b. Store a -> (a -> IO b) -> IO b
withStore Store a
s a -> IO b
f =
  do a
v <- Store a -> IO a
forall a. Store a -> IO a
readStore Store a
s
     a -> IO b
f a
v

foreign import ccall
  "x-helpers.h x_store"
  x_store :: StablePtr a -> IO Word32

foreign import ccall
  "x-helpers.h x_set"
  x_set :: Word32 -> StablePtr a -> IO ()

foreign import ccall
  "x-helpers.h x_get"
  x_get :: Word32 -> IO (StablePtr a)

foreign import ccall
  "x-helpers.h x_lookup"
  x_lookup :: Word32 -> IO Word32

foreign import ccall
  "x-helpers.h x_delete"
  x_delete :: Word32 -> IO ()