@@ -7,26 +7,23 @@
77
88module Reflex.Vty where
99
10−import Reflex
11−import Reflex.Host.Class
12−import Control.Concurrent (forkIO)
13−import Control.Monad.Fix
10+import Control.Concurrent (forkIO, killThread)
11+import Control.Concurrent.Chan (newChan, readChan, writeChan)
12+import Control.Monad (forM, forM_, forever)
13+import Control.Monad.Fix (MonadFix, fix)
14+import Control.Monad.IO.Class (liftIO, MonadIO)
1415import Control.Monad.Identity (Identity(..))
15−import Control.Monad.IO.Class
16−import Data.IORef (readIORef)
16+import Control.Monad.Primitive (PrimMonad)
17+import Control.Monad.Ref (MonadRef, Ref, readRef)
1718import Data.Dependent.Sum (DSum ((:=>)))
18−import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
19+import Data.IORef (IORef)
20+import Data.IORef (readIORef)
21+import Data.Maybe (catMaybes)
22+import Data.Time (getCurrentTime)
1923
20−import Control.Concurrent.STM.TChan
21−import Control.Monad.STM (atomically)
22−import Data.Time
24+import Reflex
25+import Reflex.Host.Class
2326import qualified Graphics.Vty as V
24−import Control.Monad.Ref
25−import Data.IORef (IORef)
26−import Control.Monad.Primitive (PrimMonad)
27−import Control.Concurrent.Chan
28−import Control.Monad
29−import Data.Maybe
3027
3128data VtyResult t = VtyResult
3229 { _vtyResult_picture :: Behavior t V.Picture
@@ -57,16 +54,15 @@ host vtyGuest = runSpiderHost $ do
5754 (e, eTriggerRef) <- newEventWithTriggerRef
5855 (pb, pbTriggerRef) <- newEventWithTriggerRef
5956
60− someEvents <- liftIO newChan
57+ events <- liftIO newChan
6158
6259 (r, fc@(FireCommand fire)) <- hostPerformEventT $
6360 flip runPostBuildT pb $
64− flip runTriggerEventT someEvents $
61+ flip runTriggerEventT events $
6562 vtyGuest e
6663
6764 let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
6865
69− liftIO $ processAsyncEvents someEvents fc updateVty -- TODO is this the right way to handle screen updates for async events?
7066
7167 mPostBuildTrigger <- readRef pbTriggerRef
7268 forM_ mPostBuildTrigger $ \postBuildTrigger ->
@@ -75,25 +71,24 @@ host vtyGuest = runSpiderHost $ do
7571
7672 shutdown <- subscribeEvent $ _vtyResult_shutdown r
7773
78− vtyEvent <- liftIO newTChanIO
79− void $ liftIO $ forkIO $ forever $ atomically . writeTChan vtyEvent =<< V.nextEvent vty
74+ nextEventThread <- liftIO $ forkIO $ forever $ do
75+ ne <- V.nextEvent vty
76+ writeChan events $ [EventTriggerRef eTriggerRef :=> TriggerInvocation ne (return ())]
8077
8178 fix $ \loop -> do
82− mvtyEvent <- liftIO $ atomically $ tryReadTChan vtyEvent
83− mETrigger <- liftIO $ readIORef eTriggerRef
84− stop <- case (mvtyEvent, mETrigger) of
85− (Just vtyInput, Just eTrigger) -> do
86− x <- fire [eTrigger :=> Identity vtyInput] $ do
87− readEvent shutdown >>= \case
88− Nothing -> return False
89− Just _ -> return True
90− updateVty -- TODO should this happen outside the readphase? why?
91− return x
92− _ -> return []
93− case or stop of
94− True -> liftIO $ V.shutdown vty
95− False -> loop
96− -- TODO should this loop have a cooldown?
79+ ers <- liftIO $ readChan events
80+ stop <- do
81+ fireEventTriggerRefs fc ers $ do
82+ readEvent shutdown >>= \case
83+ Nothing -> return False
84+ Just _ -> return True
85+ if or stop
86+ then liftIO $ do
87+ killThread nextEventThread
88+ V.shutdown vty
89+ else do
90+ updateVty
91+ loop
9792
9893guest :: forall t m. VtyApp t m
9994guest e = do
@@ -102,34 +97,29 @@ guest e = do
10297 let shutdown = fforMaybe e $ \case
10398 V.EvKey V.KEsc _ -> Just ()
10499 _ -> Nothing
105− picture <- hold (V.picForImage $ V.string mempty "Initial") $ V.picForImage . V.string mempty <$> leftmost [show <$> e, show <$> ticks]
100+ picture <- hold (V.picForImage $ V.string mempty "Initial") $ V.picForImage . V.string mempty <$>
101+ leftmost [show <$> e, show <$> ticks]
106102 return $ VtyResult
107103 { _vtyResult_picture = picture
108104 , _vtyResult_refresh = never
109105 , _vtyResult_shutdown = shutdown
110106 }
111107
112−processAsyncEvents
113− :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
114− -> FireCommand t (SpiderHost Global)
115− -> SpiderHost Global ()
116− -> IO ()
117−processAsyncEvents events (FireCommand fire) updateHost = void $ forkIO $ forever $ do
118− ers <- readChan events
119− _ <- runSpiderHost $ do
120− mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
121− me <- readIORef er
122− return $ fmap (\e -> e :=> Identity a) me
123− let es = catMaybes mes
124− _ <- fire es $ return ()
125− case es of
126− [] -> return ()
127− _ -> updateHost
128− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
129− return ()
108+-- TODO Some part of this is probably general enough to belong in reflex
109+fireEventTriggerRefs
110+ :: (Monad (ReadPhase m), MonadIO m)
111+ => FireCommand t m
112+ -> [DSum (EventTriggerRef t) TriggerInvocation]
113+ -> ReadPhase m a
114+ -> m [a]
115+fireEventTriggerRefs (FireCommand fire) ers rcb = do
116+ mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
117+ me <- readIORef er
118+ return $ fmap (\e -> e :=> Identity a) me
119+ let es = catMaybes mes
120+ a <- fire es rcb
121+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
122+ return a
130123
131124main :: IO ()
132−main = do
133− hSetEcho stdin False
134− hSetBuffering stdin NoBuffering
135− host guest
125+main = host guest