@@ -9,10 +9,7 @@ module Reflex.Vty where
99
1010import Reflex
1111import Reflex.Host.Class
12−import Reflex.PerformEvent.Base
13−import Reflex.PerformEvent.Class
1412import Control.Concurrent (forkIO)
15−import Control.Monad (forever)
1613import Control.Monad.Fix
1714import Control.Monad.Identity (Identity(..))
1815import Control.Monad.IO.Class
@@ -22,9 +19,12 @@ import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
2219
2320import Data.Time
2421import qualified Graphics.Vty as V
25−import Control.Monad.Ref (Ref)
22+import Control.Monad.Ref
2623import Data.IORef (IORef)
2724import Control.Monad.Primitive (PrimMonad)
25+import Control.Concurrent.Chan
26+import Control.Monad
27+import Data.Maybe
2828
2929data VtyResult t = VtyResult
3030 { _vtyResult_picture :: Behavior t V.Picture
@@ -39,8 +39,11 @@ type VtyApp t m = ( Reflex t
3939 , ReflexHost t
4040 , MonadIO (HostFrame t)
4141 , Ref m ~ IORef
42+ , Ref (HostFrame t) ~ IORef
43+ , MonadRef (HostFrame t)
4244 )
43− => Event t (V.Event) -> {-PostBuildT t m-} PerformEventT t m (VtyResult t)
45+ => Event t (V.Event)
46+ -> TriggerEventT t (PostBuildT t (PerformEventT t m)) (VtyResult t)
4447
4548host
4649 :: (forall t m. VtyApp t m)
@@ -50,13 +53,21 @@ host vtyGuest = runSpiderHost $ do
5053 vty <- liftIO $ V.mkVty cfg
5154
5255 (e, eTriggerRef) <- newEventWithTriggerRef
53− -- (pb, pbTriggerRef) <- newEventWithTriggerRef
54− (r, fireCommand) <- hostPerformEventT $ {- flip runPostBuildT pb $ -} do
56+ (pb, pbTriggerRef) <- newEventWithTriggerRef
57+
58+ someEvents <- liftIO newChan
59+
60+ (r, fc@(FireCommand fire)) <- hostPerformEventT $ flip runPostBuildT pb $ flip runTriggerEventT someEvents $ do
5561 r <- vtyGuest e
5662 return r
5763
58− -- fireEventRef pbTriggerRef ()
64+ liftIO $ processAsyncEvents someEvents fc
5965
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+
6071 shutdown <- subscribeEvent $ _vtyResult_shutdown r
6172
6273 fix $ \loop -> do
@@ -65,7 +76,7 @@ host vtyGuest = runSpiderHost $ do
6576 stop <- case mETrigger of
6677 Nothing -> return []
6778 Just eTrigger ->
68− runFireCommand fireCommand [eTrigger :=> Identity vtyEvent] $ do
79+ fire [eTrigger :=> Identity vtyEvent] $ do
6980 readEvent shutdown >>= \case
7081 Nothing -> return False
7182 Just _ -> return True
@@ -75,21 +86,35 @@ host vtyGuest = runSpiderHost $ do
7586 True -> liftIO $ V.shutdown vty
7687 False -> loop
7788
78−guest :: VtyApp t m
89+guest :: forall t m. VtyApp t m
7990guest e = do
80− now <- performEvent $ fmap (\_ -> liftIO getCurrentTime) e
81− -- now <- liftIO getCurrentTime
82− -- ticks <- fmap show <$> tickLossy 1 now
91+ pb <- getPostBuild
92+ now <- liftIO getCurrentTime
93+ ticks <- fmap show <$> tickLossy 1 now
8394 let shutdown = fforMaybe e $ \case
8495 V.EvKey V.KEsc _ -> Just ()
8596 _ -> 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]
8798 return $ VtyResult
8899 { _vtyResult_picture = picture
89100 , _vtyResult_refresh = never
90101 , _vtyResult_shutdown = shutdown
91102 }
92103
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+
93118main :: IO ()
94119main = do
95120 hSetEcho stdin False