git.iko.soy/reflex-vty
on develop help sign in
Add TriggerEventT
18dc266Ali Abrar
src/Reflex/Vty.hs+39−14
compare with develop
unifiedsplit
@@ -9,10 +9,7 @@ module Reflex.Vty where
9
9
10import Reflex
10import Reflex
11import Reflex.Host.Class
11import Reflex.Host.Class
12−import Reflex.PerformEvent.Base
13−import Reflex.PerformEvent.Class
14import Control.Concurrent (forkIO)
12import Control.Concurrent (forkIO)
15−import Control.Monad (forever)
16import Control.Monad.Fix
13import Control.Monad.Fix
17import Control.Monad.Identity (Identity(..))
14import Control.Monad.Identity (Identity(..))
18import Control.Monad.IO.Class
15import Control.Monad.IO.Class
@@ -22,9 +19,12 @@ import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
22
19
23import Data.Time
20import Data.Time
24import qualified Graphics.Vty as V
21import qualified Graphics.Vty as V
25−import Control.Monad.Ref (Ref)
22+import Control.Monad.Ref
26import Data.IORef (IORef)
23import Data.IORef (IORef)
27import Control.Monad.Primitive (PrimMonad)
24import Control.Monad.Primitive (PrimMonad)
25+import Control.Concurrent.Chan
26+import Control.Monad
27+import Data.Maybe
28
28
29data VtyResult t = VtyResult
29data VtyResult t = VtyResult
30 { _vtyResult_picture :: Behavior t V.Picture
30 { _vtyResult_picture :: Behavior t V.Picture
@@ -39,8 +39,11 @@ type VtyApp t m = ( Reflex t
39 , ReflexHost t
39 , ReflexHost t
40 , MonadIO (HostFrame t)
40 , MonadIO (HostFrame t)
41 , Ref m ~ IORef
41 , Ref m ~ IORef
42+ , Ref (HostFrame t) ~ IORef
43+ , MonadRef (HostFrame t)
42 )
44 )
45+ => Event t (V.Event)
43− => Event t (V.Event) -> {-PostBuildT t m-} PerformEventT t m (VtyResult t)
46+ -> TriggerEventT t (PostBuildT t (PerformEventT t m)) (VtyResult t)
44
47
45host
48host
46 :: (forall t m. VtyApp t m)
49 :: (forall t m. VtyApp t m)
@@ -50,13 +53,21 @@ host vtyGuest = runSpiderHost $ do
50 vty <- liftIO $ V.mkVty cfg
53 vty <- liftIO $ V.mkVty cfg
51
54
52 (e, eTriggerRef) <- newEventWithTriggerRef
55 (e, eTriggerRef) <- newEventWithTriggerRef
53− -- (pb, pbTriggerRef) <- newEventWithTriggerRef
56+ (pb, pbTriggerRef) <- newEventWithTriggerRef
57+
58+ someEvents <- liftIO newChan
59+
54− (r, fireCommand) <- hostPerformEventT $ {- flip runPostBuildT pb $ -} do
60+ (r, fc@(FireCommand fire)) <- hostPerformEventT $ flip runPostBuildT pb $ flip runTriggerEventT someEvents $ do
55 r <- vtyGuest e
61 r <- vtyGuest e
56 return r
62 return r
57
63
58− -- fireEventRef pbTriggerRef ()
64+ liftIO $ processAsyncEvents someEvents fc
59
65
66+ mPostBuildTrigger <- readRef pbTriggerRef
67+ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
68+ vtyPostBuild <- sample $ _vtyResult_picture r
69+ liftIO $ V.update vty vtyPostBuild
70+
60 shutdown <- subscribeEvent $ _vtyResult_shutdown r
71 shutdown <- subscribeEvent $ _vtyResult_shutdown r
61
72
62 fix $ \loop -> do
73 fix $ \loop -> do
@@ -65,7 +76,7 @@ host vtyGuest = runSpiderHost $ do
65 stop <- case mETrigger of
76 stop <- case mETrigger of
66 Nothing -> return []
77 Nothing -> return []
67 Just eTrigger ->
78 Just eTrigger ->
68− runFireCommand fireCommand [eTrigger :=> Identity vtyEvent] $ do
79+ fire [eTrigger :=> Identity vtyEvent] $ do
69 readEvent shutdown >>= \case
80 readEvent shutdown >>= \case
70 Nothing -> return False
81 Nothing -> return False
71 Just _ -> return True
82 Just _ -> return True
@@ -75,21 +86,35 @@ host vtyGuest = runSpiderHost $ do
75 True -> liftIO $ V.shutdown vty
86 True -> liftIO $ V.shutdown vty
76 False -> loop
87 False -> loop
77
88
78−guest :: VtyApp t m
89+guest :: forall t m. VtyApp t m
79guest e = do
90guest e = do
80− now <- performEvent $ fmap (\_ -> liftIO getCurrentTime) e
91+ pb <- getPostBuild
81− -- now <- liftIO getCurrentTime
92+ now <- liftIO getCurrentTime
82− -- ticks <- fmap show <$> tickLossy 1 now
93+ ticks <- fmap show <$> tickLossy 1 now
83 let shutdown = fforMaybe e $ \case
94 let shutdown = fforMaybe e $ \case
84 V.EvKey V.KEsc _ -> Just ()
95 V.EvKey V.KEsc _ -> Just ()
85 _ -> Nothing
96 _ -> Nothing
86− picture <- hold V.emptyPicture $ V.picForImage . V.string mempty <$> leftmost [show <$> e, show <$> now]
97+ picture <- hold (V.picForImage $ V.string mempty "Initial") $ V.picForImage . V.string mempty <$> leftmost [show <$> e, show <$> ticks]
87 return $ VtyResult
98 return $ VtyResult
88 { _vtyResult_picture = picture
99 { _vtyResult_picture = picture
89 , _vtyResult_refresh = never
100 , _vtyResult_refresh = never
90 , _vtyResult_shutdown = shutdown
101 , _vtyResult_shutdown = shutdown
91 }
102 }
92
103
104+processAsyncEvents
105+ :: Chan [DSum (EventTriggerRef t) TriggerInvocation]
106+ -> FireCommand t (SpiderHost Global)
107+ -> IO ()
108+processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
109+ ers <- readChan events
110+ _ <- runSpiderHost $ do
111+ mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
112+ me <- readIORef er
113+ return $ fmap (\e -> e :=> Identity a) me
114+ _ <- fire (catMaybes mes) $ return ()
115+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
116+ return ()
117+
93main :: IO ()
118main :: IO ()
94main = do
119main = do
95 hSetEcho stdin False
120 hSetEcho stdin False