@@ -0,0 +1,69 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE RankNTypes #-}
4+
5+module Reflex.Vty where
6+
7+import Reflex
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))
17+
18+import qualified Graphics.Vty as V
19+
20+data VtyResult t = VtyResult
21+ { _vtyResult_picture :: Behavior t V.Picture
22+ , _vtyResult_refresh :: Event t ()
23+ , _vtyResult_shutdown :: Event t ()
24+ }
25+
26+type VtyApp t m = (Reflex t, MonadHold t m, MonadFix m) => Event t (V.Event) -> m (VtyResult t)
27+
28+host
29+ :: (forall t m. VtyApp t m)
30+ -> IO ()
31+host vtyGuest = runSpiderHost $ do
32+ cfg <- liftIO V.standardIOConfig
33+ vty <- liftIO $ V.mkVty cfg
34+
35+ (e, eTriggerRef) <- newEventWithTriggerRef
36+ r <- runHostFrame $ vtyGuest e
37+ shutdown <- subscribeEvent $ _vtyResult_shutdown r
38+
39+ fix $ \loop -> do
40+ vtyEvent <- liftIO $ V.nextEvent vty
41+ mETrigger <- liftIO $ readIORef eTriggerRef
42+ next <- case mETrigger of
43+ Nothing -> return loop
44+ Just eTrigger ->
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
51+ next
52+
53+guest :: VtyApp t m
54+guest e = do
55+ let shutdown = fforMaybe e $ \case
56+ V.EvKey V.KEsc _ -> Just ()
57+ _ -> Nothing
58+ picture <- hold V.emptyPicture $ V.picForImage . V.string mempty . show <$> e
59+ return $ VtyResult
60+ { _vtyResult_picture = picture
61+ , _vtyResult_refresh = never
62+ , _vtyResult_shutdown = shutdown
63+ }
64+
65+main :: IO ()
66+main = do
67+ hSetEcho stdin False
68+ hSetBuffering stdin NoBuffering
69+ host guest