@@ -0,0 +1,128 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+
7+module Reflex.Host.Headless where
8+
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)
20+
21+import Reflex
22+import Reflex.Host.Class
23+
24+type MonadHeadlessApp t m =
25+ ( Adjustable t m
26+ , MonadFix m
27+ , MonadHold t m
28+ , MonadIO (HostFrame t)
29+ , MonadIO (Performable m)
30+ , MonadIO m
31+ , MonadRef (HostFrame t)
32+ , NotReady t m
33+ , PerformEvent t m
34+ , PostBuild t m
35+ , PrimMonad (HostFrame t)
36+ , Ref (HostFrame t) ~ IORef
37+ , Ref m ~ IORef
38+ , Reflex t
39+ , ReflexHost t
40+ , TriggerEvent t m
41+ )
42+
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
46+-- testing.
47+runHeadlessApp
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'.
51+ -> IO ()
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
62+ -- processed.
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
66+ -- trigger events.
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
71+ -- 'Event's fire.
72+
73+ flip runPostBuildT postBuild $ -- Allows the guest app to access to
74+ -- a "post-build" 'Event'
75+
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
80+ -- processed.
81+ guest
82+
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
86+
87+ -- When there is a subscriber to the post-build event, fire the event.
88+ for_ mPostBuildTrigger $ \postBuildTrigger ->
89+ fire [postBuildTrigger :=> Identity ()] $ pure ()
90+
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
95+
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
98+ -- terminates.
99+ fix $ \loop -> do
100+ -- Read the next event (blocking).
101+ ers <- liftIO $ readChan events
102+ stop <- do
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
108+ Just _ -> pure True
109+ if or stop
110+ then pure ()
111+ else loop
112+ where
113+ -- Use the given 'FireCommand' to fire events that have subscribers
114+ -- and call the callback for the 'TriggerInvocation' of each.
115+ fireEventTriggerRefs
116+ :: MonadIO m
117+ => FireCommand t m
118+ -> [DSum (EventTriggerRef t) TriggerInvocation]
119+ -> ReadPhase m a
120+ -> m [a]
121+ fireEventTriggerRefs (FireCommand fire) ers rcb = do
122+ mes <- liftIO $
123+ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
124+ me <- readIORef er
125+ pure $ fmap (==> a) me
126+ a <- fire (catMaybes mes) rcb
127+ liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
128+ pure a