@@ -0,0 +1,69 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE RankNTypes #-}
5+module Reflex.Vty where
8+import Reflex.Host.Class
9+import Control.Concurrent (forkIO)
10+import Control.Monad (forever)
11+import Control.Monad.Fix
12+import Control.Monad.Identity (Identity(..))
13+import Control.Monad.IO.Class (liftIO)
14+import Data.IORef (readIORef)
15+import Data.Dependent.Sum (DSum ((:=>)))
16+import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))
18+import qualified Graphics.Vty as V
20+data VtyResult t = VtyResult
21+ { _vtyResult_picture :: Behavior t V.Picture
22+ , _vtyResult_refresh :: Event t ()
23+ , _vtyResult_shutdown :: Event t ()
26+type VtyApp t m = (Reflex t, MonadHold t m, MonadFix m) => Event t (V.Event) -> m (VtyResult t)
29+ :: (forall t m. VtyApp t m)
31+host vtyGuest = runSpiderHost $ do
32+ cfg <- liftIO V.standardIOConfig
33+ vty <- liftIO $ V.mkVty cfg
35+ (e, eTriggerRef) <- newEventWithTriggerRef
36+ r <- runHostFrame $ vtyGuest e
37+ shutdown <- subscribeEvent $ _vtyResult_shutdown r
40+ vtyEvent <- liftIO $ V.nextEvent vty
41+ mETrigger <- liftIO $ readIORef eTriggerRef
42+ next <- case mETrigger of
43+ Nothing -> return loop
45+ fireEventsAndRead [eTrigger :=> Identity vtyEvent] $ do
46+ readEvent shutdown >>= \case
47+ Nothing -> return loop
48+ Just _ -> return $ liftIO $ V.shutdown vty
49+ output <- runHostFrame $ sample $ _vtyResult_picture r
50+ liftIO $ V.update vty output
55+ let shutdown = fforMaybe e $ \case
56+ V.EvKey V.KEsc _ -> Just ()
58+ picture <- hold V.emptyPicture $ V.picForImage . V.string mempty . show <$> e
60+ { _vtyResult_picture = picture
61+ , _vtyResult_refresh = never
62+ , _vtyResult_shutdown = shutdown
68+ hSetBuffering stdin NoBuffering