Stylized.hs

module System.Console.ANSI.Stylized
  ( ColorIntensity(..)
  , Color(..)
  , ConsoleIntensity(..)
  , Underlining(..)
  , Style, ColourOption, StyleOption
  , hResetGR, resetGR
  , hPutStrS, putStrS
  , hPutStrLnS, putStrLnS
  , hPutS, putS
  , hPutLnS, putLnS
  , hPutT, putT
  , hPutLnT, putLnT
  ) where


import Control.Arrow
import System.Console.ANSI
import System.IO


type Style = (ColourOption, StyleOption)

type ColourOption = (ColorIntensity, Color)

type StyleOption = (ConsoleIntensity, Underlining)


styleToSGRs :: Style -> [SGR]
styleToSGRs ((col_int, col), (b, u)) =
  [
    SetColor Foreground col_int col,
    SetConsoleIntensity b,
    SetUnderlining u
  ]


-- |Given an handle, reset graphic rendition
hResetGR :: Handle -> IO ()
hResetGR h = hSetSGR h [Reset]

-- |On stdout, reset graphic rendition
resetGR :: IO ()
resetGR = setSGR [Reset]

-- |Given an handle, set style and put string
hPutStrS :: Handle -> Style -> String -> IO ()
hPutStrS h style s = do
  hSetSGR h $ styleToSGRs style
  hPutStr h s

-- |On stdout, set style and put string
putStrS :: Style -> String -> IO ()
putStrS = hPutStrS stdout

-- |Given an handle, set style and put string followed by newline
hPutStrLnS :: Handle -> Style -> String -> IO ()
hPutStrLnS h style s = do
  hSetSGR h $ styleToSGRs style
  hPutStrLn h s

-- |On stdout, set style and put string followed by newline
putStrLnS :: Style -> String -> IO ()
putStrLnS = hPutStrLnS stdout


-- |Given an handle, for each item set style and put string
hPutS :: Handle -> [(Style, String)] -> IO ()
hPutS _ [] = return ()
hPutS h (x:[]) = uncurry (hPutStrS h) x
hPutS h (x:xs) = uncurry (hPutStrS h) x >> hPutS h xs

-- |On stdout, for each item set style and put string
putS :: [(Style, String)] -> IO ()
putS = hPutS stdout

-- |Given an handle, for each item set style and put string followed by newline
hPutLnS :: Handle -> [(Style, String)] -> IO ()
hPutLnS _ [] = return ()
hPutLnS h (x:[]) = uncurry (hPutStrLnS h) x
hPutLnS h (x:xs) = uncurry (hPutStrS h) x >> hPutLnS h xs

-- |On stdout, for each item set style and put string followed by newline
putLnS :: [(Style, String)] -> IO ()
putLnS = hPutLnS stdout


-- |Given a function mapping some type t to 'Style', return a function
--  behaving like 'hPutS'
hPutT :: (t -> Style) -> Handle -> [(t, String)] -> IO ()
hPutT fn h xs = hPutS h $ map (first fn) xs

-- |Given a function mapping some type t to 'Style', return a function
--  behaving like 'putS'
putT :: (t -> Style) -> [(t, String)] -> IO ()
putT fn = hPutT fn stdout

-- |Given a function mapping some type t to 'Style', return a function
--  behaving like 'hPutLnS'
hPutLnT :: (t -> Style) -> Handle -> [(t, String)] -> IO ()
hPutLnT fn h xs = hPutLnS h $ map (first fn) xs

-- |Given a function mapping some type t to 'Style', return a function
--  behaving like 'putLnS'
putLnT :: (t -> Style) -> [(t, String)] -> IO ()
putLnT fn = hPutLnT fn stdout