Example.hs

module Main (
        main
    ) where

import System.Console.ANSI

import System.IO

import Control.Concurrent
import Control.Monad


examples :: [IO ()]
examples = [ cursorMovementExample
           , lineChangeExample
           , setCursorPositionExample
           , saveRestoreCursorExample
           , clearExample
           , scrollExample
           , sgrExample
           , cursorVisibilityExample
           , titleExample
           , getCursorPositionExample
           ]

main :: IO ()
main = mapM_ (\example -> resetScreen >> example) examples

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

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

sgrExample :: IO ()
sgrExample = do
    let colors = enumFromTo minBound maxBound :: [Color]
    forM_ [Foreground, Background] $ \layer ->  do
        forM_ [Dull, Vivid] $ \intensity -> do
            resetScreen
            forM_ colors $ \color -> do
                setSGR [Reset]
                setSGR [SetColor layer intensity color]
                putStrLn (show color)
            pause
    -- All the colors, 4 times in sequence

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

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 ++ " and column number " ++ show col ++ ".\n"
        Nothing -> putStrLn "Error: unable to get the cursor position\n"
    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.