vty/demos/Demo.hs

{-# LANGUAGE FlexibleContexts #-}
module Main where

import Graphics.Vty

import Control.Applicative hiding ((<|>))
import Control.Arrow
import Control.Monad.RWS

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 defaultConfig
            else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )
    _ <- 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 palette."
    , "Followed by tones of red using a 24-bit palette."
    , "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 ¯\\_(ツ)_/¯"
    , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"
    ]

splitColorImages :: [Image] -> [[Image]]
splitColorImages [] = []
splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

fullcolorbox :: Image
fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages
    where
        colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]

colorbox_240 :: Image
colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages
    where
        colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

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 <|> fullcolorbox)
    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 []