{-# LANGUAGE RankNTypes #-}
module Rapid
(
Rapid,
rapid,
restart,
restartWith,
start,
startWith,
stop,
createRef,
deleteRef,
writeRef
)
where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Data.Dynamic
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Word
import Foreign.Store
data Rapid k =
Rapid {
forall k. Rapid k -> TVar Bool
rLock :: TVar Bool,
forall k. Rapid k -> TVar (Map k Dynamic)
rRefs :: TVar (Map k Dynamic),
forall k. Rapid k -> TVar (Map k (Async ()))
rThreads :: TVar (Map k (Async ()))
}
cancelAndWait :: Async a -> IO ()
cancelAndWait :: forall a. Async a -> IO ()
cancelAndWait Async a
tv = do
Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
tv
() () -> IO (Either SomeException a) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Async a -> IO (Either SomeException a)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async a
tv
createRef
:: (Ord k, Typeable a)
=> Rapid k
-> k
-> IO a
-> IO a
createRef :: forall k a. (Ord k, Typeable a) => Rapid k -> k -> IO a -> IO a
createRef Rapid k
r k
k IO a
gen =
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
forall k a.
Ord k =>
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
withRef Rapid k
r k
k ((Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a)
-> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Dynamic
mxd ->
case Maybe Dynamic
mxd of
Maybe Dynamic
Nothing -> (a -> (Maybe Dynamic, a)) -> IO a -> IO (Maybe Dynamic, a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x), a
x)) IO a
gen
Just Dynamic
xd
| Just a
x <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
xd -> (Maybe Dynamic, a) -> IO (Maybe Dynamic, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just Dynamic
xd, a
x)
| Bool
otherwise -> IOError -> IO (Maybe Dynamic, a)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"createRef: Wrong reference type")
deleteRef
:: (Ord k)
=> Rapid k
-> k
-> IO ()
deleteRef :: forall k. Ord k => Rapid k -> k -> IO ()
deleteRef Rapid k
r k
k =
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, ())) -> IO ()
forall k a.
Ord k =>
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
withRef Rapid k
r k
k (\Maybe Dynamic
_ -> (Maybe Dynamic, ()) -> IO (Maybe Dynamic, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Dynamic
forall a. Maybe a
Nothing, ()))
rapid
:: forall k r.
Word32
-> (Rapid k -> IO r)
-> IO r
rapid :: forall k r. Word32 -> (Rapid k -> IO r) -> IO r
rapid Word32
stNum Rapid k -> IO r
k =
((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO r) -> IO r)
-> ((forall a. IO a -> IO a) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
Word32 -> IO (Maybe (Store Any))
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
stNum IO (Maybe (Store Any))
-> (Maybe (Store Any) -> IO (Rapid k)) -> IO (Rapid k)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO (Rapid k)
-> (Store Any -> IO (Rapid k)) -> Maybe (Store Any) -> IO (Rapid k)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Store (Rapid k) -> IO (Rapid k) -> IO (Rapid k)
forall a. Store a -> IO a -> IO a
storeAction Store (Rapid k)
forall k. Store (Rapid k)
store IO (Rapid k)
forall {k}. IO (Rapid k)
create)
(\Store Any
_ -> Store (Rapid k) -> IO (Rapid k)
forall a. Store a -> IO a
readStore Store (Rapid k)
forall k. Store (Rapid k)
store) IO (Rapid k) -> (Rapid k -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(IO r -> IO r) -> Rapid k -> IO r
forall {b}. (IO r -> IO b) -> Rapid k -> IO b
pass IO r -> IO r
forall a. IO a -> IO a
unmask
where
create :: IO (Rapid k)
create =
(TVar Bool
-> TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k)
-> IO
(TVar Bool
-> TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TVar Bool
-> TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k
forall k.
TVar Bool
-> TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k
Rapid
IO
(TVar Bool
-> TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k)
-> IO (TVar Bool)
-> IO (TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
IO (TVar (Map k Dynamic) -> TVar (Map k (Async ())) -> Rapid k)
-> IO (TVar (Map k Dynamic))
-> IO (TVar (Map k (Async ())) -> Rapid k)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map k Dynamic -> IO (TVar (Map k Dynamic))
forall a. a -> IO (TVar a)
newTVarIO Map k Dynamic
forall k a. Map k a
M.empty
IO (TVar (Map k (Async ())) -> Rapid k)
-> IO (TVar (Map k (Async ()))) -> IO (Rapid k)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map k (Async ()) -> IO (TVar (Map k (Async ())))
forall a. a -> IO (TVar a)
newTVarIO Map k (Async ())
forall k a. Map k a
M.empty
pass :: (IO r -> IO b) -> Rapid k -> IO b
pass IO r -> IO b
unmask Rapid k
r = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (Rapid k -> TVar Bool
forall k. Rapid k -> TVar Bool
rLock Rapid k
r) STM Bool -> (Bool -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
check (Bool -> STM ()) -> (Bool -> Bool) -> Bool -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Rapid k -> TVar Bool
forall k. Rapid k -> TVar Bool
rLock Rapid k
r) Bool
True
IO r -> IO b
unmask (Rapid k -> IO r
k Rapid k
r) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`finally` STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Rapid k -> TVar Bool
forall k. Rapid k -> TVar Bool
rLock Rapid k
r) Bool
False)
store :: Store (Rapid k)
store :: forall k. Store (Rapid k)
store = Word32 -> Store (Rapid k)
forall a. Word32 -> Store a
Store Word32
stNum
restart
:: (Ord k)
=> Rapid k
-> k
-> IO ()
-> IO ()
restart :: forall k. Ord k => Rapid k -> k -> IO () -> IO ()
restart = (forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
forall k.
Ord k =>
(forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
restartWith IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async
restartWith
:: (Ord k)
=> (forall a. IO a -> IO (Async a))
-> Rapid k
-> k
-> IO ()
-> IO ()
restartWith :: forall k.
Ord k =>
(forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
restartWith forall a. IO a -> IO (Async a)
myAsync Rapid k
r k
k IO ()
action =
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall k.
Ord k =>
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
withThread Rapid k
r k
k ((Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ())
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Async ())
mtv -> do
(Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall a. Async a -> IO ()
cancelAndWait Maybe (Async ())
mtv
Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just (Async () -> Maybe (Async ()))
-> IO (Async ()) -> IO (Maybe (Async ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
myAsync IO ()
action
start
:: (Ord k)
=> Rapid k
-> k
-> IO ()
-> IO ()
start :: forall k. Ord k => Rapid k -> k -> IO () -> IO ()
start = (forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
forall k.
Ord k =>
(forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
startWith IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async
startWith
:: (Ord k)
=> (forall a. IO a -> IO (Async a))
-> Rapid k
-> k
-> IO ()
-> IO ()
startWith :: forall k.
Ord k =>
(forall a. IO a -> IO (Async a)) -> Rapid k -> k -> IO () -> IO ()
startWith forall a. IO a -> IO (Async a)
myAsync Rapid k
r k
k IO ()
action =
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall k.
Ord k =>
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
withThread Rapid k
r k
k ((Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ())
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall a b. (a -> b) -> a -> b
$
IO (Maybe (Async ()))
-> (Async () -> IO (Maybe (Async ())))
-> Maybe (Async ())
-> IO (Maybe (Async ()))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just (Async () -> Maybe (Async ()))
-> IO (Async ()) -> IO (Maybe (Async ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
myAsync IO ()
action)
(\Async ()
tv -> Async () -> IO (Maybe (Either SomeException ()))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async ()
tv IO (Maybe (Either SomeException ()))
-> (Maybe (Either SomeException ()) -> IO (Maybe (Async ())))
-> IO (Maybe (Async ()))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO (Maybe (Async ()))
-> (Either SomeException () -> IO (Maybe (Async ())))
-> Maybe (Either SomeException ())
-> IO (Maybe (Async ()))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Async ()) -> IO (Maybe (Async ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
tv))
(\Either SomeException ()
_ -> Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just (Async () -> Maybe (Async ()))
-> IO (Async ()) -> IO (Maybe (Async ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
myAsync IO ()
action))
stop :: (Ord k) => Rapid k -> k -> x -> IO ()
stop :: forall k x. Ord k => Rapid k -> k -> x -> IO ()
stop Rapid k
r k
k x
_ =
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall k.
Ord k =>
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
withThread Rapid k
r k
k ((Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ())
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Async ())
mtv ->
Maybe (Async ())
forall a. Maybe a
Nothing Maybe (Async ()) -> IO () -> IO (Maybe (Async ()))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall a. Async a -> IO ()
cancelAndWait Maybe (Async ())
mtv
withRef
:: (Ord k)
=> Rapid k
-> k
-> (Maybe Dynamic -> IO (Maybe Dynamic, a))
-> IO a
withRef :: forall k a.
Ord k =>
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
withRef Rapid k
r k
k Maybe Dynamic -> IO (Maybe Dynamic, a)
f = do
(Maybe Dynamic
mx, a
y) <- STM (Maybe Dynamic) -> IO (Maybe Dynamic)
forall a. STM a -> IO a
atomically (k -> Map k Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k Dynamic -> Maybe Dynamic)
-> STM (Map k Dynamic) -> STM (Maybe Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k Dynamic) -> STM (Map k Dynamic)
forall a. TVar a -> STM a
readTVar (Rapid k -> TVar (Map k Dynamic)
forall k. Rapid k -> TVar (Map k Dynamic)
rRefs Rapid k
r)) IO (Maybe Dynamic)
-> (Maybe Dynamic -> IO (Maybe Dynamic, a))
-> IO (Maybe Dynamic, a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Maybe Dynamic -> IO (Maybe Dynamic, a)
f
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map k Dynamic) -> (Map k Dynamic -> Map k Dynamic) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Rapid k -> TVar (Map k Dynamic)
forall k. Rapid k -> TVar (Map k Dynamic)
rRefs Rapid k
r) ((Map k Dynamic -> Map k Dynamic)
-> (Dynamic -> Map k Dynamic -> Map k Dynamic)
-> Maybe Dynamic
-> Map k Dynamic
-> Map k Dynamic
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (k -> Map k Dynamic -> Map k Dynamic
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
k) (k -> Dynamic -> Map k Dynamic -> Map k Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k) Maybe Dynamic
mx)
a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y
withThread
:: (Ord k)
=> Rapid k
-> k
-> (Maybe (Async ()) -> IO (Maybe (Async ())))
-> IO ()
withThread :: forall k.
Ord k =>
Rapid k
-> k -> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
withThread Rapid k
r k
k Maybe (Async ()) -> IO (Maybe (Async ()))
f =
STM (Maybe (Async ())) -> IO (Maybe (Async ()))
forall a. STM a -> IO a
atomically (k -> Map k (Async ()) -> Maybe (Async ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k (Async ()) -> Maybe (Async ()))
-> STM (Map k (Async ())) -> STM (Maybe (Async ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (Async ())) -> STM (Map k (Async ()))
forall a. TVar a -> STM a
readTVar (Rapid k -> TVar (Map k (Async ()))
forall k. Rapid k -> TVar (Map k (Async ()))
rThreads Rapid k
r)) IO (Maybe (Async ()))
-> (Maybe (Async ()) -> IO (Maybe (Async ())))
-> IO (Maybe (Async ()))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Maybe (Async ()) -> IO (Maybe (Async ()))
f IO (Maybe (Async ())) -> (Maybe (Async ()) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (Maybe (Async ()) -> STM ()) -> Maybe (Async ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map k (Async ()))
-> (Map k (Async ()) -> Map k (Async ())) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Rapid k -> TVar (Map k (Async ()))
forall k. Rapid k -> TVar (Map k (Async ()))
rThreads Rapid k
r) ((Map k (Async ()) -> Map k (Async ())) -> STM ())
-> (Maybe (Async ()) -> Map k (Async ()) -> Map k (Async ()))
-> Maybe (Async ())
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map k (Async ()) -> Map k (Async ()))
-> (Async () -> Map k (Async ()) -> Map k (Async ()))
-> Maybe (Async ())
-> Map k (Async ())
-> Map k (Async ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (k -> Map k (Async ()) -> Map k (Async ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
k) (k -> Async () -> Map k (Async ()) -> Map k (Async ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k)
writeRef
:: (Ord k, Typeable a)
=> Rapid k
-> k
-> IO a
-> IO a
writeRef :: forall k a. (Ord k, Typeable a) => Rapid k -> k -> IO a -> IO a
writeRef Rapid k
r k
k IO a
gen =
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
forall k a.
Ord k =>
Rapid k -> k -> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
withRef Rapid k
r k
k ((Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a)
-> (Maybe Dynamic -> IO (Maybe Dynamic, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Dynamic
_ ->
(a -> (Maybe Dynamic, a)) -> IO a -> IO (Maybe Dynamic, a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x), a
x)) IO a
gen