X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTerminal.hs;h=6031d62c5e9a7cdd3919099622c701cb6e9ad60f;hb=52e788e676ea2a67ad20b23d2e5c5b351f27b834;hp=7e8850519303a497da3813593c295388df60d288;hpb=49c23c133221c9686dde0d52d06904db8d048724;p=dead%2Fhtsn.git

diff --git a/src/Terminal.hs b/src/Terminal.hs
index 7e88505..6031d62 100644
--- a/src/Terminal.hs
+++ b/src/Terminal.hs
@@ -1,7 +1,9 @@
 module Terminal (
-  hPutBlueStr,
-  hPutRedStr,
-  putGreenLn )
+  display_debug,
+  display_error,
+  display_info,
+  display_sent,
+  display_warning )
 where
 
 import Control.Monad.IO.Class (MonadIO(..))
@@ -10,38 +12,45 @@ import System.Console.ANSI (
   Color(..),
   ColorIntensity( Vivid ),
   ConsoleLayer( Foreground ),
-  setSGR )
-import System.IO ( Handle, hPutStr )
+  hSetSGR )
+import System.IO ( Handle, hPutStr, stderr, stdout )
 
 -- | Perform a computation (anything in MonadIO) with the given
 --   graphics mode(s) enabled. Revert to the previous graphics mode
 --   after the computation has finished.
-with_sgr :: (MonadIO m) => [SGR] -> m a -> m a
-with_sgr sgrs computation = do
-  liftIO $ setSGR sgrs
+with_sgr :: (MonadIO m) => Handle -> [SGR] -> m a -> m a
+with_sgr h sgrs computation = do
+  liftIO $ hSetSGR h sgrs
   x <- computation
-  liftIO $ setSGR []
+  liftIO $ hSetSGR h []
   return x
 
--- | Perform a computation (anything in MonadIO) with the terminal
---   output set to a certain color. Reset to the default color after
---   the computation has finished.
-with_color :: (MonadIO m) => Color -> m a -> m a
-with_color color =
-  with_sgr [SetColor Foreground Vivid color]
+-- | Perform a computation (anything in MonadIO) with the output set
+--   to a certain color. Reset to the default color after the
+--   computation has finished.
+with_color :: (MonadIO m) => Handle -> Color -> m a -> m a
+with_color h color =
+  with_sgr h [SetColor Foreground Vivid color]
 
 
--- | Output the given line to the given handle, in red. The silly
---   camelCase name is for consistency with e.g. hPutStrLn.
-hPutRedStr :: Handle -> String -> IO ()
-hPutRedStr h = with_color Red . hPutStr h
+hPutStrColor :: Handle -> Color -> String -> IO ()
+hPutStrColor h c = with_color h c . hPutStr h
 
--- | Output the given line to the given handle, in blue. The silly
---   camelCase name is for consistency with e.g. hPutStrLn.
-hPutBlueStr :: Handle -> String -> IO ()
-hPutBlueStr h = with_color Blue . hPutStr h
+hPutStrColorLn :: Handle -> Color -> String -> IO ()
+hPutStrColorLn h c s = hPutStrColor h c (s ++ "\n")
 
--- | Output the given line to stdout, in green. The silly camelCase
---   name is for consistency with e.g. putStrLn.
-putGreenLn :: String -> IO ()
-putGreenLn = with_color Green . putStrLn
+-- | Don't automatically append a newline.
+display_sent :: String -> IO ()
+display_sent = hPutStrColor stdout Green
+
+display_debug :: String -> IO ()
+display_debug = putStr
+
+display_info :: String -> IO ()
+display_info = hPutStrColorLn stdout Cyan
+
+display_warning :: String -> IO ()
+display_warning = hPutStrColorLn stderr Yellow
+
+display_error :: String -> IO ()
+display_error = hPutStrColorLn stderr Red