diff --git a/reflex.cabal b/reflex.cabal index 796757d2..bb9e63e8 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -119,6 +119,7 @@ library Reflex.FastWeak, Reflex.FunctorMaybe, Reflex.Host.Class, + Reflex.Host.Headless, Reflex.Network, Reflex.NotReady.Class, Reflex.PerformEvent.Base, diff --git a/src/Reflex/Host/Headless.hs b/src/Reflex/Host/Headless.hs new file mode 100644 index 00000000..752598ab --- /dev/null +++ b/src/Reflex/Host/Headless.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} + +module Reflex.Host.Headless where + +import Control.Concurrent.Chan (newChan, readChan) +import Control.Monad.Fix (MonadFix, fix) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Ref (MonadRef, Ref, readRef) +import Data.Dependent.Sum (DSum (..), (==>)) +import Data.Foldable (for_) +import Data.Functor.Identity (Identity(..)) +import Data.IORef (IORef, readIORef) +import Data.Maybe (catMaybes) +import Data.Traversable (for) + +import Reflex +import Reflex.Host.Class + +type MonadHeadlessApp t m = + ( Adjustable t m + , MonadFix m + , MonadHold t m + , MonadIO (HostFrame t) + , MonadIO (Performable m) + , MonadIO m + , MonadRef (HostFrame t) + , NotReady t m + , PerformEvent t m + , PostBuild t m + , PrimMonad (HostFrame t) + , Ref (HostFrame t) ~ IORef + , Ref m ~ IORef + , Reflex t + , ReflexHost t + , TriggerEvent t m + ) + +-- | Run a headless FRP network. Inside the action, you will most probably use +-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type +-- classes to interface the FRP network with the outside world. Useful for +-- testing. +runHeadlessApp + :: (forall t m. MonadHeadlessApp t m => m (Event t ())) + -- ^ The action to be run in the headless FRP network. The FRP network is + -- closed at the first occurrence of the resulting 'Event'. + -> IO () +runHeadlessApp guest = + -- We are using the 'Spider' implementation of reflex. Running the host + -- allows us to take actions on the FRP timeline. The scoped type signature + -- specifies that our host runs on the Global timeline. + -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'. + (runSpiderHost :: SpiderHost Global a -> IO a) $ do + -- Create the "post-build" event and associated trigger. This event fires + -- once, when the application starts. + (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef + -- Create a queue to which we will write 'Event's that need to be + -- processed. + events <- liftIO newChan + -- Run the "guest" application, providing the appropriate context. We'll + -- pure the result of the action, and a 'FireCommand' that will be used to + -- trigger events. + (result, fc@(FireCommand fire)) <- do + hostPerformEventT $ -- Allows the guest app to run + -- 'performEvent', so that actions + -- (e.g., IO actions) can be run when + -- 'Event's fire. + + flip runPostBuildT postBuild $ -- Allows the guest app to access to + -- a "post-build" 'Event' + + flip runTriggerEventT events $ -- Allows the guest app to create new + -- events and triggers and write + -- those triggers to a channel from + -- which they will be read and + -- processed. + guest + + -- Read the trigger reference for the post-build event. This will be + -- 'Nothing' if the guest application hasn't subscribed to this event. + mPostBuildTrigger <- readRef postBuildTriggerRef + + -- When there is a subscriber to the post-build event, fire the event. + for_ mPostBuildTrigger $ \postBuildTrigger -> + fire [postBuildTrigger :=> Identity ()] $ pure () + + -- Subscribe to an 'Event' of that the guest application can use to + -- request application shutdown. We'll check whether this 'Event' is firing + -- to determine whether to terminate. + shutdown <- subscribeEvent result + + -- The main application loop. We wait for new events and fire those that + -- have subscribers. If we detect a shutdown request, the application + -- terminates. + fix $ \loop -> do + -- Read the next event (blocking). + ers <- liftIO $ readChan events + stop <- do + -- Fire events that have subscribers. + fireEventTriggerRefs fc ers $ + -- Check if the shutdown 'Event' is firing. + readEvent shutdown >>= \case + Nothing -> pure False + Just _ -> pure True + if or stop + then pure () + else loop + where + -- Use the given 'FireCommand' to fire events that have subscribers + -- and call the callback for the 'TriggerInvocation' of each. + fireEventTriggerRefs + :: MonadIO m + => FireCommand t m + -> [DSum (EventTriggerRef t) TriggerInvocation] + -> ReadPhase m a + -> m [a] + fireEventTriggerRefs (FireCommand fire) ers rcb = do + mes <- liftIO $ + for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do + me <- readIORef er + pure $ fmap (==> a) me + a <- fire (catMaybes mes) rcb + liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb + pure a