{-|
Module : Reflex.Host.Basic
Copyright : (c) 2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO)
License : BSD-3
Maintainer : dave.laing.80@gmail.com
'BasicGuest' provides instances that most `reflex` programs need:
* 'MonadIO'
* 'MonadFix'
* 'MonadSample'
* 'MonadHold'
* 'NotReady'
* 'PostBuild'
* 'PerformEvent' — @'Performable' ('BasicGuest' t m)@ has 'MonadIO'
* 'TriggerEvent'
* 'Adjustable'
For some usage examples, see
<https://github.com/qfpl/reflex-basic-host/tree/master/example the example directory>
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Reflex.Host.Basic
( BasicGuest
, BasicGuestConstraints
, basicHostWithQuit
, basicHostForever
, repeatUntilQuit
, repeatUntilQuit_
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (newChan, readChan)
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.STM (atomically)
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
type BasicGuestConstraints t (m :: * -> *) =
( MonadReflexHost t m
, MonadHold t m
, MonadSample t m
, Ref m ~ Ref IO
, MonadRef (HostFrame t)
, Ref (HostFrame t) ~ Ref IO
, MonadIO (HostFrame t)
, PrimMonad (HostFrame t)
, MonadIO m
, MonadFix m
)
newtype BasicGuest t (m :: * -> *) a =
BasicGuest {
unBasicGuest :: PostBuildT t (TriggerEventT t (PerformEventT t m)) a
} deriving (Functor, Applicative, Monad, MonadFix)
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
{-# INLINABLE sample #-}
sample = BasicGuest . lift . sample
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 ReflexHost t => PostBuild t (BasicGuest t m) where
{-# INLINABLE getPostBuild #-}
getPostBuild = BasicGuest getPostBuild
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
{-# INLINABLE 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
type Performable (BasicGuest t m) = HostFrame t
{-# INLINABLE performEvent_ #-}
performEvent_ = BasicGuest . lift . lift . performEvent_
{-# INLINABLE performEvent #-}
performEvent = BasicGuest . lift . lift . performEvent
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')
{-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
traverseIntMapWithKeyWithAdjust f dm0 dm' = BasicGuest $
traverseIntMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm'
{-# INLINABLE traverseDMapWithKeyWithAdjust #-}
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
{-# INLINABLE notReadyUntil #-}
notReadyUntil _ = pure ()
{-# INLINABLE notReady #-}
notReady = pure ()
-- | Run a 'BasicGuest' without a quit 'Event'.
--
-- @
-- basicHostForever guest = 'basicHostWithQuit' $ never <$ guest
-- @
basicHostForever
:: (forall t m. BasicGuestConstraints t m => BasicGuest t m ())
-> IO ()
basicHostForever guest = basicHostWithQuit $ never <$ guest
-- | 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
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 = count
--
-- 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
-- dCount <- myNetwork eTick
--
-- performEvent_ $ liftIO . print \<$\> eCountUpdated
-- 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 (Event t a)
repeatUntilQuit act eQuit = do
ePostBuild <- getPostBuild
tHasQuit <- liftIO $ newTVarIO False
let
go fire = loop where
loop = do
hasQuit <- readTVarIO tHasQuit
unless hasQuit $ (act >>= fire) *> loop
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
let
loop = do
hasQuit <- readTVarIO tHasQuit
unless hasQuit $ act *> loop
performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit
performEvent_ $ liftIO (void $ forkIO loop) <$ ePostBuild