git.iko.soy/reflex
on master help sign in
reflex/src/Reflex/Host/Headless.hs
128 lines 5.0 kB history raw
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE ConstraintKinds #-}
7module Reflex.Host.Headless where
9import Control.Concurrent.Chan (newChan, readChan)
10import Control.Monad (unless)
11import Control.Monad.Fix (MonadFix, fix)
12import Control.Monad.IO.Class (MonadIO, liftIO)
13import Control.Monad.Primitive (PrimMonad)
14import Control.Monad.Ref (MonadRef, Ref, readRef)
15import Data.Dependent.Sum (DSum (..), (==>))
16import Data.Foldable (for_)
17import Data.Functor.Identity (Identity(..))
18import Data.IORef (IORef, readIORef)
19import Data.Maybe (catMaybes, fromMaybe)
20import Data.Traversable (for)
22import Reflex
23import Reflex.Host.Class
25type MonadHeadlessApp t m =
26 ( Adjustable t m
27 , MonadFix m
28 , MonadHold t m
29 , MonadIO (HostFrame t)
30 , MonadIO (Performable m)
31 , MonadIO m
32 , MonadRef (HostFrame t)
33 , NotReady t m
34 , PerformEvent t m
35 , PostBuild t m
36 , PrimMonad (HostFrame t)
37 , Ref (HostFrame t) ~ IORef
38 , Ref m ~ IORef
39 , Reflex t
40 , ReflexHost t
41 , TriggerEvent t m
42 )
44-- | Run a headless FRP network. Inside the action, you will most probably use
45-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type
46-- classes to interface the FRP network with the outside world. Useful for
47-- testing. Each headless network runs on its own spider timeline.
48runHeadlessApp
49 :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
50 -- ^ The action to be run in the headless FRP network. The FRP network is
51 -- closed at the first occurrence of the resulting 'Event'.
52 -> IO ()
53runHeadlessApp guest =
54 -- We are using the 'Spider' implementation of reflex. Running the host
55 -- allows us to take actions on the FRP timeline.
56 withSpiderTimeline $ runSpiderHostForTimeline $ do
57 -- Create the "post-build" event and associated trigger. This event fires
58 -- once, when the application starts.
59 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
60 -- Create a queue to which we will write 'Event's that need to be
61 -- processed.
62 events <- liftIO newChan
63 -- Run the "guest" application, providing the appropriate context. We'll
64 -- pure the result of the action, and a 'FireCommand' that will be used to
65 -- trigger events.
66 (result, fc@(FireCommand fire)) <- do
67 hostPerformEventT $ -- Allows the guest app to run
68 -- 'performEvent', so that actions
69 -- (e.g., IO actions) can be run when
70 -- 'Event's fire.
72 flip runPostBuildT postBuild $ -- Allows the guest app to access to
73 -- a "post-build" 'Event'
75 flip runTriggerEventT events $ -- Allows the guest app to create new
76 -- events and triggers and write
77 -- those triggers to a channel from
78 -- which they will be read and
79 -- processed.
80 guest
82 -- Read the trigger reference for the post-build event. This will be
83 -- 'Nothing' if the guest application hasn't subscribed to this event.
84 mPostBuildTrigger <- readRef postBuildTriggerRef
86 -- Subscribe to an 'Event' of that the guest application can use to
87 -- request application shutdown. We'll check whether this 'Event' is firing
88 -- to determine whether to terminate.
89 shutdown <- subscribeEvent result
91 -- When there is a subscriber to the post-build event, fire the event.
92 soa <- for mPostBuildTrigger $ \postBuildTrigger ->
93 fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown
95 -- The main application loop. We wait for new events and fire those that
96 -- have subscribers. If we detect a shutdown request, the application
97 -- terminates.
98 unless (or (fromMaybe [] soa)) $ fix $ \loop -> do
99 -- Read the next event (blocking).
100 ers <- liftIO $ readChan events
101 stop <- do
102 -- Fire events that have subscribers.
103 fireEventTriggerRefs fc ers $
104 -- Check if the shutdown 'Event' is firing.
105 isFiring shutdown
106 if or stop
107 then pure ()
108 else loop
109 where
110 isFiring ev = readEvent ev >>= \case
111 Nothing -> pure False
112 Just _ -> pure True
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