summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorqfpl <>2019-10-28 03:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-28 03:42:00 (GMT)
commitb315e081ef9630ca274b93710530127587df334a (patch)
tree5ce275c049717329830946296aaa5564f09d0e3c
parentd8dff12b03ba39316b751dffcba2c0722be8ce28 (diff)
version 0.20.2
-rwxr-xr-xChangeLog.md21
-rw-r--r--LICENCE (renamed from LICENSE)0
-rw-r--r--example/Counter.hs32
-rw-r--r--example/Main.hs16
-rw-r--r--example/Multithread.hs105
-rw-r--r--reflex-basic-host.cabal45
-rw-r--r--src/Reflex/Host/Basic.hs305
7 files changed, 368 insertions, 156 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 7bf8c5f..d397093 100755
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,7 +1,22 @@
-# changelog
+# ChangeLog
-## 0.1
+## 0.2 - 2019-10-28
-2019-03-19
+* Added `Reflex.Host.Basic.repeatUntilQuit_`, with the same behaviour
+ as 0.1's `Reflex.Host.Basic.repeatUntilQuit`.
+* `Reflex.Host.Basic.repeatUntilQuit` now returns an `Event` that
+ fires each time the action executes. If you don't need this,
+ consider `Reflex.Host.Basic.repeatUntilQuit_`.
+* `Reflex.Host.Basic.basicHostWithQuit`: Expect a guest that returns
+ only `Event t ()`, as trying to return an actual result gives
+ hard-to-diagnose type errors at the use site and most people
+ returned `()` anyway.
+* `Reflex.Host.Basic.basicHostForever`: Return `()` instead of `a` for
+ the same reason.
+* Do not fork a new thread when starting the host.
+* All hosts now run in separate reflex timelines.
+* Add example of a program with two independent hosts.
+
+## 0.1 - 2019-03-19
* Initial release
diff --git a/LICENSE b/LICENCE
index 43c16b8..43c16b8 100644
--- a/LICENSE
+++ b/LICENCE
diff --git a/example/Counter.hs b/example/Counter.hs
index 59e81e2..972ca8c 100644
--- a/example/Counter.hs
+++ b/example/Counter.hs
@@ -1,26 +1,32 @@
-{-# language FlexibleContexts, TypeFamilies #-}
-module Main where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TypeFamilies #-}
-import Reflex
-import Reflex.Host.Basic
+module Main where
import Control.Concurrent (threadDelay)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (liftIO)
+import Data.Functor (void)
+import Reflex
+import Reflex.Host.Basic
-myNetwork :: (Reflex t, MonadHold t m, MonadFix m) => Event t () -> m (Dynamic t Int)
-myNetwork eTick = count eTick
+myNetwork
+ :: (Reflex t, MonadHold t m, MonadFix m)
+ => Event t ()
+ -> m (Dynamic t Int)
+myNetwork = count
-myGuest :: BasicGuestConstraints t m => BasicGuest t m ((), Event t ())
-myGuest = do
- (eTick, sendTick) <- newTriggerEvent
- dCount <- myNetwork eTick
+myGuest :: BasicGuestConstraints t m => BasicGuest t m (Event t ())
+myGuest = mdo
+ eTick <- repeatUntilQuit (void $ threadDelay 1000000) eQuit
let
eCountUpdated = updated dCount
eQuit = () <$ ffilter (==5) eCountUpdated
- repeatUntilQuit (threadDelay 1000000 *> sendTick ()) eQuit
+ dCount <- myNetwork eTick
+
performEvent_ $ liftIO . print <$> eCountUpdated
- pure ((), eQuit)
+ pure eQuit
main :: IO ()
-main = basicHostWithQuit myGuest \ No newline at end of file
+main = basicHostWithQuit myGuest
diff --git a/example/Main.hs b/example/Main.hs
index 969813a..de43839 100644
--- a/example/Main.hs
+++ b/example/Main.hs
@@ -1,19 +1,17 @@
{-# LANGUAGE RecursiveDo #-}
-module Main (
- main
- ) where
-import Control.Monad (void)
-import Control.Monad.Trans (liftIO)
+module Main (main) where
+import Control.Monad.IO.Class (liftIO)
+import Data.Functor (($>), void)
import Reflex
-
-import Reflex.Host.Basic
+import Reflex.Host.Basic (basicHostWithQuit)
main :: IO ()
main = basicHostWithQuit $ mdo
ePostBuild <- getPostBuild
- eLine <- performEventAsync $ (\fn -> liftIO $ fn =<< getLine) <$ leftmost [void eMessage, ePostBuild]
+ eLine <- performEventAsync $ leftmost [void eMessage, ePostBuild] $> \fn ->
+ liftIO $ fn =<< getLine
let
eMessage = ffilter (/= "quit") eLine
@@ -21,4 +19,4 @@ main = basicHostWithQuit $ mdo
performEvent_ $ liftIO . putStrLn <$> eMessage
- pure ((), eQuit)
+ pure eQuit
diff --git a/example/Multithread.hs b/example/Multithread.hs
new file mode 100644
index 0000000..bf8434c
--- /dev/null
+++ b/example/Multithread.hs
@@ -0,0 +1,105 @@
+{-# language FlexibleContexts, TypeFamilies #-}
+module Main where
+
+{- |
+
+* Multithreaded Multi-Host Example
+
+This example boots two reflex networks which we will call "Left" and
+"Right". As they start, they each write an event trigger into an
+'MVar' and read an event trigger from another 'MVar', so that they can
+fire events into each other's network.
+
+Left and Right both log to stdout any lines received from each
+other. Left also reads lines from stdin, and lines are passed around
+as follows: Left passes incoming lines to Right, which immediately
+sends received lines back to Left.
+
+If "quit" is read from stdin, this triggers a shutdown of both FRP
+networks.
+
+-}
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar, takeMVar)
+import Control.Lens ((<&>))
+import Control.Monad (forever)
+import Control.Monad.IO.Class (liftIO)
+import Data.Functor (($>), void)
+import Data.Semigroup ((<>))
+import Data.Witherable (filter)
+import Prelude hiding (filter)
+import Reflex
+import Reflex.Host.Basic
+
+left
+ :: BasicGuestConstraints t m
+ => MVar (String -> IO ())
+ -> MVar (String -> IO ())
+ -> BasicGuest t m (Event t ())
+left mTriggerLeft mTriggerRight = do
+ -- Construct the event "lines from Right", and put its trigger in an MVar.
+ (eFromRight, triggerLeft) <- newTriggerEvent
+ liftIO $ putMVar mTriggerLeft triggerLeft
+
+ -- Kick off a loop to read from stdin. Ignore exceptions for brevity.
+ ePostBuild <- getPostBuild
+ eLines <- performEventAsync $ ePostBuild $> \fire ->
+ void . liftIO . forkIO . forever $ getLine >>= fire
+
+ -- Get the event trigger for the "lines from Left" event inside the
+ -- Right network, and fire it on each line.
+ triggerRight <- liftIO $ readMVar mTriggerRight
+ performEvent_ $ liftIO . triggerRight <$> eLines
+
+ -- Log events received from Right.
+ performEvent_ $ eFromRight <&> \msg ->
+ liftIO . putStrLn $ "From Right: " <> msg
+
+ -- Quit if we get a "quit" from Right.
+ pure . void $ filter (== "quit") eFromRight
+
+right
+ :: BasicGuestConstraints t m
+ => MVar (String -> IO ())
+ -> MVar (String -> IO ())
+ -> BasicGuest t m (Event t ())
+right mTriggerLeft mTriggerRight = do
+ -- Construct the event "lines from Left", and put its trigger in an MVar.
+ (eFromLeft, triggerRight) <- newTriggerEvent
+ liftIO $ putMVar mTriggerRight triggerRight
+
+ -- Get the event trigger for the "lines from Right" event inside the
+ -- Left network, and fire it on each line.
+ triggerLeft <- liftIO $ readMVar mTriggerLeft
+ performEvent_ $ liftIO . triggerLeft <$> eFromLeft
+
+ -- Log events received from Left.
+ performEvent_ $ eFromLeft <&> \msg ->
+ liftIO . putStrLn $ "From Left: " <> msg
+
+ -- Quit if we get a "quit" from Left.
+ pure . void $ filter (== "quit") eFromLeft
+
+main :: IO ()
+main = do
+ -- Removing these type annotations causes type errors like "a0 is
+ -- untouchable".
+ mTriggerLeft <- newEmptyMVar :: IO (MVar (String -> IO ()))
+ mTriggerRight <- newEmptyMVar :: IO (MVar (String -> IO ()))
+
+ mLeftDone <- newEmptyMVar
+ mRightDone <- newEmptyMVar
+
+ -- Not exception-safe, for brevity's sake.
+ void . forkIO $ do
+ basicHostWithQuit (left mTriggerLeft mTriggerRight)
+ putMVar mLeftDone ()
+
+ void . forkIO $ do
+ basicHostWithQuit (right mTriggerLeft mTriggerRight)
+ putMVar mRightDone ()
+
+ -- Wait for both threads
+ takeMVar mLeftDone
+ takeMVar mRightDone
diff --git a/reflex-basic-host.cabal b/reflex-basic-host.cabal
index aa18706..3d0f849 100644
--- a/reflex-basic-host.cabal
+++ b/reflex-basic-host.cabal
@@ -1,9 +1,10 @@
name: reflex-basic-host
-version: 0.1
+version: 0.2
license: BSD3
-license-file: LICENSE
+license-file: LICENCE
author: Dave Laing
maintainer: dave.laing.80@gmail.com
+copyright: Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
@@ -14,31 +15,32 @@ description: A basic `reflex` host for backend work.
tested-with: GHC == 8.0.2
, GHC == 8.2.2
, GHC == 8.4.4
- , GHC == 8.6.4
+ , GHC == 8.6.5
source-repository head
type: git
- location: git@github.com/qfpl/reflex-basic-host.git
+ location: git@github.com:qfpl/reflex-basic-host.git
library
exposed-modules: Reflex.Host.Basic
- build-depends: base >=4.9 && <4.13
- , primitive >= 0.6 && < 0.7
- , ref-tf >= 0.4 && < 0.5
- , dependent-sum >= 0.4 && < 0.5
- , dependent-map >= 0.2 && < 0.3
+ build-depends: base >=4.9 && <4.14
+ , dependent-map >= 0.2 && < 0.4
+ , dependent-sum >= 0.4 && < 0.7
+ , lens >= 3.6 && < 4.18
, mtl >= 2.2 && < 2.3
+ , primitive >= 0.6 && < 0.8
+ , ref-tf >= 0.4 && < 0.5
+ , reflex >= 0.6 && < 0.7
, stm >= 2.4 && < 2.6
- , reflex >= 0.5 && < 0.6
hs-source-dirs: src
ghc-options: -Wall
default-language: Haskell2010
executable example
main-is: Main.hs
- build-depends: base >=4.9 && <4.13
+ build-depends: base >=4.9 && <4.14
, mtl >= 2.2 && < 2.3
- , reflex >= 0.5 && < 0.6
+ , reflex >= 0.6 && < 0.7
, reflex-basic-host
hs-source-dirs: example
ghc-options: -Wall
@@ -46,10 +48,23 @@ executable example
executable counter
main-is: Counter.hs
- build-depends: base >=4.9 && <4.13
+ build-depends: base >=4.9 && <4.14
+ , mtl >= 2.2 && < 2.3
+ , reflex >= 0.6 && < 0.7
+ , reflex-basic-host
+ hs-source-dirs: example
+ ghc-options: -Wall
+ default-language: Haskell2010
+
+executable multithread
+ main-is: Multithread.hs
+ build-depends: base >=4.9 && <4.14
+ , lens >= 3.6 && < 4.18
, mtl >= 2.2 && < 2.3
- , reflex >= 0.5 && < 0.6
+ , ref-tf >= 0.4 && < 0.5
+ , reflex >= 0.6 && < 0.7
, reflex-basic-host
+ , witherable >= 0.2 && < 0.4
hs-source-dirs: example
ghc-options: -Wall
- default-language: Haskell2010 \ No newline at end of file
+ default-language: Haskell2010
diff --git a/src/Reflex/Host/Basic.hs b/src/Reflex/Host/Basic.hs
index 1a4a1de..15ba7be 100644
--- a/src/Reflex/Host/Basic.hs
+++ b/src/Reflex/Host/Basic.hs
@@ -16,48 +16,46 @@ Maintainer : dave.laing.80@gmail.com
* 'TriggerEvent'
* 'Adjustable'
-For some simple usage examples, see
-<https://github.com/qfpl/reflex-basic-host/tree/master/example the examples directory>
+For some usage examples, see
+<https://github.com/qfpl/reflex-basic-host/tree/master/example the example directory>
-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Reflex.Host.Basic (
- BasicGuest
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Reflex.Host.Basic
+ ( BasicGuest
, BasicGuestConstraints
, basicHostWithQuit
, basicHostForever
, repeatUntilQuit
+ , repeatUntilQuit_
) where
-import Control.Monad (void, when, unless, forM_, forM)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (newChan, readChan)
-import Data.Functor.Identity (Identity(..))
-import Data.Maybe (catMaybes, isJust)
-
-import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
+import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO)
+import Control.Lens ((<&>))
+import Control.Monad (void, when, unless)
+import Control.Monad.Fix (MonadFix)
import Control.Monad.Primitive (PrimMonad)
import Control.Monad.Ref (MonadRef(..))
-import Control.Monad.Fix (MonadFix)
-import Data.IORef (newIORef, readIORef, writeIORef)
-
import Control.Monad.STM (atomically)
-import Control.Concurrent.STM.TVar (newTVar, writeTVar, readTVar)
-import Control.Concurrent.STM.TMVar (newEmptyTMVar, takeTMVar, putTMVar)
-
-import Data.Dependent.Sum
+import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
+import Data.Dependent.Sum (DSum(..), (==>))
+import Data.Foldable (for_, traverse_)
+import Data.Functor.Identity (Identity)
+import Data.Maybe (catMaybes, isJust)
+import Data.Traversable (for)
import Reflex
import Reflex.Host.Class
-import Reflex.NotReady.Class
type BasicGuestConstraints t (m :: * -> *) =
( MonadReflexHost t m
@@ -77,7 +75,8 @@ newtype BasicGuest t (m :: * -> *) a =
unBasicGuest :: PostBuildT t (TriggerEventT t (PerformEventT t m)) a
} deriving (Functor, Applicative, Monad, MonadFix)
-instance (MonadIO m, ReflexHost t, MonadIO (HostFrame t)) => MonadIO (BasicGuest t m) where
+instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (BasicGuest t m) where
+ {-# INLINEABLE liftIO #-}
liftIO = BasicGuest . liftIO
instance ReflexHost t => MonadSample t (BasicGuest t m) where
@@ -87,150 +86,224 @@ instance ReflexHost t => MonadSample t (BasicGuest t m) where
instance (ReflexHost t, MonadHold t m) => MonadHold t (BasicGuest t m) where
{-# INLINABLE hold #-}
hold v0 = BasicGuest . lift . hold v0
+
{-# INLINABLE holdDyn #-}
holdDyn v0 = BasicGuest . lift . holdDyn v0
+
{-# INLINABLE holdIncremental #-}
holdIncremental v0 = BasicGuest . lift . holdIncremental v0
+
{-# INLINABLE buildDynamic #-}
buildDynamic a0 = BasicGuest . lift . buildDynamic a0
+
{-# INLINABLE headE #-}
headE = BasicGuest . lift . headE
-instance (Reflex t, ReflexHost t) => PostBuild t (BasicGuest t m) where
+instance ReflexHost t => PostBuild t (BasicGuest t m) where
{-# INLINABLE getPostBuild #-}
getPostBuild = BasicGuest getPostBuild
-instance (Reflex t, ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TriggerEvent t (BasicGuest t m) where
+instance
+ ( ReflexHost t
+ , MonadRef (HostFrame t)
+ , Ref (HostFrame t) ~ Ref IO
+ ) => TriggerEvent t (BasicGuest t m) where
+
{-# INLINABLE newTriggerEvent #-}
newTriggerEvent = BasicGuest $ lift newTriggerEvent
+
{-# INLINABLE newTriggerEventWithOnComplete #-}
- newTriggerEventWithOnComplete = BasicGuest $ lift newTriggerEventWithOnComplete
+ newTriggerEventWithOnComplete =
+ BasicGuest $ lift newTriggerEventWithOnComplete
+
{-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
- newEventWithLazyTriggerWithOnComplete = BasicGuest . lift . newEventWithLazyTriggerWithOnComplete
+ newEventWithLazyTriggerWithOnComplete =
+ BasicGuest . lift . newEventWithLazyTriggerWithOnComplete
+
+instance
+ ( ReflexHost t
+ , Ref m ~ Ref IO
+ , MonadRef (HostFrame t)
+ , Ref (HostFrame t) ~ Ref IO
+ , MonadIO (HostFrame t)
+ , PrimMonad (HostFrame t)
+ , MonadIO m
+ ) => PerformEvent t (BasicGuest t m) where
-instance (Reflex t, ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, MonadIO (HostFrame t), PrimMonad (HostFrame t), MonadIO m) => PerformEvent t (BasicGuest t m) where
type Performable (BasicGuest t m) = HostFrame t
+
{-# INLINABLE performEvent_ #-}
performEvent_ = BasicGuest . lift . lift . performEvent_
+
{-# INLINABLE performEvent #-}
performEvent = BasicGuest . lift . lift . performEvent
-instance (Reflex t, ReflexHost t, Ref m ~ Ref IO, MonadHold t m, PrimMonad (HostFrame t)) => Adjustable t (BasicGuest t m) where
+instance
+ ( ReflexHost t
+ , Ref m ~ Ref IO
+ , MonadHold t m
+ , PrimMonad (HostFrame t)
+ ) => Adjustable t (BasicGuest t m) where
+
{-# INLINABLE runWithReplace #-}
- runWithReplace a0 a' =
- BasicGuest $ runWithReplace (unBasicGuest a0) (fmap unBasicGuest a')
+ runWithReplace a0 a' = BasicGuest $
+ runWithReplace (unBasicGuest a0) (fmap unBasicGuest a')
+
{-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
- traverseIntMapWithKeyWithAdjust f dm0 dm' = do
- BasicGuest $ traverseIntMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm'
+ traverseIntMapWithKeyWithAdjust f dm0 dm' = BasicGuest $
+ traverseIntMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm'
+
{-# INLINABLE traverseDMapWithKeyWithAdjust #-}
- traverseDMapWithKeyWithAdjust f dm0 dm' = do
- BasicGuest $ traverseDMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm'
- {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
- traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
- BasicGuest $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unBasicGuest (f k v)) dm0 dm'
+ traverseDMapWithKeyWithAdjust f dm0 dm' = BasicGuest $
+ traverseDMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm'
+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = BasicGuest $
+ traverseDMapWithKeyWithAdjustWithMove (\k v -> unBasicGuest (f k v)) dm0 dm'
-instance (ReflexHost t) => NotReady t (BasicGuest t m) where
+instance ReflexHost t => NotReady t (BasicGuest t m) where
{-# INLINABLE notReadyUntil #-}
notReadyUntil _ = pure ()
+
{-# INLINABLE notReady #-}
notReady = pure ()
--- | Run a 'BasicGuest' without a quit 'Event'
-basicHostForever :: (forall t m. BasicGuestConstraints t m => BasicGuest t m a)
- -> IO a
-basicHostForever guest = basicHostWithQuit $ (\x -> (x, never)) <$> guest
-
--- | Run a 'BasicGuest'
+-- | Run a 'BasicGuest' without a quit 'Event'.
--
--- The program will exit when the 'Event' returned by the 'BasicGuest' fires
-basicHostWithQuit :: (forall t m. BasicGuestConstraints t m => BasicGuest t m (a, Event t ()))
- -> IO a
-basicHostWithQuit (BasicGuest guest) = do
- events <- liftIO newChan
-
- rHasQuit <- liftIO $ newIORef False
+-- @
+-- basicHostForever guest = 'basicHostWithQuit' $ never <$ guest
+-- @
+basicHostForever
+ :: (forall t m. BasicGuestConstraints t m => BasicGuest t m ())
+ -> IO ()
+basicHostForever guest = basicHostWithQuit $ never <$ guest
- ((a, eQuit), FireCommand fire) <- liftIO $ runSpiderHost $ do
- (((a, eQuit), postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ do
- (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
- pae <- runTriggerEventT (runPostBuildT guest postBuild) events
- pure (pae, postBuildTriggerRef)
+-- | Run a 'BasicGuest', and return when the 'Event' returned by the
+-- 'BasicGuest' fires.
+--
+-- Each call runs on a separate spider timeline, so you can launch
+-- multiple hosts via 'Control.Concurrent.forkIO' or
+-- 'Control.Concurrent.forkOS' and they will not mutex each other.
+--
+-- NOTE: If you want to capture values from a build before the network
+-- starts firing (e.g., to hand off event triggers to another thread),
+-- populate an 'Control.Concurrent.MVar' (if threading) or
+-- 'Data.IORef.IORef' as you build the network. If you receive errors
+-- about untouchable type variables while doing this, add type
+-- annotations to constrain the 'Control.Concurrent.MVar' or
+-- 'Data.IORef.IORef' contents before passing them to the function
+-- that returns your 'BasicGuest'. See the @Multithread.hs@ example
+-- for a demonstration of this pattern, and where to put the type
+-- annotations.
+basicHostWithQuit
+ :: (forall t m. BasicGuestConstraints t m => BasicGuest t m (Event t ()))
+ -> IO ()
+basicHostWithQuit guest =
+ withSpiderTimeline $ runSpiderHostForTimeline $ do
+ -- Unpack the guest, get the quit event, the result of building the
+ -- network, and a function to kick off each frame.
+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
+ triggerEventChan <- liftIO newChan
+ rHasQuit <- newRef False -- When to shut down
+ (eQuit, FireCommand fire) <- hostPerformEventT
+ . flip runTriggerEventT triggerEventChan
+ . flip runPostBuildT postBuild
+ $ unBasicGuest guest
hQuit <- subscribeEvent eQuit
-
- mPostBuildTrigger <- readRef postBuildTriggerRef
- forM_ mPostBuildTrigger $ \postBuildTrigger -> do
- lmQuit <- fire [postBuildTrigger :=> Identity ()] $ readEvent hQuit >>= sequence
- when (any isJust lmQuit) $
- liftIO $ writeIORef rHasQuit True
-
- pure ((a, eQuit), fc)
-
- done <- liftIO . atomically $ newEmptyTMVar
- let
- loop = do
- hasQuit <- liftIO $ readIORef rHasQuit
- if hasQuit
- then liftIO . atomically $ putTMVar done ()
- else do
- ers <- readChan events
- _ <- runSpiderHost $ do
- hQuit <- subscribeEvent eQuit
- mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation x _) ->
- fmap (\e -> e :=> Identity x) <$> readIORef er
-
- lmQuit <- fire (catMaybes mes) $ readEvent hQuit >>= sequence
- when (any isJust lmQuit) $
- liftIO $ writeIORef rHasQuit True
-
- liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
- loop
-
- void . liftIO . forkIO $ loop
- void . liftIO . atomically . takeTMVar $ done
-
- pure a
-
--- | Augment a 'BasicGuest' with an action that is repeatedly run until
--- the provided event fires
+ let
+ runFrameAndCheckQuit firings = do
+ lmQuit <- fire firings $ readEvent hQuit >>= sequenceA
+ when (any isJust lmQuit) $ writeRef rHasQuit True
+
+ -- If anyone is listening to PostBuild, fire it
+ readRef postBuildTriggerRef
+ >>= traverse_ (\t -> runFrameAndCheckQuit [t ==> ()])
+
+ let
+ loop = do
+ hasQuit <- readRef rHasQuit
+ unless hasQuit $ do
+ eventsAndTriggers <- liftIO $ readChan triggerEventChan
+
+ let
+ prepareFiring
+ :: (MonadRef m, Ref m ~ Ref IO)
+ => DSum (EventTriggerRef t) TriggerInvocation
+ -> m (Maybe (DSum (EventTrigger t) Identity))
+ prepareFiring (EventTriggerRef er :=> TriggerInvocation x _)
+ = readRef er <&> fmap (==> x)
+
+ catMaybes <$> for eventsAndTriggers prepareFiring
+ >>= runFrameAndCheckQuit
+
+ -- Fire callbacks for each event we triggered this frame
+ liftIO . for_ eventsAndTriggers $
+ \(_ :=> TriggerInvocation _ cb) -> cb
+ loop
+ loop
+
+-- | Augment a 'BasicGuest' with an action that is repeatedly run
+-- until the provided 'Event' fires. Each time the action completes,
+-- the returned 'Event' will fire.
--
-- Example - providing a \'tick\' 'Event' to a network
--
-- @
--- myNetwork :: (Reflex t, MonadHold t m, MonadFix m) => Event t () -> m (Dynamic t Int)
--- myNetwork eTick = count eTick
+-- myNetwork
+-- :: (Reflex t, MonadHold t m, MonadFix m)
+-- => Event t ()
+-- -> m (Dynamic t Int)
+-- myNetwork = count
--
--- myGuest :: BasicGuestConstraints t m => BasicGuest t m ((), Event t ())
--- myGuest = do
--- (eTick, sendTick) <- newTriggerEvent
--- dCount <- myNetwork eTick
+-- myGuest :: BasicGuestConstraints t m => BasicGuest t m (Event t ())
+-- myGuest = mdo
+-- eTick <- repeatUntilQuit (void $ threadDelay 1000000) eQuit
-- let
-- eCountUpdated = updated dCount
-- eQuit = () <$ ffilter (==5) eCountUpdated
--- repeatUntilQuit eQuit (threadDelay 1000000 *> sendTick ())
+-- dCount <- myNetwork eTick
+--
-- performEvent_ $ liftIO . print \<$\> eCountUpdated
--- pure ((), eQuit)
+-- pure eQuit
--
-- main :: IO ()
-- main = basicHostWithQuit myGuest
-- @
-repeatUntilQuit :: BasicGuestConstraints t m
- => IO a -- ^ Action to repeatedly run
- -> Event t () -- ^ 'Event' to stop the action
- -> BasicGuest t m ()
+repeatUntilQuit
+ :: BasicGuestConstraints t m
+ => IO a -- ^ Action to repeatedly run
+ -> Event t () -- ^ 'Event' to stop the action
+ -> BasicGuest t m (Event t a)
repeatUntilQuit act eQuit = do
ePostBuild <- getPostBuild
- tHasQuit <- liftIO . atomically $ newTVar False
+ tHasQuit <- liftIO $ newTVarIO False
let
- loop = do
- hasQuit <- liftIO . atomically $ readTVar tHasQuit
- unless hasQuit $ do
- void act
- loop
+ go fire = loop where
+ loop = do
+ hasQuit <- readTVarIO tHasQuit
+ unless hasQuit $ (act >>= fire) *> loop
- performEvent_ $ liftIO (void . forkIO $ loop) <$ ePostBuild
performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit
+ performEventAsync $ liftIO . void . forkIO . go <$ ePostBuild
+
+-- | Like 'repeatUntilQuit', but it doesn't do anything with the
+-- result of the action. May be a little more efficient if you don't
+-- need it.
+repeatUntilQuit_
+ :: BasicGuestConstraints t m
+ => IO a -- ^ Action to repeatedly run
+ -> Event t () -- ^ 'Event' to stop the action
+ -> BasicGuest t m ()
+repeatUntilQuit_ act eQuit = do
+ ePostBuild <- getPostBuild
+ tHasQuit <- liftIO $ newTVarIO False
- pure ()
+ let
+ loop = do
+ hasQuit <- readTVarIO tHasQuit
+ unless hasQuit $ act *> loop
+
+ performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit
+ performEvent_ $ liftIO (void $ forkIO loop) <$ ePostBuild