@@ -17,6 +17,8 @@ import Data.IORef (readIORef)
1717import Data.Dependent.Sum (DSum ((:=>)))
1818import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
1919
20+import Control.Concurrent.STM.TChan
21+import Control.Monad.STM (atomically)
2022import Data.Time
2123import qualified Graphics.Vty as V
2224import Control.Monad.Ref
@@ -57,38 +59,44 @@ host vtyGuest = runSpiderHost $ do
5759
5860 someEvents <- liftIO newChan
5961
60− (r, fc@(FireCommand fire)) <- hostPerformEventT $ flip runPostBuildT pb $ flip runTriggerEventT someEvents $ do
61− r <- vtyGuest e
62− return r
62+ (r, fc@(FireCommand fire)) <- hostPerformEventT $
63+ flip runPostBuildT pb $
64+ flip runTriggerEventT someEvents $
65+ vtyGuest e
6366
64− liftIO $ processAsyncEvents someEvents fc
67+ let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
68+
69+ liftIO $ processAsyncEvents someEvents fc updateVty -- TODO is this the right way to handle screen updates for async events?
6570
6671 mPostBuildTrigger <- readRef pbTriggerRef
67− forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
68− vtyPostBuild <- sample $ _vtyResult_picture r
69− liftIO $ V.update vty vtyPostBuild
70−
72+ forM_ mPostBuildTrigger $ \postBuildTrigger ->
73+ fire [postBuildTrigger :=> Identity ()] $ return ()
74+ updateVty
75+
7176 shutdown <- subscribeEvent $ _vtyResult_shutdown r
77+
78+ vtyEvent <- liftIO newTChanIO
79+ void $ liftIO $ forkIO $ forever $ atomically . writeTChan vtyEvent =<< V.nextEvent vty
7280
7381 fix $ \loop -> do
74− vtyEvent <- liftIO $ V.nextEvent vty
82+ mvtyEvent <- liftIO $ atomically $ tryReadTChan vtyEvent
7583 mETrigger <- liftIO $ readIORef eTriggerRef
76− stop <- case mETrigger of
77− Nothing -> return []
78− Just eTrigger ->
79− fire [eTrigger :=> Identity vtyEvent] $ do
84+ stop <- case (mvtyEvent, mETrigger) of
85+ (Just vtyInput, Just eTrigger) -> do
86+ x <- fire [eTrigger :=> Identity vtyInput] $ do
8087 readEvent shutdown >>= \case
8188 Nothing -> return False
8289 Just _ -> return True
83− output <- runHostFrame $ sample $ _vtyResult_picture r
84− liftIO $ V.update vty output
90+ updateVty -- TODO should this happen outside the readphase? why?
91+ return x
92+ _ -> return []
8593 case or stop of
8694 True -> liftIO $ V.shutdown vty
8795 False -> loop
96+ -- TODO should this loop have a cooldown?
8897
8998guest :: forall t m. VtyApp t m
9099guest e = do
91− pb <- getPostBuild
92100 now <- liftIO getCurrentTime
93101 ticks <- fmap show <$> tickLossy 1 now
94102 let shutdown = fforMaybe e $ \case
@@ -104,14 +112,19 @@ guest e = do
104112processAsyncEvents
105113 :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
106114 -> FireCommand t (SpiderHost Global)
115+ -> SpiderHost Global ()
107116 -> IO ()
108−processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
117+processAsyncEvents events (FireCommand fire) updateHost = void $ forkIO $ forever $ do
109118 ers <- readChan events
110119 _ <- runSpiderHost $ do
111120 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
112121 me <- readIORef er
113122 return $ fmap (\e -> e :=> Identity a) me
114− _ <- fire (catMaybes mes) $ return ()
123+ let es = catMaybes mes
124+ _ <- fire es $ return ()
125+ case es of
126+ [] -> return ()
127+ _ -> updateHost
115128 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
116129 return ()
117130