mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 11:17:08 +03:00
83 lines
3.1 KiB
Haskell
83 lines
3.1 KiB
Haskell
module Main where
|
|
|
|
import Graphics.Vty
|
|
|
|
import Control.Applicative hiding ((<|>))
|
|
import Control.Arrow
|
|
import Control.Monad.RWS
|
|
|
|
import Data.Default (def)
|
|
import Data.Sequence (Seq, (<|) )
|
|
import qualified Data.Sequence as Seq
|
|
import Data.Foldable
|
|
|
|
eventBufferSize = 1000
|
|
|
|
type App = RWST Vty () (Seq String) IO
|
|
|
|
main = do
|
|
vty <- if True -- change to false for emacs-like input processing
|
|
then mkVty def
|
|
else mkVty (def { vmin = Just 2, vtime = Just 100 } )
|
|
_ <- execRWST (vtyInteract False) vty Seq.empty
|
|
shutdown vty
|
|
|
|
vtyInteract :: Bool -> App ()
|
|
vtyInteract shouldExit = do
|
|
updateDisplay
|
|
unless shouldExit $ handleNextEvent >>= vtyInteract
|
|
|
|
introText = vertCat $ map (string defAttr)
|
|
[ "this line is hidden by the top layer"
|
|
, "The vty demo program will echo the events generated by the pressed keys."
|
|
, "Below there is a 240 color box."
|
|
, "Followed by a description of the 16 color pallete."
|
|
, "If the 240 color box is not visible then the terminal"
|
|
, "claims 240 colors are not supported."
|
|
, "Try setting TERM to xterm-256color"
|
|
, "This text is on a lower layer than the event list."
|
|
, "Which means it'll be hidden soon."
|
|
, "Bye!"
|
|
, "Great Faith in the ¯\\_(ツ)_/¯"
|
|
, "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
|
|
]
|
|
|
|
colorbox_240 :: Image
|
|
colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
|
|
where
|
|
colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
|
|
splitColorImages [] = []
|
|
splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
|
|
|
|
colorbox_16 :: Image
|
|
colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border
|
|
where
|
|
column0 = vertCat $ map lineWithColor normal
|
|
column1 = vertCat $ map lineWithColor bright
|
|
border = vertCat $ replicate (length normal) $ string defAttr " | "
|
|
column2 = vertCat $ map (string defAttr . snd) normal
|
|
lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName
|
|
normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
|
|
[ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
|
|
bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue
|
|
, brightMagenta, brightCyan, brightWhite ]
|
|
[ "bright black", "bright red", "bright green", "bright yellow"
|
|
, "bright blue", "bright magenta", "bright cyan", "bright white" ]
|
|
|
|
updateDisplay :: App ()
|
|
updateDisplay = do
|
|
let info = string (defAttr `withForeColor` black `withBackColor` green)
|
|
"Press ESC to exit. Events for keys below."
|
|
eventLog <- foldMap (string defAttr) <$> get
|
|
let pic = picForImage (info <-> eventLog)
|
|
`addToBottom` (introText <-> colorbox_240 <|> colorbox_16)
|
|
vty <- ask
|
|
liftIO $ update vty pic
|
|
|
|
handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent
|
|
where
|
|
handleEvent e = do
|
|
modify $ (<|) (show e) >>> Seq.take eventBufferSize
|
|
return $ e == EvKey KEsc []
|
|
|