module Game.GoreAndAsh.Async.State(
AsyncState(..)
, emptyAsyncState
, AsyncId(..)
, AsyncValueMap
, registerAsyncValue
, getFinishedAsyncValue
, cancelAsyncValue
, purgeAsyncs
, SyncId(..)
, SyncSheduled
, SyncFinished
, registerSyncValue
, getFinishedSyncValue
, cancelSyncValue
, purgeSyncs
) where
import Control.Concurrent.Async
import Control.DeepSeq
import Control.Exception
import Data.Dynamic
import Data.Either
import Data.Hashable
import GHC.Generics (Generic)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as S
newtype AsyncId = AsyncId { unAsyncId :: Int }
deriving (Generic, Eq, Show)
instance Hashable AsyncId
instance NFData AsyncId
type AsyncValueMap = HashMap AsyncId (Either (Async Dynamic) (Either SomeException Dynamic))
newtype SyncId = SyncId { unSyncId :: Int }
deriving (Generic, Eq, Ord, Show)
instance Hashable SyncId
instance NFData SyncId
type SyncSheduled = Seq (SyncId, IO Dynamic)
type SyncFinished = HashMap SyncId (Either SomeException Dynamic)
data AsyncState s = AsyncState {
asyncAValues :: !AsyncValueMap
, asyncScheduled :: !SyncSheduled
, asyncSValues :: !SyncFinished
, asyncNextId :: !Int
, asyncNextState :: !s
} deriving (Generic)
instance NFData s => NFData (AsyncState s) where
rnf AsyncState{..} =
asyncAValues `seq`
asyncSValues `seq`
asyncNextState `deepseq`
()
emptyAsyncState :: s -> AsyncState s
emptyAsyncState s = AsyncState {
asyncAValues = H.empty
, asyncScheduled = S.empty
, asyncSValues = H.empty
, asyncNextId = 0
, asyncNextState = s
}
registerAsyncValue :: Typeable a => Async a -> AsyncState s -> (AsyncId, AsyncState s)
registerAsyncValue !av !s = (i, s {
asyncNextId = asyncNextId s + 1
, asyncAValues = H.insert i (Left $ toDyn <$> av) . asyncAValues $! s
})
where
i = AsyncId . asyncNextId $! s
getFinishedAsyncValue :: AsyncId -> AsyncState s -> Maybe (Maybe (Either SomeException Dynamic))
getFinishedAsyncValue !i AsyncState{..} = check <$> H.lookup i asyncAValues
where
check v = case v of
Left _ -> Nothing
Right a -> Just a
cancelAsyncValue :: AsyncId -> AsyncState s -> (Maybe (Async Dynamic), AsyncState s)
cancelAsyncValue !i !s = (check =<< H.lookup i (asyncAValues s), s {
asyncAValues = H.delete i . asyncAValues $! s
})
where
check v = case v of
Left a -> Just a
Right _ -> Nothing
purgeAsyncs :: AsyncState s -> AsyncState s
purgeAsyncs !s = s {
asyncAValues = H.filter isLeft . asyncAValues $! s
}
registerSyncValue :: Typeable a => IO a -> AsyncState s -> (SyncId, AsyncState s)
registerSyncValue !io !s = (i, s {
asyncNextId = asyncNextId s + 1
, asyncScheduled = asyncScheduled s |> (i, toDyn <$> io)
})
where
i = SyncId . asyncNextId $! s
getFinishedSyncValue :: SyncId -> AsyncState s -> Maybe (Either SomeException Dynamic)
getFinishedSyncValue !i AsyncState{..} = H.lookup i asyncSValues
cancelSyncValue :: SyncId -> AsyncState s -> AsyncState s
cancelSyncValue !i !s = s {
asyncScheduled = S.filter ((/= i).fst) . asyncScheduled $! s
}
purgeSyncs :: AsyncState s -> AsyncState s
purgeSyncs !s = s {
asyncSValues = H.empty
}