diff --git a/ChangeLog.md b/ChangeLog.md --- 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/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -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. diff --git a/example/Counter.hs b/example/Counter.hs --- 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 diff --git a/example/Main.hs b/example/Main.hs --- 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 @@ performEvent_ $ liftIO . putStrLn <$> eMessage - pure ((), eQuit) + pure eQuit diff --git a/example/Multithread.hs b/example/Multithread.hs new file mode 100644 --- /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 --- 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 @@ 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 diff --git a/src/Reflex/Host/Basic.hs b/src/Reflex/Host/Basic.hs --- a/src/Reflex/Host/Basic.hs +++ b/src/Reflex/Host/Basic.hs @@ -16,48 +16,46 @@ * 'TriggerEvent' * 'Adjustable' -For some simple usage examples, see - +For some usage examples, see + -} -{-# 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