frpnow-vty-0.2.0.0: demos/Demo.hs

module Main where

import Control.FRPNow.Vty
import Control.FRPNow
import Graphics.Vty

import Control.Applicative hiding ((<|>))

import Data.Sequence (Seq, (<|))
import qualified Data.Sequence as Seq
import Data.Foldable (foldMap)
import Data.Functor (void)

eventBufferSize = 1000

main = do
    let config = if True -- change to false for emacs-like input processing
            then defaultConfig
            else (defaultConfig { vmin = Just 2, vtime = Just 300 } )
    runNowVtyPure config mainFRP

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" ]

renderPicture :: Seq String -> Picture
renderPicture log =
    let info = string (defAttr `withForeColor` black `withBackColor` green)
                      "Press ESC to exit. Events for keys below."
        eventLog = foldMap (string defAttr) log
    in picForImage (info <-> eventLog)
           `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)

mainFRP :: EvStream VEvent -> Behavior (BehaviorEnd Picture ())
mainFRP evs = do
    seqs <- foldEs handleEvent Seq.empty evs
    escEv <- next (filterEs (== EvKey KEsc []) evs)
    pure (fmap renderPicture seqs `Until` void escEv)
    where
        handleEvent s e = Seq.take eventBufferSize (show e <| s)