{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Foreign.Store
(
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
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
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)
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))
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)
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 ()
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
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
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
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 ()