module Extra.CIO
(
CIO(..)
, TStyle(..)
, defStyle
, withStyle
, setVerbosity
, addVerbosity
, setPrefix
, addPrefix
, appPrefix
, setPrefixes
, addPrefixes
, appPrefixes
, hGetPrefix
, putStr
, ePutStr
, vPutStr
, vEPutStr
, hPutChar
, putChar
, ePutChar
, vHPutChar
, vPutChar
, vEPutChar
, hPutStrBl
, putStrBl
, ePutStrBl
, vHPutStrBl
, vPutStrBl
, vEPutStrBl
, hPutStrLn
, putStrLn
, ePutStrLn
, vHPutStrLn
, vPutStrLn
, vEPutStrLn
, bol
, eBOL
, vHBOL
, vBOL
, vEBOL
, hColor
, blue
, green
, red
, magenta
) where
import Prelude hiding (putStr, putChar, putStrLn)
import qualified System.IO as IO
import Control.Monad.Trans
import Control.Exception
class MonadIO m => CIO m where
hPutStr :: IO.Handle -> String -> m ()
hBOL :: IO.Handle -> m ()
ev :: Int -> m Int
setStyle :: (TStyle -> TStyle) -> m a -> m a
tryCIO :: m a -> m (Either SomeException a)
data TStyle
= TStyle { prefix :: String
, verbosity :: Int
, hPrefix :: [(IO.Handle, String)]
} deriving Show
defStyle :: TStyle
defStyle = TStyle { prefix = ": "
, hPrefix = []
, verbosity = 0
}
withStyle :: CIO m => TStyle -> m a -> m a
withStyle newStyle = setStyle (const newStyle)
setVerbosity :: Int -> TStyle -> TStyle
setVerbosity n style = style {verbosity = n}
addVerbosity :: Int -> TStyle -> TStyle
addVerbosity n style = setVerbosity (n + verbosity style) style
setPrefix :: String -> TStyle -> TStyle
setPrefix prefix style = style {prefix = prefix}
addPrefix :: String -> TStyle -> TStyle
addPrefix newPrefix style = style {prefix = newPrefix ++ prefix style}
appPrefix :: String -> TStyle -> TStyle
appPrefix newPrefix style = style {prefix = prefix style ++ newPrefix}
hSetPrefix :: IO.Handle -> String -> TStyle -> TStyle
hSetPrefix handle string style =
style {hPrefix = (handle, string) : filter ((/= handle) . fst) (hPrefix style)}
hAddPrefix :: IO.Handle -> String -> TStyle -> TStyle
hAddPrefix handle string style =
hSetPrefix handle (string ++ prefix) style
where prefix = maybe "" id (lookup handle (hPrefix style))
hAppPrefix :: IO.Handle -> String -> TStyle -> TStyle
hAppPrefix handle string style =
hSetPrefix handle (prefix ++ string) style
where prefix = maybe "" id (lookup handle (hPrefix style))
hGetPrefix :: IO.Handle -> TStyle -> String
hGetPrefix handle style = prefix style ++ maybe "" id (lookup handle (hPrefix style))
setPrefixes :: String -> String -> TStyle -> TStyle
setPrefixes stdoutPrefix stderrPrefix style =
hSetPrefix IO.stdout stdoutPrefix . hSetPrefix IO.stderr stderrPrefix $ style
addPrefixes :: String -> String -> TStyle -> TStyle
addPrefixes oPrefix ePrefix style =
hAddPrefix IO.stdout oPrefix . hAddPrefix IO.stderr ePrefix $ style
appPrefixes :: String -> String -> TStyle -> TStyle
appPrefixes oPrefix ePrefix style =
hAppPrefix IO.stdout oPrefix . hAppPrefix IO.stderr ePrefix $ style
vIO :: CIO m => Int -> a -> m a -> m a
vIO v d f =
do v' <- ev v
if v' >= 0 then f else return d
putStr :: CIO m => String -> m ()
putStr = hPutStr IO.stdout
ePutStr :: CIO m => String -> m ()
ePutStr = hPutStr IO.stderr
vEPutStr :: CIO m => Int -> String -> m ()
vEPutStr = vHPutStr IO.stderr
vPutStr :: CIO m => Int -> String -> m ()
vPutStr = vHPutStr IO.stdout
hPutChar :: CIO m => IO.Handle -> Char -> m ()
hPutChar h c = hPutStr h [c]
putChar :: CIO m => Char -> m ()
putChar = hPutChar IO.stdout
ePutChar :: CIO m => Char -> m ()
ePutChar = hPutChar IO.stderr
vHPutStr :: CIO m => IO.Handle -> Int -> String -> m ()
vHPutStr h v s = vIO v () (hPutStr h s)
vHPutChar :: CIO m => IO.Handle -> Int -> Char -> m ()
vHPutChar h v c = vHPutStr h v [c]
vPutChar :: CIO m => Int -> Char -> m ()
vPutChar = vHPutChar IO.stdout
vEPutChar :: CIO m => Int -> Char -> m ()
vEPutChar = vHPutChar IO.stderr
hPutStrBl :: CIO m => IO.Handle -> String -> m ()
hPutStrBl h s = hBOL h >> hPutStr h s
putStrBl :: CIO m => String -> m ()
putStrBl = hPutStrBl IO.stdout
ePutStrBl :: CIO m => String -> m ()
ePutStrBl = hPutStrBl IO.stderr
vHPutStrBl :: CIO m => IO.Handle -> Int -> String -> m ()
vHPutStrBl h v s = vHBOL h v >> vHPutStr h v s
vPutStrBl :: CIO m => Int -> String -> m ()
vPutStrBl = vHPutStrBl IO.stdout
vEPutStrBl :: CIO m => Int -> String -> m ()
vEPutStrBl = vHPutStrBl IO.stderr
hPutStrLn :: CIO m => IO.Handle -> String -> m ()
hPutStrLn h s = hBOL h >> hPutStr h s
putStrLn :: CIO m => String -> m ()
putStrLn s = hPutStrLn IO.stdout s
ePutStrLn :: CIO m => String -> m ()
ePutStrLn = hPutStrLn IO.stderr
vHPutStrLn :: CIO m => IO.Handle -> Int -> String -> m ()
vHPutStrLn h v s = vHBOL h v >> vHPutStr h v s
vPutStrLn :: CIO m => Int -> String -> m ()
vPutStrLn = vHPutStrLn IO.stdout
vEPutStrLn :: CIO m => Int -> String -> m ()
vEPutStrLn = vHPutStrLn IO.stderr
bol :: CIO m => m ()
bol = hBOL IO.stdout
eBOL :: CIO m => m ()
eBOL = hBOL IO.stderr
vHBOL :: CIO m => IO.Handle -> Int -> m ()
vHBOL h v = vIO v () (hBOL h)
vBOL :: CIO m => Int -> m ()
vBOL = vHBOL IO.stdout
vEBOL :: CIO m => Int -> m ()
vEBOL = vHBOL IO.stderr
hColor h s = case h of
_ | h == IO.stdout -> green s
_ | h == IO.stdout -> red s
_ -> magenta s
blue s = "\ESC[34m" ++ s ++ "\ESC[30m"
green s = "\ESC[32m" ++ s ++ "\ESC[30m"
red s = "\ESC[31m" ++ s ++ "\ESC[30m"
magenta s = "\ESC[35m" ++ s ++ "\ESC[30m"