module Main
(
main
) where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_, replicateM_)
import System.IO (hFlush, stdout)
import Text.Printf(printf)
import Data.Colour.SRGB (sRGB24)
import System.Console.ANSI
import System.Environment ( getArgs )
examples :: [(String, IO ())]
examples =
[ ( "Cursor movement", cursorMovementExample )
, ( "Line change", lineChangeExample )
, ( "Set cursor position", setCursorPositionExample )
, ( "Save restore cursor", saveRestoreCursorExample )
, ( "Clear", clearExample )
, ( "Line wrap", lineWrapExample )
, ( "Scroll", scrollExample )
, ( "Screen buffers", screenBuffersExample )
, ( "SGR color", sgrColorExample )
, ( "SGR other", sgrOtherExample )
, ( "Cursor visibility", cursorVisibilityExample )
, ( "Hyperlink", hyperlinkExample )
, ( "Title", titleExample )
, ( "Get cursor position", getCursorPositionExample )
, ( "Get terminal size", getTerminalSizeExample )
, ( "Get layer color", getLayerColorExample )
]
main :: IO ()
main = do
args <- getArgs
let numExamples = zip [1 ..] examples
if wantHelp args
then
listExamples numExamples
else do
let wantedNumExamples = filter (isExample args) numExamples
wantedExamples = map getExample wantedNumExamples
stdoutSupportsANSI <- hNowSupportsANSI stdout
if stdoutSupportsANSI
then
mapM_ (resetScreen >>) wantedExamples
else
putStrLn "Standard output does not support 'ANSI' escape codes."
where
wantHelp :: [String] -> Bool
wantHelp args = "-h" `elem` args || "--help" `elem` args
listExamples :: [(Int, (String, IO ()))] -> IO ()
listExamples = mapM_ (\(n, (d, _)) -> putStrLn $ show n ++ ": " ++ d)
isExample :: [String] -> (Int, (String, IO ())) -> Bool
isExample args (n, _) = show n `elem` args
getExample :: (Int, (String, IO ())) -> IO ()
getExample (_, (_, example)) = example
-- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation
-- of an erased state is implementation-dependent. There may or may not be a
-- distinction between a character position in the erased state and one imaging
-- SPACE. Consequently, to reset the screen, the default graphic rendition must
-- be selected (setSGR [Reset]) before all character positions are put into the
-- erased state (clearScreen).
resetScreen :: IO ()
resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0
pause :: IO ()
pause = do
hFlush stdout
-- 1 second pause
threadDelay 1000000
cursorMovementExample :: IO ()
cursorMovementExample = do
putStrLn "Line One"
putStr "Line Two"
pause
-- Line One
-- Line Two
cursorUp 1
putStr " - Extras"
pause
-- Line One - Extras
-- Line Two
cursorBackward 2
putStr "zz"
pause
-- Line One - Extrzz
-- Line Two
cursorForward 2
putStr "- And More"
pause
-- Line One - Extrzz - And More
-- Line Two
cursorDown 1
putStr "Disconnected"
pause
-- Line One - Extrzz - And More
-- Line Two Disconnected
lineChangeExample :: IO ()
lineChangeExample = do
putStrLn "Line One"
putStr "Line Two"
pause
-- Line One
-- Line Two
cursorUpLine 1
putStr "New Line One"
pause
-- New Line One
-- Line Two
cursorDownLine 1
putStr "New Line Two"
pause
-- New Line One
-- New Line Two
setCursorPositionExample :: IO ()
setCursorPositionExample = do
putStrLn "Line One"
putStrLn "Line Two"
pause
-- Line One
-- Line Two
setCursorPosition 0 5
putStr "Foo"
pause
-- Line Foo
-- Line Two
setCursorPosition 1 5
putStr "Bar"
pause
-- Line Foo
-- Line Bar
setCursorColumn 1
putStr "oaf"
pause
-- Line Foo
-- Loaf Bar
saveRestoreCursorExample :: IO ()
saveRestoreCursorExample = do
putStr "Start sentence ..."
pause
-- Start sentence ...
saveCursor
setCursorPosition 2 3
putStr "SPLASH!"
pause
-- Start sentence ...
--
-- SPLASH!
restoreCursor
putStr " end sentence, uninterrupted."
pause
-- Start sentence ... end sentence, uninterrupted
--
-- SPLASH!
clearExample :: IO ()
clearExample = do
putStrLn "Line One"
putStrLn "Line Two"
pause
-- Line One
-- Line Two
setCursorPosition 0 4
clearFromCursorToScreenEnd
pause
-- Line
resetScreen
putStrLn "Line One"
putStrLn "Line Two"
pause
-- Line One
-- Line Two
setCursorPosition 1 4
clearFromCursorToScreenBeginning
pause
--
-- Two
resetScreen
putStrLn "Line One"
putStrLn "Line Two"
pause
-- Line One
-- Line Two
setCursorPosition 0 4
clearFromCursorToLineEnd
pause
-- Line
-- Line Two
setCursorPosition 1 4
clearFromCursorToLineBeginning
pause
-- Line
-- Two
clearLine
pause
-- Line
clearScreen
pause
--
lineWrapExample :: IO ()
lineWrapExample = do
putStrLn $ take 240 $ cycle "Default-line-wrap|"
pause
-- Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Def
-- ault-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Defaul
-- t-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-l
disableLineWrap
putStrLn $ take 240 $ cycle "Disable-line-wrap|"
pause
-- Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Dis
enableLineWrap
putStrLn $ take 240 $ cycle "Enable-line-wrap|"
pause
-- Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-
-- line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wr
-- ap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enab
scrollExample :: IO ()
scrollExample = do
putStrLn "Line One"
putStrLn "Line Two"
putStrLn "Line Three"
pause
-- Line One
-- Line Two
-- Line Three
scrollPageDown 2
pause
--
--
-- Line One
-- Line Two
-- Line Three
scrollPageUp 3
pause
-- Line Two
-- Line Three
screenBuffersExample :: IO ()
screenBuffersExample = do
replicateM_ 5 $ putStrLn "This message is on the Normal Screen Bufffer"
replicateM_ 5 pause
useAlternateScreenBuffer
replicateM_ 5 $ putStrLn "This message is on the Alternate Screen Bufffer"
replicateM_ 5 pause
useNormalScreenBuffer
replicateM_ 5 $ putStrLn "This message is continuing where we left off"
replicateM_ 5 pause
sgrColorExample :: IO ()
sgrColorExample = do
let colors = enumFromTo minBound maxBound :: [Color]
forM_ [Foreground, Background, Underlining] $ \layer -> do
forM_ [Dull, Vivid] $ \intensity -> do
resetScreen
forM_ colors $ \color -> do
setSGR [Reset]
setSGR [SetColor layer intensity color]
setSGR [SetUnderlining SingleUnderline]
print color
pause
-- The ANSI eight standard colors, 6 times in sequence (three layers and two
-- intensities)
resetScreen
putStrLn "True color (24 bit color depth)"
putStrLn "-------------------------------"
putStrLn ""
setSGR [SetRGBColor Foreground $ sRGB24 0 0 0]
forM_ [0 .. 23] $ \row -> do
forM_ [0 .. 47] $ \col -> do
let r = row * 11
g = 255 - r
b = col * 5
setSGR [SetRGBColor Background $ sRGB24 r g b]
putStr "-"
putStrLn ""
replicateM_ 5 pause
-- True colors, a swatch of 24 rows and 48 columns
resetScreen
putStrLn "A 256-color palette"
putStrLn "-------------------"
putStrLn ""
-- First 16 colors ('system' colors in xterm protocol), in a row
--
-- 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 A A B B C C D D E E F F
forM_ [Dull .. Vivid] $ \intensity -> do
forM_ [Black .. White] $ \color -> do
let i = fromEnum intensity * 8 + fromEnum color
eol = i == 15
setSGR [SetPaletteColor Background $ xtermSystem intensity color]
setSGR [SetPaletteColor Foreground $ xtermSystem Dull Black]
printf "%X " i
setSGR [SetPaletteColor Foreground $ xtermSystem Vivid White]
printf "%X" i
if eol
then putStrLn ""
else do
setSGR [Reset]
putStr " "
putStrLn ""
-- Next 216 colors (6 level RGB in xterm protocol), in 12 rows of 18
--
-- 000 001 002 003 004 005 010 011 012 013 014 015 020 021 022 023 024 025
-- 030 031 032 033 034 035 040 041 042 043 044 045 050 051 052 053 054 055
-- 100 101 102 103 104 105 110 111 112 113 114 115 120 121 122 123 124 125
-- ... and so on ...
forM_ [0 .. 5] $ \r -> do
forM_ [0 .. 5] $ \g -> do
forM_ [0 .. 5] $ \b -> do
let i = 16 + b + g * 6 + r * 36
eol = i `mod` 18 == 15
r' = (r + 3) `mod` 6
g' = (g + 3) `mod` 6
b' = (b + 3) `mod` 6
setSGR [SetPaletteColor Foreground $ xterm6LevelRGB r' g' b']
setSGR [SetPaletteColor Background $ xterm6LevelRGB r g b]
putStr $ show r ++ show g ++ show b
if eol
then putStrLn ""
else do
setSGR [Reset]
putStr " "
putStrLn ""
-- Final 24 colors (24 levels of gray in xterm protocol), in two rows
--
-- 0 1 2 3 4 5 6 7 8 9 10 11
-- 12 13 14 15 16 17 18 19 20 21 22 23
forM_ [0 .. 23] $ \y -> do
setSGR [SetPaletteColor Foreground $ xterm24LevelGray $ (y + 12) `mod` 24]
setSGR [SetPaletteColor Background $ xterm24LevelGray y]
printf "%3d" y
if y == 11
then putStrLn ""
else do
setSGR [Reset]
putStr " "
replicateM_ 5 pause
resetScreen
setSGR [Reset]
setSGR [SetUnderlining SingleUnderline]
forM_
(zip "Underlining: True color (24 bit color depth)" (cycle [0, 10 .. 255])) $
\(c, i) -> do
setSGR [SetRGBColor Underlining $ sRGB24 i 0 0]
putChar c
putChar '\n'
putChar '\n'
setSGR [Reset]
setSGR [SetUnderlining SingleUnderline]
forM_ (zip "Underlining: A 256-color palette" (cycle [0 .. 5])) $
\(c, i) -> do
setSGR [SetPaletteColor Underlining $ xterm6LevelRGB i 0 0]
putChar c
putChar '\n'
replicateM_ 5 pause
sgrOtherExample :: IO ()
sgrOtherExample = do
let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold")
, (SetConsoleIntensity FaintIntensity, "Faint")
, (SetConsoleIntensity NormalIntensity, "Normal")
, (SetItalicized True, "Italic")
, (SetItalicized False, "No Italics")
, (SetUnderlining SingleUnderline, "Single Underline")
, (SetUnderlining DoubleUnderline, "Double Underline")
, (SetUnderlining CurlyUnderline, "Curly Underline")
, (SetUnderlining DottedUnderline, "Dotted Underline")
, (SetUnderlining DashedUnderline, "Dashed Underline")
, (SetUnderlining NoUnderline, "No Underline")
, (SetBlinkSpeed SlowBlink, "Slow Blink")
, (SetBlinkSpeed RapidBlink, "Rapid Blink")
, (SetBlinkSpeed NoBlink, "No Blink")
, (SetVisible False, "Conceal")
, (SetVisible True, "Reveal")
]
forM_ named_styles $ \(style, name) -> do
resetScreen
setSGR [style]
putStrLn name
pause
-- Text describing a style displayed in that style in sequence
setSGR [SetColor Foreground Vivid Red]
setSGR [SetColor Background Vivid Blue]
clearScreen >> setCursorPosition 0 0
setSGR [SetSwapForegroundBackground False]
putStr "Red-On-Blue"
pause
-- Red-On-Blue
clearScreen >> setCursorPosition 0 0
setSGR [SetSwapForegroundBackground True]
putStr "Blue-On-Red"
pause
-- Blue-On-Red
cursorVisibilityExample :: IO ()
cursorVisibilityExample = do
putStr "Cursor Demo"
pause
-- Cursor Demo|
hideCursor
pause
-- Cursor Demo
showCursor
pause
-- Cursor Demo|
hyperlinkExample :: IO ()
hyperlinkExample = do
putStr "Hyperlink demo: "
hyperlink "https://example.com" "Example hyperlink\n"
putStrLn ""
putStrLn "Linked hyperlinks demo:"
hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink one\n"
hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink two\n"
replicateM_ 5 pause
-- Hyperlink demo: Example hyperlink
--
-- Linked hyperlinks demo:
-- Example linked hyperlink one
-- Example linked hyperlink two
titleExample :: IO ()
titleExample = do
putStr "Title Demo"
pause
-- ~/foo/ - ansi-terminal-ex - 83x70
------------------------------------
-- Title Demo
setTitle "Yup, I'm a new title!"
pause
-- Yup, I'm a new title! - ansi-terminal-ex - 83x70
---------------------------------------------------
-- Title Demo
getCursorPositionExample :: IO ()
getCursorPositionExample = do
putStrLn " 11111111112222222222"
putStrLn "12345678901234567890123456789"
putStr "Report cursor position here:"
pause
-- 11111111112222222222
-- 12345678901234567890123456789
-- Report cursor position here:|
result <- getCursorPosition
putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n"
case result of
Just (row, col) -> putStrLn $ "The cursor was at row number " ++
show (row + 1) ++ " and column number " ++ show (col + 1) ++ ".\n"
Nothing -> putStrLn "Error: unable to get the cursor position\n"
replicateM_ 3 pause
-- 11111111112222222222
-- 12345678901234567890123456789
-- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.
--
-- The cursor was at row number 3 and column number 29.
getTerminalSizeExample :: IO ()
getTerminalSizeExample = do
result <- getTerminalSize
case result of
Just (h, w) -> putStrLn $ "The size of the terminal is " ++ show h ++
" rows by " ++ show w ++ " columns.\n"
Nothing -> putStrLn "Error: unable to get the terminal size\n"
pause
-- The size of the terminal is 25 rows by 80 columns.
getLayerColorExample :: IO ()
getLayerColorExample = do
fgResult <- getLayerColor Foreground
case fgResult of
Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++
show fgCol ++ "\n"
Nothing -> putStrLn "Error: unable to get the foreground color\n"
bgResult <- getLayerColor Background
case bgResult of
Just bgCol -> putStrLn $ "The reported background color is:\n" ++
show bgCol ++ "\n"
Nothing -> putStrLn "Error: unable to get the background color\n"