module Game.GoreAndAsh.Async.API(
MonadAsync(..)
, MonadAsyncExcepion(..)
, asyncAction
, asyncActionC
, asyncActionEx
, asyncActionExC
, asyncActionFactory
, asyncActionFactoryEx
, asyncActionBound
, asyncActionBoundC
, asyncActionBoundEx
, asyncActionBoundExC
, asyncActionBoundFactory
, asyncActionBoundFactoryEx
, asyncSyncAction
, asyncSyncActionEx
, asyncSyncActionC
, asyncSyncActionExC
, asyncSyncActionFactory
, asyncSyncActionFactoryEx
) where
import Control.Concurrent.Async
import Control.DeepSeq
import Control.Exception
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Wire
import Control.Wire.Unsafe.Event
import Data.Dynamic
import GHC.Generics (Generic)
import Prelude hiding (id, (.))
import Game.GoreAndAsh.Core
import Game.GoreAndAsh.Async.Module
import Game.GoreAndAsh.Async.State
import Data.Sequence (Seq, (|>), (><))
import qualified Data.Sequence as S
import qualified Data.Foldable as F
data MonadAsyncExcepion =
AsyncWrongType TypeRep TypeRep
| AsyncNotFound AsyncId
| SyncWrongType TypeRep TypeRep
deriving (Generic, Show)
instance Exception MonadAsyncExcepion
instance NFData MonadAsyncExcepion where
rnf e = case e of
AsyncWrongType tr1 tr2 -> rnfTypeRep tr1 `deepseq` rnfTypeRep tr2
AsyncNotFound i -> i `deepseq` ()
SyncWrongType tr1 tr2 -> rnfTypeRep tr1 `deepseq` rnfTypeRep tr2
class (MonadIO m, MonadThrow m) => MonadAsync m where
asyncActionM :: Typeable a => IO a -> m AsyncId
asyncActionBoundM :: Typeable a => IO a -> m AsyncId
asyncPollM :: Typeable a => AsyncId -> m (Maybe (Either SomeException a))
asyncCancelM :: AsyncId -> m ()
asyncSyncActionM :: Typeable a => IO a -> m SyncId
asyncSyncPollM :: Typeable a => SyncId -> m (Maybe (Either SomeException a))
asyncSyncCanceM :: SyncId -> m ()
instance (MonadIO m, MonadThrow m) => MonadAsync (AsyncT s m) where
asyncActionM !io = do
av <- liftIO . async $! io
state $! registerAsyncValue av
asyncActionBoundM !io = do
av <- liftIO . asyncBound $! io
state $! registerAsyncValue av
asyncPollM :: forall a . Typeable a => AsyncId -> AsyncT s m (Maybe (Either SomeException a))
asyncPollM i = do
mav <- getFinishedAsyncValue i <$> AsyncT get
case mav of
Nothing -> throwM . AsyncNotFound $! i
Just av -> case av of
Nothing -> return Nothing
Just ev -> case ev of
Left e -> return . Just . Left $! e
Right da -> case fromDynamic da of
Nothing -> throwM $! AsyncWrongType (typeRep (Proxy :: Proxy a)) (dynTypeRep da)
Just a -> return . Just . Right $! a
asyncCancelM i = do
mav <- state $! cancelAsyncValue i
case mav of
Nothing -> return ()
Just av -> liftIO $! cancel av
asyncSyncActionM = state . registerSyncValue
asyncSyncPollM :: forall a . Typeable a => SyncId -> AsyncT s m (Maybe (Either SomeException a))
asyncSyncPollM i = do
mav <- getFinishedSyncValue i <$> AsyncT get
case mav of
Nothing -> return Nothing
Just ev -> case ev of
Left e -> return . Just . Left $! e
Right da -> case fromDynamic da of
Nothing -> throwM $! SyncWrongType (typeRep (Proxy :: Proxy a)) (dynTypeRep da)
Just a -> return . Just . Right $! a
asyncSyncCanceM i = state $! ((), ) <$> cancelSyncValue i
instance (MonadIO (mt m), MonadThrow (mt m), MonadAsync m, MonadTrans mt) => MonadAsync (mt m) where
asyncActionM = lift . asyncActionM
asyncActionBoundM = lift . asyncActionBoundM
asyncPollM = lift . asyncPollM
asyncCancelM = lift . asyncCancelM
asyncSyncActionM = lift . asyncSyncActionM
asyncSyncPollM = lift . asyncSyncPollM
asyncSyncCanceM = lift . asyncSyncCanceM
asyncActionG :: (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> IO a -> GameWire m b (Event a)
asyncActionG mkAsync io = mkGen $ \_ _ -> do
i <- mkAsync io
return (Right NoEvent, go i)
where
go i = mkGen $ \_ _ -> do
mr <- asyncPollM i
case mr of
Nothing -> return (Right NoEvent, go i)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (Right $ Event a, never)
asyncActionCG :: (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> IO a -> GameWire m (Event b) (Event a)
asyncActionCG mkAsync io = mkGen $ \_ ce -> case ce of
NoEvent -> do
i <- mkAsync io
return (Right NoEvent, go i)
Event _ -> return (Right NoEvent, never)
where
go i = mkGen $ \_ ce -> case ce of
NoEvent -> do
mr <- asyncPollM i
case mr of
Nothing -> return (Right NoEvent, go i)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (Right $ Event a, never)
Event _ -> do
asyncCancelM i
return (Right NoEvent, never)
asyncActionExG :: (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> IO a -> GameWire m b (Event (Either SomeException a))
asyncActionExG mkAsync io = mkGen $ \_ _ -> do
i <- mkAsync io
return (Right NoEvent, go i)
where
go i = mkGen $ \_ _ -> do
mr <- asyncPollM i
case mr of
Nothing -> return (Right NoEvent, go i)
Just ea -> return (Right $ Event ea, never)
asyncActionExCG :: (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> IO a -> GameWire m (Event b) (Event (Either SomeException a))
asyncActionExCG mkAsync io = mkGen $ \_ ce -> case ce of
NoEvent -> do
i <- mkAsync io
return (Right NoEvent, go i)
Event _ -> return (Right NoEvent, never)
where
go i = mkGen $ \_ ce -> case ce of
NoEvent -> do
mr <- asyncPollM i
case mr of
Nothing -> return (Right NoEvent, go i)
Just ea -> return (Right $ Event ea, never)
Event _ -> do
asyncCancelM i
return (Right NoEvent, never)
asyncAction :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event a)
asyncAction = asyncActionG asyncActionM
asyncActionC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event a)
asyncActionC = asyncActionCG asyncActionM
asyncActionEx :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event (Either SomeException a))
asyncActionEx = asyncActionExG asyncActionM
asyncActionExC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event (Either SomeException a))
asyncActionExC = asyncActionExCG asyncActionM
asyncActionBound :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event a)
asyncActionBound = asyncActionG asyncActionBoundM
asyncActionBoundC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event a)
asyncActionBoundC = asyncActionCG asyncActionBoundM
asyncActionBoundEx :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event (Either SomeException a))
asyncActionBoundEx = asyncActionExG asyncActionBoundM
asyncActionBoundExC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event (Either SomeException a))
asyncActionBoundExC = asyncActionExCG asyncActionBoundM
asyncSyncAction :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event a)
asyncSyncAction io = mkGen $ \_ _ -> do
i <- asyncSyncActionM io
return (Right NoEvent, go i)
where
go i = mkGen $ \_ _ -> do
mr <- asyncSyncPollM i
case mr of
Nothing -> return (Right NoEvent, never)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (Right $ Event a, never)
asyncSyncActionEx :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event (Either SomeException a))
asyncSyncActionEx io = mkGen $ \_ _ -> do
i <- asyncSyncActionM io
return (Right NoEvent, go i)
where
go i = mkGen $ \_ _ -> do
mr <- asyncSyncPollM i
case mr of
Nothing -> return (Right NoEvent, never)
Just ea -> return (Right $ Event ea, never)
asyncSyncActionC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event a)
asyncSyncActionC io = mkGen $ \_ ce -> case ce of
NoEvent -> do
i <- asyncSyncActionM io
return (Right NoEvent, go i)
Event _ -> return (Right NoEvent, never)
where
go i = mkGen $ \_ ce -> case ce of
NoEvent -> do
mr <- asyncSyncPollM i
case mr of
Nothing -> return (Right NoEvent, never)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (Right $ Event a, never)
Event _ -> return (Right NoEvent, never)
asyncSyncActionExC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event (Either SomeException a))
asyncSyncActionExC io = mkGen $ \_ ce -> case ce of
NoEvent -> do
i <- asyncSyncActionM io
return (Right NoEvent, go i)
Event _ -> return (Right NoEvent, never)
where
go i = mkGen $ \_ ce -> case ce of
NoEvent -> do
mr <- asyncSyncPollM i
case mr of
Nothing -> return (Right NoEvent, never)
Just ea -> return (Right $ Event ea, never)
Event _ -> return (Right NoEvent, never)
asyncActionFactoryG :: forall m a . (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> GameWire m (Event (Seq (IO a))) (Event (Seq a))
asyncActionFactoryG mkAsync = go S.empty
where
go :: Seq AsyncId -> GameWire m (Event (Seq (IO a))) (Event (Seq a))
go is = mkGen $ \_ eios -> do
newIs <- case eios of
NoEvent -> return S.empty
Event ios -> mapM mkAsync ios
rs <- mapM asyncPollM is
(as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is
let e = if S.null as then NoEvent else Event as
let is'' = is' >< newIs
return $ is'' `deepseq` e `seq` (Right e, go is'')
procValue :: (Seq a, Seq AsyncId) -> (Maybe (Either SomeException a), AsyncId) -> GameMonadT m (Seq a, Seq AsyncId)
procValue (as, is) (mr, i) = case mr of
Nothing -> return (as, is |> i)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (as |> a, is)
asyncActionFactoryExG :: forall m a . (MonadAsync m, Typeable a) =>
(IO a -> GameMonadT m AsyncId)
-> GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
asyncActionFactoryExG mkAsync = go S.empty
where
go :: Seq AsyncId -> GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
go is = mkGen $ \_ eios -> do
newIs <- case eios of
NoEvent -> return S.empty
Event ios -> mapM mkAsync ios
rs <- mapM asyncPollM is
(as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is
let e = if S.null as then NoEvent else Event as
let is'' = is' >< newIs
return $ is'' `deepseq` e `seq` (Right e, go is'')
procValue :: (Seq (Either SomeException a), Seq AsyncId) -> (Maybe (Either SomeException a), AsyncId) -> GameMonadT m (Seq (Either SomeException a), Seq AsyncId)
procValue (as, is) (mr, i) = case mr of
Nothing -> return (as, is |> i)
Just ea -> return (as |> ea, is)
asyncActionFactory :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq a))
asyncActionFactory = asyncActionFactoryG asyncActionM
asyncActionFactoryEx :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
asyncActionFactoryEx = asyncActionFactoryExG asyncActionM
asyncActionBoundFactory :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq a))
asyncActionBoundFactory = asyncActionFactoryG asyncActionBoundM
asyncActionBoundFactoryEx :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
asyncActionBoundFactoryEx = asyncActionFactoryExG asyncActionM
asyncSyncActionFactory :: forall m a . (MonadAsync m, Typeable a)
=> GameWire m (Event (Seq (IO a))) (Event (Seq a))
asyncSyncActionFactory = go S.empty
where
go :: Seq SyncId -> GameWire m (Event (Seq (IO a))) (Event (Seq a))
go is = mkGen $ \_ eios -> do
newIs <- case eios of
NoEvent -> return S.empty
Event ios -> mapM asyncSyncActionM ios
rs <- mapM asyncSyncPollM is
(as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is
let e = if S.null as then NoEvent else Event as
let is'' = is' >< newIs
return $ is'' `deepseq` e `seq` (Right e, go is'')
procValue :: (Seq a, Seq SyncId) -> (Maybe (Either SomeException a), SyncId) -> GameMonadT m (Seq a, Seq SyncId)
procValue (as, is) (mr, i) = case mr of
Nothing -> return (as, is |> i)
Just ea -> case ea of
Left e -> throwM e
Right a -> return (as |> a, is)
asyncSyncActionFactoryEx :: forall m a . (MonadAsync m, Typeable a)
=> GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
asyncSyncActionFactoryEx = go S.empty
where
go :: Seq SyncId -> GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))
go is = mkGen $ \_ eios -> do
newIs <- case eios of
NoEvent -> return S.empty
Event ios -> mapM asyncSyncActionM ios
rs <- mapM asyncSyncPollM is
(as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is
let e = if S.null as then NoEvent else Event as
let is'' = is' >< newIs
return $ is'' `deepseq` e `seq` (Right e, go is'')
procValue :: (Seq (Either SomeException a), Seq SyncId) -> (Maybe (Either SomeException a), SyncId) -> GameMonadT m (Seq (Either SomeException a), Seq SyncId)
procValue (as, is) (mr, i) = case mr of
Nothing -> return (as, is |> i)
Just ea -> return (as |> ea, is)