git.iko.soy/reflex-vty
on develop help sign in
Begin documentation
9fd5491Ali Abrar
src/Reflex/Vty.hs+164−71
compare with develop
unifiedsplit
@@ -5,7 +5,12 @@
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
7
7
8−module Reflex.Vty where
8+module Reflex.Vty
9+ ( VtyApp
10+ , VtyResult(..)
11+ , runVtyApp
12+ , runVtyAppWith
13+ ) where
9
14
10import Control.Concurrent (forkIO, killThread)
15import Control.Concurrent (forkIO, killThread)
11import Control.Concurrent.Chan (newChan, readChan, writeChan)
16import Control.Concurrent.Chan (newChan, readChan, writeChan)
@@ -24,82 +29,170 @@ import Reflex
24import Reflex.Host.Class
29import Reflex.Host.Class
25import qualified Graphics.Vty as V
30import qualified Graphics.Vty as V
26
31
32+-- | The output of a 'VtyApp'
27data VtyResult t = VtyResult
33data VtyResult t = VtyResult
28 { _vtyResult_picture :: Behavior t V.Picture
34 { _vtyResult_picture :: Behavior t V.Picture
29− , _vtyResult_refresh :: Event t ()
35+ -- ^ The current vty output. 'runVtyAppWith' samples this value every time an
36+ -- event fires and updates the display.
30 , _vtyResult_shutdown :: Event t ()
37 , _vtyResult_shutdown :: Event t ()
38+ -- ^ An event that requests application termination.
31 }
39 }
32
40
41+-- | A functional reactive vty application
33−type VtyApp t m = ( Reflex t
42+type VtyApp t m =
43+ ( Reflex t
34− , MonadHold t m
44+ , MonadHold t m
35− , MonadFix m
45+ , MonadFix m
36− , PrimMonad (HostFrame t)
46+ , PrimMonad (HostFrame t)
37− , ReflexHost t
47+ , ReflexHost t
38− , MonadIO (HostFrame t)
48+ , MonadIO (HostFrame t)
39− , Ref m ~ IORef
49+ , Ref m ~ IORef
40− , Ref (HostFrame t) ~ IORef
50+ , Ref (HostFrame t) ~ IORef
41− , MonadRef (HostFrame t)
51+ , MonadRef (HostFrame t)
42− )
52+ )
43− => Event t (V.Event)
53+ => Event t (V.Event)
54+ -- ^ Vty input events
44− -> TriggerEventT t (PostBuildT t (PerformEventT t m)) (VtyResult t)
55+ -> TriggerEventT t (PostBuildT t (PerformEventT t m)) (VtyResult t)
45−
56+ -- ^ The output of the 'VtyApp'. The application runs in a context that
46−host
57+ -- allows new events to be created and triggered ('TriggerEventT'), provides
58+ -- access to an event that fires immediately upon app instantiation
59+ -- ('PostBuildT'), and allows actions to be run upon occurrences
60+ -- of events ('PerformEventT').
61+
62+-- | Runs a 'VtyApp' in a given 'Vty'
63+runVtyAppWith
64+ :: V.Vty
65+ -- ^ A 'Vty' handle
66+ -> (forall t m. VtyApp t m)
67+ -- ^ A functional reactive vty application
68+ -> IO ()
69+runVtyAppWith vty vtyGuest =
70+ -- We are using the 'Spider' implementation of reflex. Running the host
71+ -- allows us to take actions on the FRP timeline. For more information, see
72+ -- 'Reflex.Spider.Internal.runSpiderHost'.
73+ runSpiderHost $ do
74+
75+ -- Create an 'Event' and a "trigger" reference for that event. The trigger
76+ -- reference can be used to determine whether anyone is "subscribed" to
77+ -- that 'Event' and, therefore, whether we need to bother performing any
78+ -- updates when the 'Event' fires.
79+ -- The 'Event' below will be used to convey vty input events.
80+ (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef
81+
82+ -- Create the "post-build" event and associated trigger. This event fires
83+ -- once, when the application starts.
84+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
85+
86+ -- Create a queue to which we will write 'Event's that need to be
87+ -- processed.
88+ events <- liftIO newChan
89+
90+ -- Run the vty "guest" application, providing the appropriate context. The
91+ -- result is a 'VtyResult', and a 'FireCommand' that will be used to
92+ -- trigger events.
93+ (vtyResult, fc@(FireCommand fire)) <- do
94+ hostPerformEventT $ -- TODO document
95+
96+ flip runPostBuildT postBuild $ -- Runs the guest app in a context
97+ -- that provides access to a
98+ -- "post-build" 'Event'
99+
100+ flip runTriggerEventT events $ -- Runs the guest app in a context
101+ -- that allows new events and
102+ -- triggers to be created and writes
103+ -- those triggers to a channel from
104+ -- which they will be read and
105+ -- triggered.
106+
107+ vtyGuest vtyEvent -- The guest app is provided an
108+ -- 'Event' of vty inputs
109+
110+ -- Reads the current value of the 'Picture' behavior and updates the
111+ -- display with it. This will be called whenever we determine that a
112+ -- display update is necessary. In this implementation that is when various
113+ -- events occur.
114+ let updateVty =
115+ sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty
116+
117+ -- Read the trigger reference for the post-build event. This will be
118+ -- 'Nothing' if the guest application hasn't subscribed to this event.
119+ mPostBuildTrigger <- readRef postBuildTriggerRef
120+
121+ -- When there is a subscriber to the post-build event, fire the event.
122+ forM_ mPostBuildTrigger $ \postBuildTrigger ->
123+ fire [postBuildTrigger :=> Identity ()] $ return ()
124+
125+ -- After firing the post-build event, sample the vty result and update
126+ -- the display.
127+ updateVty
128+
129+ -- Subscribe to an 'Event' of that the guest application can use to
130+ -- request application shutdown. We'll check whether this 'Event' is firing
131+ -- to determine whether to terminate.
132+ shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult
133+
134+ -- Fork a thread and continuously get the next vty input event, and then
135+ -- write the input event to our channel of FRP 'Event' triggers.
136+ -- The thread is forked here because 'nextEvent' blocks.
137+ nextEventThread <- liftIO $ forkIO $ forever $ do
138+ -- Retrieve the next input event.
139+ ne <- V.nextEvent vty
140+ let -- The reference to the vty input 'EventTrigger'. This is the trigger
141+ -- we'd like to associate the input event value with.
142+ triggerRef = EventTriggerRef vtyEventTriggerRef
143+ -- Create an event 'TriggerInvocation' with the value that we'd like
144+ -- the event to have if it is fired. It may not fire with this value
145+ -- if nobody is subscribed to the 'Event'.
146+ triggerInvocation = TriggerInvocation ne $ return ()
147+ -- Write our input event's 'EventTrigger' with the newly created
148+ -- 'TriggerInvocation' value to the queue of events.
149+ writeChan events $ [triggerRef :=> triggerInvocation]
150+
151+ -- The main application loop. We wait for new events, fire those that
152+ -- have subscribers, and update the display. If we detect a shutdown
153+ -- request, the application terminates.
154+ fix $ \loop -> do
155+ -- Read the next event (blocking)
156+ ers <- liftIO $ readChan events
157+ stop <- do
158+ -- Fire events that have subscribers.
159+ fireEventTriggerRefs fc ers $
160+ -- Check if the shutdown 'Event' is firing.
161+ readEvent shutdown >>= \case
162+ Nothing -> return False
163+ Just _ -> return True
164+ if or stop
165+ then liftIO $ do -- If we received a shutdown 'Event'
166+ killThread nextEventThread -- then stop reading input events and
167+ V.shutdown vty -- call the 'Vty's shutdown command.
168+
169+ else do -- Otherwise, update the display and loop
170+ updateVty
171+ loop
172+ where
173+ -- TODO Some part of this is probably general enough to belong in reflex
174+ -- | Use the given 'FireCommand' to fire events that have subscribers
175+ -- and call the callback for the 'TriggerInvocation' of each.
176+ fireEventTriggerRefs
177+ :: (Monad (ReadPhase m), MonadIO m)
178+ => FireCommand t m
179+ -> [DSum (EventTriggerRef t) TriggerInvocation]
180+ -> ReadPhase m a
181+ -> m [a]
182+ fireEventTriggerRefs (FireCommand fire) ers rcb = do
183+ mes <- liftIO $
184+ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
185+ me <- readIORef er
186+ return $ fmap (\e -> e :=> Identity a) me
187+ a <- fire (catMaybes mes) rcb
188+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
189+ return a
190+
191+-- | Run a 'VtyApp' with a 'Vty' handle with a standard configuration.
192+runVtyApp
47 :: (forall t m. VtyApp t m)
193 :: (forall t m. VtyApp t m)
48 -> IO ()
194 -> IO ()
49−host vtyGuest = runSpiderHost $ do
195+runVtyApp app = do
50 cfg <- liftIO V.standardIOConfig
196 cfg <- liftIO V.standardIOConfig
51 vty <- liftIO $ V.mkVty cfg
197 vty <- liftIO $ V.mkVty cfg
52−
198+ runVtyAppWith vty app
53− (e, eTriggerRef) <- newEventWithTriggerRef
54− (pb, pbTriggerRef) <- newEventWithTriggerRef
55−
56− events <- liftIO newChan
57−
58− (r, fc@(FireCommand fire)) <- hostPerformEventT $
59− flip runPostBuildT pb $
60− flip runTriggerEventT events $
61− vtyGuest e
62−
63− let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
64−
65− mPostBuildTrigger <- readRef pbTriggerRef
66− forM_ mPostBuildTrigger $ \postBuildTrigger ->
67− fire [postBuildTrigger :=> Identity ()] $ return ()
68− updateVty
69−
70− shutdown <- subscribeEvent $ _vtyResult_shutdown r
71−
72− nextEventThread <- liftIO $ forkIO $ forever $ do
73− ne <- V.nextEvent vty
74− writeChan events $ [EventTriggerRef eTriggerRef :=> TriggerInvocation ne (return ())]
75−
76− fix $ \loop -> do
77− ers <- liftIO $ readChan events
78− stop <- do
79− fireEventTriggerRefs fc ers $ do
80− readEvent shutdown >>= \case
81− Nothing -> return False
82− Just _ -> return True
83− if or stop
84− then liftIO $ do
85− killThread nextEventThread
86− V.shutdown vty
87− else do
88− updateVty
89− loop
90−
91−-- TODO Some part of this is probably general enough to belong in reflex
92−fireEventTriggerRefs
93− :: (Monad (ReadPhase m), MonadIO m)
94− => FireCommand t m
95− -> [DSum (EventTriggerRef t) TriggerInvocation]
96− -> ReadPhase m a
97− -> m [a]
98−fireEventTriggerRefs (FireCommand fire) ers rcb = do
99− mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
100− me <- readIORef er
101− return $ fmap (\e -> e :=> Identity a) me
102− let es = catMaybes mes
103− a <- fire es rcb
104− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
105− return a