packages feed

gore-and-ash-async (empty) → 0.1.0.0

raw patch · 8 files changed

+1408/−0 lines, 8 filesdep +HUnitdep +asyncdep +basesetup-changed

Dependencies added: HUnit, async, base, containers, deepseq, exceptions, gore-and-ash, gore-and-ash-async, hashable, mtl, test-framework, test-framework-hunit, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of  nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gore-and-ash-async.cabal view
@@ -0,0 +1,73 @@+name:                gore-and-ash-async+version:             0.1.0.0+synopsis:            Core module for Gore&Ash engine that embeds async IO actions into game loop.+description:         Please see README.md+homepage:            https://github.com/TeaspotStudio/gore-and-ash-async#readme+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2016 Anton Gushcha+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:     src+  exposed-modules:     +                      Game.GoreAndAsh.Async+                      Game.GoreAndAsh.Async.API+                      Game.GoreAndAsh.Async.Module+                      Game.GoreAndAsh.Async.State+  +  default-language:   Haskell2010+  build-depends:      base >= 4.7 && < 5+                    , async >= 2.0.2+                    , containers >= 0.5.6.2+                    , deepseq >= 1.4.1.1+                    , exceptions >= 0.8.2.1+                    , gore-and-ash >= 1.1.0.1+                    , hashable >= 1.2.4.0+                    , mtl >= 2.2.1+                    , transformers >= 0.4.2.0+                    , unordered-containers >= 0.2.5.1++  default-extensions: +                      BangPatterns+                      DeriveGeneric+                      FlexibleInstances+                      GeneralizedNewtypeDeriving+                      InstanceSigs+                      MultiParamTypeClasses+                      RecordWildCards+                      ScopedTypeVariables+                      TupleSections+                      TypeFamilies+                      UndecidableInstances++test-suite gore-and-ash-async-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , gore-and-ash >= 1.1.0.1+                     , gore-and-ash-async+                     , test-framework+                     , test-framework-hunit+                     , HUnit+                     , deepseq >= 1.4.1.1+                     , exceptions >= 0.8.2.1+                     , transformers >= 0.4.2.0+                     , mtl >= 2.2.1+                     , containers >= 0.5.6.2++  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  default-extensions:  +                      Arrows+                      DataKinds+                      DeriveGeneric+                      GeneralizedNewtypeDeriving+                      MultiParamTypeClasses+                      OverloadedStrings+                      TypeFamilies
+ src/Game/GoreAndAsh/Async.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-|+Module      : Game.GoreAndAsh.Async+Description : Core module for embedding concurrent IO actions into main loop.+Copyright   : (c) Anton Gushcha, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The core module contains API for embedding concurrent IO actions (async and sync) into main game loop for Gore&Ash.++The module does not depend on any other core modules, so 'AsyncT' could be placed at any place in monad stack.++The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.++Example of embedding:++@+-- Language extensions: DataKinds DeriveGeneric GeneralizedNewtypeDeriving MultiParamTypeClasses TypeFamilies+import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.IO.Class+import Data.Typeable +import GHC.Generics (Generic)++import Game.GoreAndAsh.Core+import Game.GoreAndAsh.Async ++-- | Application monad is monad stack build from given list of modules over base monad (IO or Identity)+type AppStack = ModuleStack [AsyncT ... other modules ... ] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadAsync ... other modules monads ... )++instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+@++-}+module Game.GoreAndAsh.Async(+  -- * Low-level+    AsyncState+  , AsyncT +  , AsyncId+  , MonadAsync(..)+  -- * Arrow API+  -- ** Not bounded async+  , asyncAction+  , asyncActionC+  , asyncActionEx+  , asyncActionExC+  , asyncActionFactory+  , asyncActionFactoryEx+  -- ** Bounded async+  , asyncActionBound+  , asyncActionBoundC+  , asyncActionBoundEx+  , asyncActionBoundExC+  , asyncActionBoundFactory+  , asyncActionBoundFactoryEx+  -- ** Sync actions+  , asyncSyncAction+  , asyncSyncActionEx+  , asyncSyncActionC+  , asyncSyncActionExC+  , asyncSyncActionFactory +  , asyncSyncActionFactoryEx+  ) where++-- for docs+import Game.GoreAndAsh++import Game.GoreAndAsh.Async.API as X +import Game.GoreAndAsh.Async.Module as X +import Game.GoreAndAsh.Async.State as X
+ src/Game/GoreAndAsh/Async/API.hs view
@@ -0,0 +1,536 @@+{-|+Module      : Game.GoreAndAsh.Async.API+Description : Monadic and arrow API for module+Copyright   : (c) Anton Gushcha, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Async.API(+  -- * Monadic API+    MonadAsync(..)+  , MonadAsyncExcepion(..)+  -- * Arrow API+  -- ** Not bounded async+  , asyncAction+  , asyncActionC+  , asyncActionEx+  , asyncActionExC+  , asyncActionFactory+  , asyncActionFactoryEx+  -- ** Bounded async+  , asyncActionBound+  , asyncActionBoundC+  , asyncActionBoundEx+  , asyncActionBoundExC+  , asyncActionBoundFactory+  , asyncActionBoundFactoryEx+  -- ** Sync actions+  , 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 ++-- | Exception of the async monadic API+data MonadAsyncExcepion =+    AsyncWrongType TypeRep TypeRep -- ^ Expected type doesn't match stored in async value+  | AsyncNotFound AsyncId -- ^ There is no async value with the id+  | SyncWrongType TypeRep TypeRep -- ^ Expected type doesn't match stored in sync value+  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++-- | Low level monadic API for module.+--+-- Note: does not require 'm' to be 'IO' monad.+class (MonadIO m, MonadThrow m) => MonadAsync m where +  -- | Start execution of 'IO' action concurrently and return its id+  asyncActionM :: Typeable a => IO a -> m AsyncId++  -- | Start execution of 'IO' action concurrently and return its id+  --+  -- Note: forks thread within same OS thread.+  asyncActionBoundM :: Typeable a => IO a -> m AsyncId++  -- | Check state of concurrent value+  --+  -- Could throw 'MonadAsyncExcepion', 'AsyncWrongType' and 'AsyncNotFound' constructors.+  asyncPollM :: Typeable a => AsyncId -> m (Maybe (Either SomeException a))++  -- | Stops given async execution+  asyncCancelM :: AsyncId -> m ()++  -- | Schedule action to be executed at the end of frame.+  --+  -- Use 'asyncSyncPollM' to get result at next frame.+  --+  -- Note: order of IO actions is preserved.+  asyncSyncActionM :: Typeable a => IO a -> m SyncId++  -- | Fires when given synchronious action is completed (at next frame after scheduling)+  --+  -- Could throw 'MonadAsyncExcepion', 'SyncWrongType' constructor.+  asyncSyncPollM :: Typeable a => SyncId -> m (Maybe (Either SomeException a))++  -- | Unshedule given action from execution+  --+  -- Actually you can unshedule it until end of frame when corresponding 'asyncSyncActionM'+  -- was called.+  asyncSyncCanceM :: SyncId -> m ()++instance {-# OVERLAPPING #-} (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 {-# OVERLAPPABLE #-} (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++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+asyncActionG :: (MonadAsync m, Typeable a) => +  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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)++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+--+-- The concurrent action can be canceled by input event.+asyncActionCG :: (MonadAsync m, Typeable a) =>+  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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)++-- | Execute given 'IO' action concurrently. +-- +-- Event fires once when the action is finished. Exceptions in the concurrent+-- action are returned in event payload.+asyncActionExG :: (MonadAsync m, Typeable a) =>+  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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)++-- | Execute given 'IO' action concurrently. +--+-- Event fires once when the action is finished. Exceptions in the +-- concurrent action are returned in event payload.+--+-- The concurrent action can be canceled by input event.+asyncActionExCG :: (MonadAsync m, Typeable a) =>+  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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)++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+asyncAction :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event a)+asyncAction = asyncActionG asyncActionM++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+--+-- The concurrent action can be canceled by input event.+asyncActionC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event a)+asyncActionC = asyncActionCG asyncActionM++-- | Execute given 'IO' action concurrently. +-- +-- Event fires once when the action is finished. Exceptions in the concurrent+-- action are returned in event payload.+asyncActionEx :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event (Either SomeException a))+asyncActionEx = asyncActionExG asyncActionM++-- | Execute given 'IO' action concurrently. +--+-- Event fires once when the action is finished. Exceptions in the +-- concurrent action are returned in event payload.+--+-- The concurrent action can be canceled by input event.+asyncActionExC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event (Either SomeException a))+asyncActionExC = asyncActionExCG asyncActionM++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+--+-- Note: forks thread within same OS thread.+asyncActionBound :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event a)+asyncActionBound = asyncActionG asyncActionBoundM++-- | Execute given 'IO' action concurrently. Event fires once when the action +-- is finished. Exceptions are rethrown into main thread.+--+-- The concurrent action can be canceled by input event.+--+-- Note: forks thread within same OS thread.+asyncActionBoundC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event a)+asyncActionBoundC = asyncActionCG asyncActionBoundM++-- | Execute given 'IO' action concurrently. +-- +-- Event fires once when the action is finished. Exceptions in the concurrent+-- action are returned in event payload.+--+-- Note: forks thread within same OS thread.+asyncActionBoundEx :: (MonadAsync m, Typeable a) => IO a -> GameWire m b (Event (Either SomeException a))+asyncActionBoundEx = asyncActionExG asyncActionBoundM++-- | Execute given 'IO' action concurrently. +--+-- Event fires once when the action is finished. Exceptions in the +-- concurrent action are returned in event payload.+--+-- The concurrent action can be canceled by input event.+--+-- Note: forks thread within same OS thread.`+asyncActionBoundExC :: (MonadAsync m, Typeable a) => IO a -> GameWire m (Event b) (Event (Either SomeException a))+asyncActionBoundExC = asyncActionExCG asyncActionBoundM++-- | Execute given 'IO' action at end of current frame. Event fires once at next frame.+-- +-- Exceptions are rethrown into main thread.+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) -- One has canceled the action+        Just ea -> case ea of +          Left e -> throwM e +          Right a -> return (Right $ Event a, never)++-- | Execute given 'IO' action at end of current frame. Event fires once at next frame.+-- +-- Exceptions are returned in event payload.+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) -- One has canceled the action+        Just ea -> return (Right $ Event ea, never)++-- | Execute given 'IO' action at end of current frame. Event fires once at next frame.+-- +-- Exceptions are rethrown into main thread.+--+-- Action can be canceled with input event, although you have only the frame to do this.+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) -- One has canceled the action+          Just ea -> case ea of +            Left e -> throwM e +            Right a -> return (Right $ Event a, never)+      Event _ -> return (Right NoEvent, never)++-- | Execute given 'IO' action at end of current frame. Event fires once at next frame.+-- +-- Exceptions are rethrown into main thread.+--+-- Action can be canceled with input event, although you have only the frame to do this.+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) -- One has canceled the action+          Just ea -> return (Right $ Event ea, never)+      Event _ -> return (Right NoEvent, never)++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are rethrown into main thread.+asyncActionFactoryG :: forall m a . (MonadAsync m, Typeable a) => +  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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 +    -- spawn new values+    newIs <- case eios of +      NoEvent -> return S.empty +      Event ios -> mapM mkAsync ios++    -- poll current values+    rs <- mapM asyncPollM is+    (as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is++    -- return values, produce new ids+    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)++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are returned in event payload.+asyncActionFactoryExG :: forall m a . (MonadAsync m, Typeable a) => +  (IO a -> GameMonadT m AsyncId) -- ^ Maker of async value+  -> 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 +    -- spawn new values+    newIs <- case eios of +      NoEvent -> return S.empty +      Event ios -> mapM mkAsync ios++    -- poll current values+    rs <- mapM asyncPollM is+    (as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is++    -- return values, produce new ids+    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)++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are rethrown into main thread.+asyncActionFactory :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq a))+asyncActionFactory = asyncActionFactoryG asyncActionM++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are returned in event payload.+asyncActionFactoryEx :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))+asyncActionFactoryEx = asyncActionFactoryExG asyncActionM++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are rethrown into main thread.+--+-- Note: forks thread within same OS thread.+asyncActionBoundFactory :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq a))+asyncActionBoundFactory = asyncActionFactoryG asyncActionBoundM++-- | Wire that executes incoming 'IO' actions concurrently and then produces+-- events with results once for each action.+-- +-- Exceptions are returned in event payload.+--+-- Note: forks thread within same OS thread.+asyncActionBoundFactoryEx :: (MonadAsync m, Typeable a) => GameWire m (Event (Seq (IO a))) (Event (Seq (Either SomeException a)))+asyncActionBoundFactoryEx = asyncActionFactoryExG asyncActionM++-- | Wire that executes incoming 'IO' actions at end of current frame and then produces+-- events with results once for each action.+-- +-- Exceptions are rethrown into main thread.+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 +    -- spawn new values+    newIs <- case eios of +      NoEvent -> return S.empty +      Event ios -> mapM asyncSyncActionM ios++    -- poll current values+    rs <- mapM asyncSyncPollM is+    (as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is++    -- return values, produce new ids+    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)++-- | Wire that executes incoming 'IO' actions at end of current frame and then produces+-- events with results once for each action.+-- +-- Exceptions are rethrown into main thread.+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 +    -- spawn new values+    newIs <- case eios of +      NoEvent -> return S.empty +      Event ios -> mapM asyncSyncActionM ios++    -- poll current values+    rs <- mapM asyncSyncPollM is+    (as, is') <- F.foldlM procValue (S.empty, S.empty) $ rs `S.zip` is++    -- return values, produce new ids+    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)
+ src/Game/GoreAndAsh/Async/Module.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.Async.Module+Description : Monad transformer and instance for core module+Copyright   : (c) Anton Gushcha, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Async.Module(+    AsyncT(..)+  ) where++import Control.Concurrent.Async+import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.State.Strict++import Game.GoreAndAsh+import Game.GoreAndAsh.Async.State++import qualified Data.Foldable as F  +import qualified Data.HashMap.Strict as H+import qualified Data.Sequence as S ++-- | Monad transformer of async core module.+--+-- [@s@] - State of next core module in modules chain;+--+-- [@m@] - Next monad in modules monad stack;+--+-- [@a@] - Type of result value;+--+-- How to embed module:+-- +-- @+-- type AppStack = ModuleStack [AsyncT, ... other modules ... ] IO+--+-- newtype AppMonad a = AppMonad (AppStack a)+--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadAsync)+-- @+--+-- The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.+newtype AsyncT s m a = AsyncT { runAsyncT :: StateT (AsyncState s) m a }+  deriving (Functor, Applicative, Monad, MonadState (AsyncState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance GameModule m s => GameModule (AsyncT s m) (AsyncState s) where +  type ModuleState (AsyncT s m) = AsyncState s+  runModule (AsyncT m) s1 = do+    ((a, s2), nextState) <- runModule (runStateT m s1) (asyncNextState s1)+    s3 <- pollAsyncs . purgeAsyncs $! s2 +    s4 <- liftIO . execSyncs . purgeSyncs $! s3+    return (a, s4 {+        asyncNextState = nextState +      })+  +  newModuleState = emptyAsyncState <$> newModuleState+  withModule _ = id+  cleanupModule _ = return ()++-- | Polls all async values and update values+pollAsyncs :: MonadIO m => AsyncState s -> m (AsyncState s)+pollAsyncs s = do+  mp <- mapM pollVal . asyncAValues $! s +  return $! s {+      asyncAValues = mp+    }+  where+  pollVal ev = case ev of +    Left a -> do +      mr <- liftIO . poll $! a+      case mr of +        Nothing -> return ev +        Just r -> return . Right $! r+    _ -> return ev++-- | Execute all sync values+execSyncs :: AsyncState s -> IO (AsyncState s)+execSyncs s = do +  as <- mapM (uncurry execAction) . asyncScheduled $! s+  return $! s {+      asyncScheduled = S.empty +    , asyncSValues = F.foldl' (\acc (k, v) -> H.insert k v acc) H.empty as+    }+  where +    execAction i io = (fmap ((i,) . Right) io) `catchAll` (return . (i,) . Left)
+ src/Game/GoreAndAsh/Async/State.hs view
@@ -0,0 +1,160 @@+{-|+Module      : Game.GoreAndAsh.Async.State+Description : Internal state of core module+Copyright   : (c) Anton Gushcha, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Async.State(+    AsyncState(..)+  , emptyAsyncState+  -- * Async helpers+  , AsyncId(..)+  , AsyncValueMap+  , registerAsyncValue+  , getFinishedAsyncValue+  , cancelAsyncValue+  , purgeAsyncs+  -- * Sync helpers+  , 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 ++-- | Id of async value, it is used to poll info about the value+newtype AsyncId = AsyncId { unAsyncId :: Int }+  deriving (Generic, Eq, Show)++instance Hashable AsyncId +instance NFData AsyncId ++-- | Container for async values+type AsyncValueMap = HashMap AsyncId (Either (Async Dynamic) (Either SomeException Dynamic))++-- | Id of sync value, it is used to identify return value+newtype SyncId = SyncId { unSyncId :: Int }+  deriving (Generic, Eq, Ord, Show)++instance Hashable SyncId +instance NFData SyncId ++-- | Container for scheduled sync values+type SyncSheduled = Seq (SyncId, IO Dynamic)++-- | Container for finished sync values+type SyncFinished = HashMap SyncId (Either SomeException Dynamic)++-- | Internal state of asynchronious core module+--+-- [@s@] - state of next module, they are chained until bottom, that is usually+--         an empty data type.+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`+    ()++-- | Create inital async state+--+-- [@s@] -  state of next module+emptyAsyncState :: s -> AsyncState s +emptyAsyncState s = AsyncState {+    asyncAValues = H.empty+  , asyncScheduled = S.empty+  , asyncSValues = H.empty+  , asyncNextId = 0+  , asyncNextState = s+  }++-- | Put async value into internal state+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++-- | Try to get value of given async value+--+-- Note: first 'Maybe' layer is test for existense of given async value+-- +-- Note: second 'Maybe' layer is test is the value is finished +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++-- | Unregister given id and return stored async+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++-- | Deletes calculated values+purgeAsyncs :: AsyncState s -> AsyncState s +purgeAsyncs !s = s {+    asyncAValues = H.filter isLeft . asyncAValues $! s+  }++-- | Put sync value into internal state+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++-- | Try to get value of given sync value+--+-- Note: first 'Maybe' layer is test for existense of given async value+getFinishedSyncValue :: SyncId -> AsyncState s -> Maybe (Either SomeException Dynamic)+getFinishedSyncValue !i AsyncState{..} = H.lookup i asyncSValues ++-- | Unregister given sheduled sync action+cancelSyncValue :: SyncId -> AsyncState s -> AsyncState s+cancelSyncValue !i !s = s {+    asyncScheduled = S.filter ((/= i).fst) . asyncScheduled $! s+  }++-- | Deletes calculated values+purgeSyncs :: AsyncState s -> AsyncState s +purgeSyncs !s = s {+    asyncSValues = H.empty+  }
+ test/Spec.hs view
@@ -0,0 +1,429 @@+module Main where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.IO.Class+import Data.Typeable +import GHC.Generics (Generic)++import Control.Concurrent.MVar+import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Either+import Game.GoreAndAsh.Async +import Game.GoreAndAsh.Core+import Prelude hiding (id, (.))++import qualified Data.Sequence as S ++-- | Application monad is monad stack build from given list of modules over base monad (IO or Identity)+type AppStack = ModuleStack [AsyncT, AsyncT] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadAsync)++instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b++data TestException = TestException deriving Show ++instance Exception TestException++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+  defaultMainWithOpts [+      testGroup "async actions" [+        testCase "simple" asyncSimple+      , testCase "except" asyncExcept+      , testCase "except no catch" asyncExcept'+      , testCase "cancel" asyncCancel+      , testCase "cancel delayed" asyncCancelDelayed+      , testCase "factory" asyncFactory+      , testCase "factory ex normal" asyncFactoryEx+      , testCase "factory ex except" asyncFactoryEx'+      ]+    , testGroup "async bound actions" [+        testCase "simple" asyncBoundSimple+      , testCase "except" asyncBoundExcept+      , testCase "except no catch" asyncBoundExcept'+      , testCase "cancel" asyncCancelBound+      , testCase "cancel delayed" asyncCancelBoundDelayed+      , testCase "factory" asyncFactoryBound+      , testCase "factory ex normal" asyncFactoryBoundEx+      , testCase "factory ex except" asyncFactoryBoundEx'+      ]+    , testGroup "async sync actions" [+        testCase "simple" asyncSyncSimple+      , testCase "except" asyncSyncExcept+      , testCase "except no catch" asyncSyncExcept'+      , testCase "cancel" asyncCancelSync+      , testCase "factory" asyncFactorySync+      , testCase "factory ex normal" asyncSyncFactoryEx+      , testCase "factory ex except" asyncSyncFactoryEx'+      ]+    ] mempty++-- | Runs wire n times and return it result+runWire :: Int -> AppWire () a -> IO (Maybe a)+runWire n w = do +  gs <- newGameState w+  go gs n Nothing+  where +  go gs i ma = if i <= 0 then return ma+    else do +      (ma', gs') <- stepGame gs (return ())+      go gs' (i-1) ma'++asyncSimple :: Assertion+asyncSimple = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just True) ma+  where+    w = proc _ -> do +      e <- asyncAction (return True) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncExcept :: Assertion+asyncExcept = do +  ma <- runWire 100 w +  assertBool "returned is exception" (check ma) +  where +    check ma = case ma of +      Nothing -> False +      Just ea -> isLeft ea ++    w :: AppWire () (Either SomeException Bool)+    w = proc _ -> do +      e <- asyncActionEx (throwM TestException) -< ()+      rSwitch (pure $ Right False) -< ((), pure <$> e)++asyncCancel :: Assertion+asyncCancel = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just False) ma+  where+    w = proc _ -> do +      ce <- now -< ()+      e <- asyncActionC (return True) -< ce+      rSwitch (pure False) -< ((), pure <$> e)++asyncCancelDelayed :: Assertion+asyncCancelDelayed = do +  ma <- runWire 100 w0 +  assertEqual "wire switch" (Just False) ma+  where+    w0 = switch $ proc _ -> do +      evar <- liftGameMonadEvent1 (const $ liftIO newEmptyMVar) . now -< ()+      returnA -< (False, w <$> evar)++    w var = proc _ -> do +      ce <- delay NoEvent . now -< ()+      e <- asyncActionC (io var) -< ce+      liftGameMonadEvent1 (const . liftIO $ putMVar var ()) -< ce+      rSwitch (pure False) -< ((), pure <$> e)++    io var = do +      _ <- readMVar var+      return True++asyncFactory :: Assertion +asyncFactory = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionFactory -< eio+    hold . accumE (\i as -> i + sum as) 0 -< eas ++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++seqRights :: S.Seq (Either a b) -> S.Seq b+seqRights = fmap fromRight . S.filter isRight+  where +  fromRight (Left _) = error "seqRights"+  fromRight (Right a) = a ++asyncFactoryEx :: Assertion +asyncFactoryEx = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++asyncFactoryEx' :: Assertion +asyncFactoryEx' = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 0) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (throwM TestException), go k (n-1))++asyncExcept' :: Assertion+asyncExcept' = do +  ma <- (fmap Right $ runWire 100 w) `catchAll` (return . Left)+  assertBool "returned is exception" (isLeft ma) +  where +    w :: AppWire () Bool+    w = proc _ -> do +      e <- asyncAction (throwM TestException) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncBoundSimple :: Assertion+asyncBoundSimple = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just True) ma+  where+    w = proc _ -> do +      e <- asyncActionBound (return True) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncBoundExcept :: Assertion+asyncBoundExcept = do +  ma <- runWire 100 w +  assertBool "returned is exception" (check ma) +  where +    check ma = case ma of +      Nothing -> False +      Just ea -> isLeft ea ++    w :: AppWire () (Either SomeException Bool)+    w = proc _ -> do +      e <- asyncActionBoundEx (throwM TestException) -< ()+      rSwitch (pure $ Right False) -< ((), pure <$> e)++asyncBoundExcept' :: Assertion+asyncBoundExcept' = do +  ma <- (fmap Right $ runWire 100 w) `catchAll` (return . Left)+  assertBool "returned is exception" (isLeft ma) +  where +    w :: AppWire () Bool+    w = proc _ -> do +      e <- asyncActionBound (throwM TestException) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncCancelBound :: Assertion+asyncCancelBound = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just False) ma+  where+    w = proc _ -> do +      ce <- now -< ()+      e <- asyncActionBoundC (return True) -< ce+      rSwitch (pure False) -< ((), pure <$> e)++asyncCancelBoundDelayed :: Assertion+asyncCancelBoundDelayed = do +  ma <- runWire 100 w0 +  assertEqual "wire switch" (Just False) ma+  where+    w0 = switch $ proc _ -> do +      evar <- liftGameMonadEvent1 (const $ liftIO newEmptyMVar) . now -< ()+      returnA -< (False, w <$> evar)++    w var = proc _ -> do +      ce <- delay NoEvent . now -< ()+      e <- asyncActionBoundC (io var) -< ce+      liftGameMonadEvent1 (const . liftIO $ putMVar var ()) -< ce+      rSwitch (pure False) -< ((), pure <$> e)++    io var = do +      _ <- readMVar var+      return True++asyncFactoryBound :: Assertion +asyncFactoryBound = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionBoundFactory -< eio+    hold . accumE (\i as -> i + sum as) 0 -< eas ++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++asyncFactoryBoundEx :: Assertion +asyncFactoryBoundEx = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionBoundFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++asyncFactoryBoundEx' :: Assertion +asyncFactoryBoundEx' = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 0) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncActionBoundFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (throwM TestException), go k (n-1))++asyncSyncSimple :: Assertion+asyncSyncSimple = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just True) ma+  where+    w = proc _ -> do +      e <- asyncSyncAction (return True) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncSyncExcept :: Assertion+asyncSyncExcept = do +  ma <- runWire 100 w +  assertBool "returned is exception" (check ma) +  where +    check ma = case ma of +      Nothing -> False +      Just ea -> isLeft ea ++    w :: AppWire () (Either SomeException Bool)+    w = proc _ -> do +      e <- asyncSyncActionEx (throwM TestException) -< ()+      rSwitch (pure $ Right False) -< ((), pure <$> e)++asyncSyncExcept' :: Assertion+asyncSyncExcept' = do +  ma <- (fmap Right $ runWire 100 w) `catchAll` (return . Left)+  assertBool "returned is exception" (isLeft ma) +  where +    w :: AppWire () Bool+    w = proc _ -> do +      e <- asyncSyncAction (throwM TestException) -< ()+      rSwitch (pure False) -< ((), pure <$> e)++asyncCancelSync :: Assertion+asyncCancelSync = do +  ma <- runWire 100 w +  assertEqual "wire switch" (Just False) ma+  where+    w = proc _ -> do +      ce <- now -< ()+      e <- asyncSyncActionC (return True) -< ce+      rSwitch (pure False) -< ((), pure <$> e)++asyncFactorySync :: Assertion +asyncFactorySync = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncSyncActionFactory -< eio+    hold . accumE (\i as -> i + sum as) 0 -< eas ++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++asyncSyncFactoryEx :: Assertion +asyncSyncFactoryEx = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 20) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncSyncActionFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (return 1), go k (n-1))++asyncSyncFactoryEx' :: Assertion +asyncSyncFactoryEx' = do +  ma <- runWire 100 w+  assertEqual "summed values" (Just 0) ma+  where+  w = proc _ -> do +    eio <- wgen -< ()+    eas <- asyncSyncActionFactoryEx -< eio+    hold . accumE foldResult 0 -< eas ++  foldResult :: Int -> S.Seq (Either SomeException Int) -> Int+  foldResult i eas = i + sum (seqRights eas)++  wgen :: AppWire () (Event (S.Seq (IO Int))) +  wgen = go 2 10+    where+    go k 0 = never+    go k n = mkSFN $ \_ -> (Event $ S.replicate k (throwM TestException), go k (n-1))