@@ -7,26 +7,23 @@
8module Reflex.Vty where
8module Reflex.Vty where
11−import Reflex.Host.Class
12−import Control.Concurrent (forkIO)
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
13+import Control.Monad.Fix (MonadFix, fix)
14+import Control.Monad.IO.Class (liftIO, MonadIO)
14import Control.Monad.Identity (Identity(..))
15import Control.Monad.Identity (Identity(..))
15−import Control.Monad.IO.Class
16+import Control.Monad.Primitive (PrimMonad)
16−import Data.IORef (readIORef)
17+import Control.Monad.Ref (MonadRef, Ref, readRef)
17import Data.Dependent.Sum (DSum ((:=>)))
18import 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)
20−import Control.Concurrent.STM.TChan
24+import Reflex
21−import Control.Monad.STM (atomically)
25+import Reflex.Host.Class
23import qualified Graphics.Vty as V
26import 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
31data VtyResult t = VtyResult
28data VtyResult t = VtyResult
32 { _vtyResult_picture :: Behavior t V.Picture
29 { _vtyResult_picture :: Behavior t V.Picture
@@ -57,16 +54,15 @@ host vtyGuest = runSpiderHost $ do
57 (e, eTriggerRef) <- newEventWithTriggerRef
54 (e, eTriggerRef) <- newEventWithTriggerRef
58 (pb, pbTriggerRef) <- newEventWithTriggerRef
55 (pb, pbTriggerRef) <- newEventWithTriggerRef
60− someEvents <- liftIO newChan
57+ events <- liftIO newChan
62 (r, fc@(FireCommand fire)) <- hostPerformEventT $
59 (r, fc@(FireCommand fire)) <- hostPerformEventT $
63 flip runPostBuildT pb $
60 flip runPostBuildT pb $
64− flip runTriggerEventT someEvents $
61+ flip runTriggerEventT events $
65 vtyGuest e
62 vtyGuest e
67 let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
64 let updateVty = sample (_vtyResult_picture r) >>= liftIO . V.update vty
69− liftIO $ processAsyncEvents someEvents fc updateVty -- TODO is this the right way to handle screen updates for async events?
71 mPostBuildTrigger <- readRef pbTriggerRef
67 mPostBuildTrigger <- readRef pbTriggerRef
72 forM_ mPostBuildTrigger $ \postBuildTrigger ->
68 forM_ mPostBuildTrigger $ \postBuildTrigger ->
@@ -75,25 +71,24 @@ host vtyGuest = runSpiderHost $ do
76 shutdown <- subscribeEvent $ _vtyResult_shutdown r
72 shutdown <- subscribeEvent $ _vtyResult_shutdown r
78− vtyEvent <- liftIO newTChanIO
74+ nextEventThread <- liftIO $ forkIO $ forever $ do
79− void $ liftIO $ forkIO $ forever $ atomically . writeTChan vtyEvent =<< V.nextEvent vty
75+ ne <- V.nextEvent vty
76+ writeChan events $ [EventTriggerRef eTriggerRef :=> TriggerInvocation ne (return ())]
81 fix $ \loop -> do
78 fix $ \loop -> do
82− mvtyEvent <- liftIO $ atomically $ tryReadTChan vtyEvent
79+ ers <- liftIO $ readChan events
83− mETrigger <- liftIO $ readIORef eTriggerRef
80+ stop <- do
84− stop <- case (mvtyEvent, mETrigger) of
81+ fireEventTriggerRefs fc ers $ do
85− (Just vtyInput, Just eTrigger) -> do
86− x <- fire [eTrigger :=> Identity vtyInput] $ do
87− readEvent shutdown >>= \case
82+ readEvent shutdown >>= \case
88− Nothing -> return False
83+ Nothing -> return False
89− Just _ -> return True
84+ Just _ -> return True
90− updateVty -- TODO should this happen outside the readphase? why?
93− case or stop of
85+ if or stop
87+ killThread nextEventThread
94− True -> liftIO $ V.shutdown vty
88+ V.shutdown vty
95− False -> loop
89+ else do
96− -- TODO should this loop have a cooldown?
90+ updateVty
98guest :: forall t m. VtyApp t m
93guest :: forall t m. VtyApp t m
99guest e = do
94guest e = do
@@ -102,34 +97,29 @@ guest e = do
102 let shutdown = fforMaybe e $ \case
97 let shutdown = fforMaybe e $ \case
103 V.EvKey V.KEsc _ -> Just ()
98 V.EvKey V.KEsc _ -> Just ()
104 _ -> Nothing
99 _ -> 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]
106 return $ VtyResult
102 return $ VtyResult
107 { _vtyResult_picture = picture
103 { _vtyResult_picture = picture
108 , _vtyResult_refresh = never
104 , _vtyResult_refresh = never
109 , _vtyResult_shutdown = shutdown
105 , _vtyResult_shutdown = shutdown
112−processAsyncEvents
108+-- TODO Some part of this is probably general enough to belong in reflex
110+ :: (Monad (ReadPhase m), MonadIO m)
113− :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
112+ -> [DSum (EventTriggerRef t) TriggerInvocation]
114− -> FireCommand t (SpiderHost Global)
113+ -> ReadPhase m a
115− -> SpiderHost Global ()
114+ -> m [a]
116− -> IO ()
115+fireEventTriggerRefs (FireCommand fire) ers rcb = do
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
116+ mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
121− me <- readIORef er
117+ me <- readIORef er
122− return $ fmap (\e -> e :=> Identity a) me
118+ return $ fmap (\e -> e :=> Identity a) me
123− let es = catMaybes mes
119+ let es = catMaybes mes
124− _ <- fire es $ return ()
120+ a <- fire es rcb
128− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
121+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
129− return ()
122+ return a
131main :: IO ()
124main :: IO ()
133− hSetEcho stdin False
134− hSetBuffering stdin NoBuffering
135− host guest
125+main = host guest