@@ -0,0 +1,128 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE ConstraintKinds #-}
7+module Reflex.Host.Headless where
9+import Control.Concurrent.Chan (newChan, readChan)
10+import Control.Monad.Fix (MonadFix, fix)
11+import Control.Monad.IO.Class (MonadIO, liftIO)
12+import Control.Monad.Primitive (PrimMonad)
13+import Control.Monad.Ref (MonadRef, Ref, readRef)
14+import Data.Dependent.Sum (DSum (..), (==>))
15+import Data.Foldable (for_)
16+import Data.Functor.Identity (Identity(..))
17+import Data.IORef (IORef, readIORef)
18+import Data.Maybe (catMaybes)
19+import Data.Traversable (for)
22+import Reflex.Host.Class
24+type MonadHeadlessApp t m =
28+ , MonadIO (HostFrame t)
29+ , MonadIO (Performable m)
31+ , MonadRef (HostFrame t)
35+ , PrimMonad (HostFrame t)
36+ , Ref (HostFrame t) ~ IORef
43+-- | Run a headless FRP network. Inside the action, you will most probably use
44+-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type
45+-- classes to interface the FRP network with the outside world. Useful for
48+ :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
49+ -- ^ The action to be run in the headless FRP network. The FRP network is
50+ -- closed at the first occurrence of the resulting 'Event'.
52+runHeadlessApp guest =
53+ -- We are using the 'Spider' implementation of reflex. Running the host
54+ -- allows us to take actions on the FRP timeline. The scoped type signature
55+ -- specifies that our host runs on the Global timeline.
56+ -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'.
57+ (runSpiderHost :: SpiderHost Global a -> IO a) $ do
58+ -- Create the "post-build" event and associated trigger. This event fires
59+ -- once, when the application starts.
60+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
61+ -- Create a queue to which we will write 'Event's that need to be
63+ events <- liftIO newChan
64+ -- Run the "guest" application, providing the appropriate context. We'll
65+ -- pure the result of the action, and a 'FireCommand' that will be used to
67+ (result, fc@(FireCommand fire)) <- do
68+ hostPerformEventT $ -- Allows the guest app to run
69+ -- 'performEvent', so that actions
70+ -- (e.g., IO actions) can be run when
73+ flip runPostBuildT postBuild $ -- Allows the guest app to access to
74+ -- a "post-build" 'Event'
76+ flip runTriggerEventT events $ -- Allows the guest app to create new
77+ -- events and triggers and write
78+ -- those triggers to a channel from
79+ -- which they will be read and
83+ -- Read the trigger reference for the post-build event. This will be
84+ -- 'Nothing' if the guest application hasn't subscribed to this event.
85+ mPostBuildTrigger <- readRef postBuildTriggerRef
87+ -- When there is a subscriber to the post-build event, fire the event.
88+ for_ mPostBuildTrigger $ \postBuildTrigger ->
89+ fire [postBuildTrigger :=> Identity ()] $ pure ()
91+ -- Subscribe to an 'Event' of that the guest application can use to
92+ -- request application shutdown. We'll check whether this 'Event' is firing
93+ -- to determine whether to terminate.
94+ shutdown <- subscribeEvent result
96+ -- The main application loop. We wait for new events and fire those that
97+ -- have subscribers. If we detect a shutdown request, the application
100+ -- Read the next event (blocking).
101+ ers <- liftIO $ readChan events
103+ -- Fire events that have subscribers.
104+ fireEventTriggerRefs fc ers $
105+ -- Check if the shutdown 'Event' is firing.
106+ readEvent shutdown >>= \case
107+ Nothing -> pure False
113+ -- Use the given 'FireCommand' to fire events that have subscribers
114+ -- and call the callback for the 'TriggerInvocation' of each.
115+ fireEventTriggerRefs
118+ -> [DSum (EventTriggerRef t) TriggerInvocation]
121+ fireEventTriggerRefs (FireCommand fire) ers rcb = do
123+ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
125+ pure $ fmap (==> a) me
126+ a <- fire (catMaybes mes) rcb
127+ liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb