@@ -17,6 +17,8 @@ import Data.IORef (readIORef)
17import Data.Dependent.Sum (DSum ((:=>)))
17import Data.Dependent.Sum (DSum ((:=>)))
18import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
18import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
20+import Control.Concurrent.STM.TChan
21+import Control.Monad.STM (atomically)
20import Data.Time
22import Data.Time
21import qualified Graphics.Vty as V
23import qualified Graphics.Vty as V
22import Control.Monad.Ref
24import Control.Monad.Ref
@@ -57,38 +59,44 @@ host vtyGuest = runSpiderHost $ do
58 someEvents <- liftIO newChan
60 someEvents <- liftIO newChan
60− (r, fc@(FireCommand fire)) <- hostPerformEventT $ flip runPostBuildT pb $ flip runTriggerEventT someEvents $ do
62+ (r, fc@(FireCommand fire)) <- hostPerformEventT $
63+ flip runPostBuildT pb $
64+ flip runTriggerEventT someEvents $
61− r <- vtyGuest e
65+ vtyGuest e
67+ let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
64− liftIO $ processAsyncEvents someEvents fc
69+ liftIO $ processAsyncEvents someEvents fc updateVty -- TODO is this the right way to handle screen updates for async events?
66 mPostBuildTrigger <- readRef pbTriggerRef
71 mPostBuildTrigger <- readRef pbTriggerRef
67− forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
72+ forM_ mPostBuildTrigger $ \postBuildTrigger ->
68− vtyPostBuild <- sample $ _vtyResult_picture r
73+ fire [postBuildTrigger :=> Identity ()] $ return ()
69− liftIO $ V.update vty vtyPostBuild
74+ updateVty
71 shutdown <- subscribeEvent $ _vtyResult_shutdown r
76 shutdown <- subscribeEvent $ _vtyResult_shutdown r
78+ vtyEvent <- liftIO newTChanIO
79+ void $ liftIO $ forkIO $ forever $ atomically . writeTChan vtyEvent =<< V.nextEvent vty
73 fix $ \loop -> do
81 fix $ \loop -> do
74− vtyEvent <- liftIO $ V.nextEvent vty
82+ mvtyEvent <- liftIO $ atomically $ tryReadTChan vtyEvent
75 mETrigger <- liftIO $ readIORef eTriggerRef
83 mETrigger <- liftIO $ readIORef eTriggerRef
76− stop <- case mETrigger of
84+ stop <- case (mvtyEvent, mETrigger) of
78− Just eTrigger ->
85+ (Just vtyInput, Just eTrigger) -> do
79− fire [eTrigger :=> Identity vtyEvent] $ do
86+ x <- fire [eTrigger :=> Identity vtyInput] $ do
80 readEvent shutdown >>= \case
87 readEvent shutdown >>= \case
81 Nothing -> return False
88 Nothing -> return False
82 Just _ -> return True
89 Just _ -> return True
83− output <- runHostFrame $ sample $ _vtyResult_picture r
90+ updateVty -- TODO should this happen outside the readphase? why?
84− liftIO $ V.update vty output
91+ return x
85 case or stop of
93 case or stop of
86 True -> liftIO $ V.shutdown vty
94 True -> liftIO $ V.shutdown vty
87 False -> loop
95 False -> loop
96+ -- TODO should this loop have a cooldown?
89guest :: forall t m. VtyApp t m
98guest :: forall t m. VtyApp t m
90guest e = do
99guest e = do
92 now <- liftIO getCurrentTime
100 now <- liftIO getCurrentTime
93 ticks <- fmap show <$> tickLossy 1 now
101 ticks <- fmap show <$> tickLossy 1 now
94 let shutdown = fforMaybe e $ \case
102 let shutdown = fforMaybe e $ \case
@@ -104,14 +112,19 @@ guest e = do
104processAsyncEvents
112processAsyncEvents
105 :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
113 :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
106 -> FireCommand t (SpiderHost Global)
114 -> FireCommand t (SpiderHost Global)
115+ -> SpiderHost Global ()
108−processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
117+processAsyncEvents events (FireCommand fire) updateHost = void $ forkIO $ forever $ do
109 ers <- readChan events
118 ers <- readChan events
110 _ <- runSpiderHost $ do
119 _ <- runSpiderHost $ do
111 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
120 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
112 me <- readIORef er
121 me <- readIORef er
113 return $ fmap (\e -> e :=> Identity a) me
122 return $ fmap (\e -> e :=> Identity a) me
123+ let es = catMaybes mes
114− _ <- fire (catMaybes mes) $ return ()
124+ _ <- fire es $ return ()
115 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
128 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
116 return ()
129 return ()