mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-11-30 02:13:36 +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,
|
utf8-string >= 0.3 && < 0.4,
|
||||||
vector >= 0.7
|
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
|
executable vty-rouge
|
||||||
main-is: Rouge.hs
|
main-is: Rouge.hs
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
|
Loading…
Reference in New Issue
Block a user