module System.Unix.QIO
( ePutStr
, ePutStrLn
, eMessage
, eMessageLn
, initialQuietness
, quietness
, quieter
, quieter'
, qDo
, qPutStr
, qPutStrLn
, qMessage
, qMessageLn
, q12
, q02
, v1
, v2
, v3
, showQ
) where
import Control.Exception (try, SomeException)
import "mtl" Control.Monad.Trans ( MonadIO, liftIO )
import System.Environment (getArgs, getEnv)
import System.IO (hPutStrLn, stderr, hPutStr)
import System.Posix.Env (setEnv)
ePutStr :: MonadIO m => String -> m ()
ePutStr s = liftIO $ hPutStr stderr s
ePutStrLn :: MonadIO m => String -> m ()
ePutStrLn s = liftIO $ hPutStrLn stderr s
eMessage :: MonadIO m => String -> b -> m b
eMessage s x = liftIO (hPutStr stderr s) >> return x
eMessageLn :: MonadIO m => String -> b -> m b
eMessageLn s x = liftIO (hPutStrLn stderr s) >> return x
initialQuietness :: MonadIO m => m Int
initialQuietness = liftIO $
do v1' <- try (getEnv "VERBOSITY" >>= return . read) >>= either (\ (_ :: SomeException) -> return 0) return
v2' <- getArgs >>= return . length . filter (== "-v")
q1 <- try (getEnv "QUIETNESS" >>= return . read) >>= either (\ (_ :: SomeException) -> return 0) return
q2 <- getArgs >>= return . length . filter (== "-q")
return $ q1 v1' + q2 v2'
quietness :: MonadIO m => m Int
quietness = liftIO (try (getEnv "QUIETNESS" >>= return . read)) >>=
either (\ (_ :: SomeException) -> return 0) return
quieter :: MonadIO m => (Int -> Int) -> m a -> m a
quieter f task =
quietness >>= \ q0 ->
setQuietness (f q0) >>
task >>= \ result ->
setQuietness q0 >>
return result
where
setQuietness :: MonadIO m => Int -> m ()
setQuietness q = liftIO $ setEnv "QUIETNESS" (show q) True
quieter' :: MonadIO m => (Int -> Int) -> m a -> m a
quieter' _ x = x
qDo :: MonadIO m => m () -> m ()
qDo task = quietness >>= \ q -> if (q < 1) then task else return ()
qPutStr :: MonadIO m => String -> m ()
qPutStr s = qDo (ePutStr s)
qPutStrLn :: MonadIO m => String -> m ()
qPutStrLn s = qDo (ePutStrLn s)
qMessage :: MonadIO m => String -> a -> m a
qMessage message output = qDo (ePutStr message) >> return output
qMessageLn :: MonadIO m => String -> a -> m a
qMessageLn message output = qDo (ePutStrLn message) >> return output
q12 :: MonadIO m => String -> m a -> m a
q12 s a = quieter (+ 1) $ qPutStrLn s >> quieter (+ 2) a
q02 :: MonadIO m => String -> m a -> m a
q02 s a = qPutStrLn s >> quieter (+ 2) a
v1, v2, v3 :: (MonadIO m) => m a -> m a
v1 a = quieter (\x->x1) a
v2 a = quieter (\x->x2) a
v3 a = quieter (\x->x3) a
showQ :: MonadIO m => String -> m a -> m a
showQ s a = quietness >>= \ n -> ePutStrLn (s ++ ": quietness=" ++ show n) >> a