@@ -1,21 +1,30 @@
1+{-# LANGUAGE FlexibleContexts #-}
12{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
47
58module Reflex.Vty where
69
710import Reflex
811import Reflex.Host.Class
12+import Reflex.PerformEvent.Base
13+import Reflex.PerformEvent.Class
914import Control.Concurrent (forkIO)
1015import Control.Monad (forever)
1116import Control.Monad.Fix
1217import Control.Monad.Identity (Identity(..))
13−import Control.Monad.IO.Class (liftIO)
18+import Control.Monad.IO.Class
1419import Data.IORef (readIORef)
1520import Data.Dependent.Sum (DSum ((:=>)))
1621import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
1722
23+import Data.Time
1824import qualified Graphics.Vty as V
25+import Control.Monad.Ref (Ref)
26+import Data.IORef (IORef)
27+import Control.Monad.Primitive (PrimMonad)
1928
2029data VtyResult t = VtyResult
2130 { _vtyResult_picture :: Behavior t V.Picture
@@ -23,7 +32,15 @@ data VtyResult t = VtyResult
2332 , _vtyResult_shutdown :: Event t ()
2433 }
2534
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
36+ , MonadHold t m
37+ , MonadFix m
38+ , PrimMonad (HostFrame t)
39+ , ReflexHost t
40+ , MonadIO (HostFrame t)
41+ , Ref m ~ IORef
42+ )
43+ => Event t (V.Event) -> {-PostBuildT t m-} PerformEventT t m (VtyResult t)
2744
2845host
2946 :: (forall t m. VtyApp t m)
@@ -33,29 +50,40 @@ host vtyGuest = runSpiderHost $ do
3350 vty <- liftIO $ V.mkVty cfg
3451
3552 (e, eTriggerRef) <- newEventWithTriggerRef
36− r <- runHostFrame $ vtyGuest e
53+ -- (pb, pbTriggerRef) <- newEventWithTriggerRef
54+ (r, fireCommand) <- hostPerformEventT $ {- flip runPostBuildT pb $ -} do
55+ r <- vtyGuest e
56+ return r
57+
58+ -- fireEventRef pbTriggerRef ()
59+
3760 shutdown <- subscribeEvent $ _vtyResult_shutdown r
3861
3962 fix $ \loop -> do
4063 vtyEvent <- liftIO $ V.nextEvent vty
4164 mETrigger <- liftIO $ readIORef eTriggerRef
42− next <- case mETrigger of
43− Nothing -> return loop
65+ stop <- case mETrigger of
66+ Nothing -> return []
4467 Just eTrigger ->
45− fireEventsAndRead [eTrigger :=> Identity vtyEvent] $ do
68+ runFireCommand fireCommand [eTrigger :=> Identity vtyEvent] $ do
4669 readEvent shutdown >>= \case
47− Nothing -> return loop
48− Just _ -> return $ liftIO $ V.shutdown vty
70+ Nothing -> return False
71+ Just _ -> return True
4972 output <- runHostFrame $ sample $ _vtyResult_picture r
5073 liftIO $ V.update vty output
51− next
74+ case or stop of
75+ True -> liftIO $ V.shutdown vty
76+ False -> loop
5277
5378guest :: VtyApp t m
5479guest e = do
80+ now <- performEvent $ fmap (\_ -> liftIO getCurrentTime) e
81+ -- now <- liftIO getCurrentTime
82+ -- ticks <- fmap show <$> tickLossy 1 now
5583 let shutdown = fforMaybe e $ \case
5684 V.EvKey V.KEsc _ -> Just ()
5785 _ -> 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]
5987 return $ VtyResult
6088 { _vtyResult_picture = picture
6189 , _vtyResult_refresh = never