ansi-colorizer.hs

{-# LANGUAGE Safe #-}

-- this demo is placed into the public domain.

-- base
import Control.Monad (forever)
-- ansi-terminal
import System.Console.ANSI

main = do
    putStrLn "Type a line and I'll colorize it."
    putStrLn "Use @ for text color, and $ for background color,"
    putStrLn "followed by one of krgybmcw (lowercase or uppercase)."
    putStr "eg, @ghello ==> "
    formatStringLn "@ghello"
    forever $ do
        line <- getLine
        formatStringLn line

-- | Allows you to output a string that has embedded color controls in it. Using
-- the at-sign affects the text color, and using the dollar sign affects the
-- background color. The control symbol is then followed by one of "krgybmcw"
-- for blacK, Red, Green, Yellow, Blue, Magenta, Cyan, White. Each color is
-- available in a dull (lowercase) or vivid (uppercase) variant. At the end of
-- the string any color changes are reset so that colors don't bleed into the
-- next formatting accidentally.
--
-- The following special cases apply:
--
-- * If you use the same control character twice in a row, it will always
-- "escape" that use and put the control character once without changing the
-- colors. This is only necessary when the next character would be one that
-- normally sets a color (eg: "[email protected]")
--
-- * If you use a control character followed by a character that doesn't control
-- the color then both characters will be printed and you won't need to escape
-- the control character (eg: "[email protected]") though you still can if you
-- want and the result will be the same (eg: "foo@@hotmail.com").
--
-- Example: formatString "@gHe$bllo @Wwor$k@rld\n"
formatString :: String -> IO ()
formatString [] = setSGR [Reset]
formatString ('@':'@':more) = putChar '@' >> formatString more
formatString ('@':c:more) = do
    case c of
        'k' -> setSGR [SetColor Foreground Dull Black]
        'K' -> setSGR [SetColor Foreground Vivid Black]
        'r' -> setSGR [SetColor Foreground Dull Red]
        'R' -> setSGR [SetColor Foreground Vivid Red]
        'g' -> setSGR [SetColor Foreground Dull Green]
        'G' -> setSGR [SetColor Foreground Vivid Green]
        'y' -> setSGR [SetColor Foreground Dull Yellow]
        'Y' -> setSGR [SetColor Foreground Vivid Yellow]
        'b' -> setSGR [SetColor Foreground Dull Blue]
        'B' -> setSGR [SetColor Foreground Vivid Blue]
        'm' -> setSGR [SetColor Foreground Dull Magenta]
        'M' -> setSGR [SetColor Foreground Vivid Magenta]
        'c' -> setSGR [SetColor Foreground Dull Cyan]
        'C' -> setSGR [SetColor Foreground Vivid Cyan]
        'w' -> setSGR [SetColor Foreground Dull White]
        'W' -> setSGR [SetColor Foreground Vivid White]
        _ -> putChar '@' >> putChar c
    formatString more
formatString ('$':'$':more) = putChar '$' >> formatString more
formatString ('$':c:more) = do
    case c of
        'k' -> setSGR [SetColor Background Dull Black]
        'K' -> setSGR [SetColor Background Vivid Black]
        'r' -> setSGR [SetColor Background Dull Red]
        'R' -> setSGR [SetColor Background Vivid Red]
        'g' -> setSGR [SetColor Background Dull Green]
        'G' -> setSGR [SetColor Background Vivid Green]
        'y' -> setSGR [SetColor Background Dull Yellow]
        'Y' -> setSGR [SetColor Background Vivid Yellow]
        'b' -> setSGR [SetColor Background Dull Blue]
        'B' -> setSGR [SetColor Background Vivid Blue]
        'm' -> setSGR [SetColor Background Dull Magenta]
        'M' -> setSGR [SetColor Background Vivid Magenta]
        'c' -> setSGR [SetColor Background Dull Cyan]
        'C' -> setSGR [SetColor Background Vivid Cyan]
        'w' -> setSGR [SetColor Background Dull White]
        'W' -> setSGR [SetColor Background Vivid White]
        _ -> putChar '$' >> putChar c
    formatString more
formatString (other:more) = do
    putChar other
    formatString more

-- | As per 'formatString', but puts a newline at the end for you.
formatStringLn :: String -> IO ()
formatStringLn s = formatString s >> putStrLn ""