src/Network/Services/TSN/Terminal.hs

   1 -- | Terminal output functions for displaying informational
   2 --   messages. The output is color-coded according to severity, and is
   3 --   designed at the moment for consoles with a dark background.
   4 --
   5 module Network.Services.TSN.Terminal (
   6   display_debug,
   7   display_error,
   8   display_info,
   9   display_sent,
  10   display_warning )
  11 where
  12
  13 import Control.Monad.IO.Class (MonadIO(..))
  14 import System.Console.ANSI (
  15   SGR( SetColor ),
  16   Color(..),
  17   ColorIntensity( Vivid ),
  18   ConsoleLayer( Foreground ),
  19   hSetSGR )
  20 import System.IO ( Handle, hPutStr, stderr, stdout )
  21
  22 -- | Perform a computation (anything in MonadIO) with the given
  23 --   graphics mode(s) enabled. Revert to the previous graphics mode
  24 --   after the computation has finished.
  25 with_sgr :: (MonadIO m) => Handle -> [SGR] -> m a -> m a
  26 with_sgr h sgrs computation = do
  27   liftIO $ hSetSGR h sgrs
  28   x <- computation
  29   liftIO $ hSetSGR h []
  30   return x
  31
  32 -- | Perform a computation (anything in MonadIO) with the output set
  33 --   to a certain color. Reset to the default color after the
  34 --   computation has finished.
  35 with_color :: (MonadIO m) => Handle -> Color -> m a -> m a
  36 with_color h color =
  37   with_sgr h [SetColor Foreground Vivid color]
  38
  39
  40 -- | Write the given String to a handle in color. The funnyCaps are
  41 --   for synergy with putstrLn and friends.
  42 --
  43 hPutStrColor :: Handle -> Color -> String -> IO ()
  44 hPutStrColor h c = with_color h c . hPutStr h
  45
  46
  47 -- | Write the given line to a handle in color. The funnyCaps are for
  48 --   synergy with putstrLn and friends.
  49 --
  50 hPutStrColorLn :: Handle -> Color -> String -> IO ()
  51 hPutStrColorLn h c s = hPutStrColor h c (s ++ "\n")
  52
  53
  54 -- | Display text sent to the feed on the console. Don't automatically
  55 --   append a newline.
  56 --
  57 display_sent :: String -> IO ()
  58 display_sent = hPutStrColor stdout Green
  59
  60
  61 -- | Display debug text on the console. Don't automatically append a
  62 --   newline in case the raw text is needed for, uh, debugging. The
  63 --   text color is not altered.
  64 --
  65 display_debug :: String -> IO ()
  66 display_debug = putStr
  67
  68
  69 -- | Display an informational message on the console in cyan.
  70 --
  71 display_info :: String -> IO ()
  72 display_info = hPutStrColorLn stdout Cyan
  73
  74
  75 -- | Display a warning on the console in yello. Uses stderr instead of
  76 --   stdout.
  77 --
  78 display_warning :: String -> IO ()
  79 display_warning = hPutStrColorLn stderr Yellow
  80
  81
  82 -- | Display an error on the console in red. Uses stderr instead of
  83 --   stdout.
  84 --
  85 display_error :: String -> IO ()
  86 display_error = hPutStrColorLn stderr Red