mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-11-29 16:54:42 +03:00
add an example program to test input event handling: vty-event-echo
This commit is contained in:
parent
58cf4160df
commit
33bf7c8920
42
test/EventEcho.hs
Normal file
42
test/EventEcho.hs
Normal file
@ -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
|
||||
|
19
vty.cabal
19
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
|
||||
|
Loading…
Reference in New Issue
Block a user