diff --git a/test/EventEcho.hs b/test/EventEcho.hs new file mode 100644 index 0000000..c1f943f --- /dev/null +++ b/test/EventEcho.hs @@ -0,0 +1,42 @@ +module Main where + +import Graphics.Vty + +import Control.Applicative +import Control.Arrow +import Control.Monad.RWS + +import Data.Sequence (Seq, (<|) ) +import qualified Data.Sequence as Seq +import Data.Foldable + +event_buffer_size = 1000 + +type App = RWST Vty () (Seq String) IO + +main = do + vty <- mkVty + _ <- execRWST vty_interact vty Seq.empty + shutdown vty + +vty_interact :: App () +vty_interact = do + update_display + done <- handle_next_event + unless done vty_interact + +update_display :: App () +update_display = do + let info = string def_attr "Press ESC to exit." + event_log <- foldMap (string def_attr) <$> get + let pic = pic_for_layers [info,event_log] + vty <- ask + liftIO $ update vty pic + +handle_next_event = ask >>= liftIO . next_event >>= handle_event + where + handle_event (EvKey KEsc []) = return True + handle_event e = do + modify $ (<|) (show e) >>> Seq.take event_buffer_size + return False + diff --git a/vty.cabal b/vty.cabal index 6dbd0e8..901f21f 100644 --- a/vty.cabal +++ b/vty.cabal @@ -561,6 +561,25 @@ executable vty-interactive-terminal-test utf8-string >= 0.3 && < 0.4, vector >= 0.7 +executable vty-event-echo + main-is: EventEcho.hs + hs-source-dirs: test + + default-language: Haskell2010 + default-extensions: ScopedTypeVariables + + build-depends: vty, + base >= 4 && < 5, + array >= 0.4 && < 2.0, + bytestring, + containers, + lens, + mtl >= 1.1.1.0 && < 2.2, + parallel >= 2.2 && < 3.3, + text >= 0.11.3, + utf8-string >= 0.3 && < 0.4, + vector >= 0.7 + executable vty-rouge main-is: Rouge.hs hs-source-dirs: test