reflex-basic-host 0.1 → 0.2
raw patch · 8 files changed
+391/−179 lines, 8 filesdep +lensdep +witherabledep ~basedep ~dependent-mapdep ~dependent-sumnew-component:exe:multithread
Dependencies added: lens, witherable
Dependency ranges changed: base, dependent-map, dependent-sum, primitive, reflex
Files
- ChangeLog.md +18/−3
- LICENCE +31/−0
- LICENSE +0/−31
- example/Counter.hs +18/−12
- example/Main.hs +7/−9
- example/Multithread.hs +105/−0
- reflex-basic-host.cabal +29/−14
- src/Reflex/Host/Basic.hs +183/−110
ChangeLog.md view
@@ -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
+ LICENCE view
@@ -0,0 +1,31 @@+Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation+(CSIRO) ABN 41 687 119 230.++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 Data61 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.
− LICENSE
@@ -1,31 +0,0 @@-Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation-(CSIRO) ABN 41 687 119 230.--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 Data61 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.
example/Counter.hs view
@@ -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
example/Main.hs view
@@ -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 @@ performEvent_ $ liftIO . putStrLn <$> eMessage - pure ((), eQuit)+ pure eQuit
+ example/Multithread.hs view
@@ -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
reflex-basic-host.cabal view
@@ -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 @@ 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 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.5 && < 0.6+ , 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+ , 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
src/Reflex/Host/Basic.hs view
@@ -16,48 +16,46 @@ * '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 @@ 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, 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 (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+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+ 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)+ let+ runFrameAndCheckQuit firings = do+ lmQuit <- fire firings $ readEvent hQuit >>= sequenceA+ when (any isJust lmQuit) $ writeRef rHasQuit True - 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+ -- If anyone is listening to PostBuild, fire it+ readRef postBuildTriggerRef+ >>= traverse_ (\t -> runFrameAndCheckQuit [t ==> ()]) - lmQuit <- fire (catMaybes mes) $ readEvent hQuit >>= sequence- when (any isJust lmQuit) $- liftIO $ writeIORef rHasQuit True+ let+ loop = do+ hasQuit <- readRef rHasQuit+ unless hasQuit $ do+ eventsAndTriggers <- liftIO $ readChan triggerEventChan - liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb- loop+ 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) - void . liftIO . forkIO $ loop- void . liftIO . atomically . takeTMVar $ done+ catMaybes <$> for eventsAndTriggers prepareFiring+ >>= runFrameAndCheckQuit - pure a+ -- 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+-- | 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 - pure ()+-- | 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++ let+ loop = do+ hasQuit <- readTVarIO tHasQuit+ unless hasQuit $ act *> loop++ performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit+ performEvent_ $ liftIO (void $ forkIO loop) <$ ePostBuild