@@ -1,21 +1,30 @@
1+{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
5module Reflex.Vty where
8module Reflex.Vty where
7import Reflex
10import Reflex
8import Reflex.Host.Class
11import Reflex.Host.Class
12+import Reflex.PerformEvent.Base
13+import Reflex.PerformEvent.Class
9import Control.Concurrent (forkIO)
14import Control.Concurrent (forkIO)
10import Control.Monad (forever)
15import Control.Monad (forever)
11import Control.Monad.Fix
16import Control.Monad.Fix
12import Control.Monad.Identity (Identity(..))
17import Control.Monad.Identity (Identity(..))
13−import Control.Monad.IO.Class (liftIO)
18+import Control.Monad.IO.Class
14import Data.IORef (readIORef)
19import Data.IORef (readIORef)
15import Data.Dependent.Sum (DSum ((:=>)))
20import Data.Dependent.Sum (DSum ((:=>)))
16import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
21import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
18import qualified Graphics.Vty as V
24import qualified Graphics.Vty as V
25+import Control.Monad.Ref (Ref)
26+import Data.IORef (IORef)
27+import Control.Monad.Primitive (PrimMonad)
20data VtyResult t = VtyResult
29data VtyResult t = VtyResult
21 { _vtyResult_picture :: Behavior t V.Picture
30 { _vtyResult_picture :: Behavior t V.Picture
@@ -23,7 +32,15 @@ data VtyResult t = VtyResult
23 , _vtyResult_shutdown :: Event t ()
32 , _vtyResult_shutdown :: Event t ()
26−type VtyApp t m = (Reflex t, MonadHold t m, MonadFix m) => Event t (V.Event) -> m (VtyResult t)
35+type VtyApp t m = ( Reflex t
38+ , PrimMonad (HostFrame t)
40+ , MonadIO (HostFrame t)
43+ => Event t (V.Event) -> {-PostBuildT t m-} PerformEventT t m (VtyResult t)
29 :: (forall t m. VtyApp t m)
46 :: (forall t m. VtyApp t m)
@@ -33,29 +50,40 @@ host vtyGuest = runSpiderHost $ do
33 vty <- liftIO $ V.mkVty cfg
50 vty <- liftIO $ V.mkVty cfg
35 (e, eTriggerRef) <- newEventWithTriggerRef
52 (e, eTriggerRef) <- newEventWithTriggerRef
53+ -- (pb, pbTriggerRef) <- newEventWithTriggerRef
54+ (r, fireCommand) <- hostPerformEventT $ {- flip runPostBuildT pb $ -} do
36− r <- runHostFrame $ vtyGuest e
55+ r <- vtyGuest e
58+ -- fireEventRef pbTriggerRef ()
37 shutdown <- subscribeEvent $ _vtyResult_shutdown r
60 shutdown <- subscribeEvent $ _vtyResult_shutdown r
39 fix $ \loop -> do
62 fix $ \loop -> do
40 vtyEvent <- liftIO $ V.nextEvent vty
63 vtyEvent <- liftIO $ V.nextEvent vty
41 mETrigger <- liftIO $ readIORef eTriggerRef
64 mETrigger <- liftIO $ readIORef eTriggerRef
42− next <- case mETrigger of
65+ stop <- case mETrigger of
43− Nothing -> return loop
66+ Nothing -> return []
44 Just eTrigger ->
67 Just eTrigger ->
45− fireEventsAndRead [eTrigger :=> Identity vtyEvent] $ do
68+ runFireCommand fireCommand [eTrigger :=> Identity vtyEvent] $ do
46 readEvent shutdown >>= \case
69 readEvent shutdown >>= \case
47− Nothing -> return loop
70+ Nothing -> return False
48− Just _ -> return $ liftIO $ V.shutdown vty
71+ Just _ -> return True
49 output <- runHostFrame $ sample $ _vtyResult_picture r
72 output <- runHostFrame $ sample $ _vtyResult_picture r
50 liftIO $ V.update vty output
73 liftIO $ V.update vty output
51− next
74+ case or stop of
75+ True -> liftIO $ V.shutdown vty
53guest :: VtyApp t m
78guest :: VtyApp t m
54guest e = do
79guest e = do
80+ now <- performEvent $ fmap (\_ -> liftIO getCurrentTime) e
81+ -- now <- liftIO getCurrentTime
82+ -- ticks <- fmap show <$> tickLossy 1 now
55 let shutdown = fforMaybe e $ \case
83 let shutdown = fforMaybe e $ \case
56 V.EvKey V.KEsc _ -> Just ()
84 V.EvKey V.KEsc _ -> Just ()
57 _ -> Nothing
85 _ -> Nothing
58− picture <- hold V.emptyPicture $ V.picForImage . V.string mempty . show <$> e
86+ picture <- hold V.emptyPicture $ V.picForImage . V.string mempty <$> leftmost [show <$> e, show <$> now]
59 return $ VtyResult
87 return $ VtyResult
60 { _vtyResult_picture = picture
88 { _vtyResult_picture = picture
61 , _vtyResult_refresh = never
89 , _vtyResult_refresh = never