module System.Unix.Progress
(
Progress
, ProgressFlag(..)
, quietnessLevels
, runProgress
, lazyCommandP
, lazyProcessP
, defaultQuietness
, modQuietness
, quieter
, timeTask
, showElapsed
, ePutStr
, ePutStrLn
, qPutStr
, qPutStrLn
, eMessage
, eMessageLn
, qMessage
, qMessageLn
, tests
, defaultLevels
, lazyCommandV
, lazyProcessV
, lazyCommandF
, lazyProcessF
, lazyCommandE
, lazyProcessE
, lazyCommandEF
, lazyProcessEF
, lazyCommandD
, lazyCommandQ
, lazyCommandS
, lazyCommandSF
) where
import Control.Exception (evaluate, try, SomeException)
import Control.Monad (when)
import Control.Monad.State (StateT, get, evalStateT)
import "mtl" Control.Monad.Trans ( MonadIO, liftIO, lift )
import Data.Array ((!), array, bounds)
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List (intercalate)
import qualified Data.Set as Set
import Data.Time (NominalDiffTime, getCurrentTime, diffUTCTime)
import System.Environment (getArgs, getEnv)
import System.Exit (ExitCode(..))
import System.IO (hPutStrLn, stderr, hPutStr)
import System.Posix.Env (setEnv)
import System.Unix.Process (lazyProcess, lazyCommand, Output(Stdout, Stderr),
exitCodeOnly, stdoutOnly, mergeToStdout)
import Test.HUnit
type ProgressState = Set.Set ProgressFlag
type Progress m a = MonadIO m => StateT ProgressState m a
data ProgressFlag
= Echo
| Dots
| All
| Errors
| Result
| EchoOnFail
| AllOnFail
| ErrorsOnFail
| ResultOnFail
| ExceptionOnFail
deriving (Ord, Eq)
quietnessLevels :: [Set.Set ProgressFlag] -> Int -> Set.Set ProgressFlag
quietnessLevels flagLists i =
a ! (min r . max l $ i)
where a = array (0, length flagLists 1) (zip [0..] flagLists)
(l, r) = bounds a
runProgress :: MonadIO m =>
(Int -> Set.Set ProgressFlag)
-> Progress m a
-> m a
runProgress flags action =
quietness >>= evalStateT action . flags
lazyCommandP :: MonadIO m => (Int -> Set.Set ProgressFlag) -> String -> L.ByteString -> m [Output]
lazyCommandP flags cmd input =
runProgress flags (lift (lazyCommand cmd input) >>= doProgress cmd)
lazyProcessP :: MonadIO m => (Int -> Set.Set ProgressFlag) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessP flags exec args cwd env input =
runProgress flags (lift (lazyProcess exec args cwd env input) >>= doProgress (intercalate " " (exec : args)))
defaultQuietness :: MonadIO m => m Int
defaultQuietness = 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
modQuietness :: MonadIO m => (Int -> Int) -> m a -> m a
modQuietness 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 -> m a -> m a
quieter q task = modQuietness (+ q) task
doProgress :: MonadIO m => String -> [Output] -> Progress m [Output]
doProgress cmd output =
get >>= \ s ->
doEcho s output >>= doOutput s >>= doResult s >>= doFail s
where
doEcho s output
| Set.member Echo s || (Set.member EchoOnFail s && exitCodeOnly output /= ExitSuccess) =
liftIO (ePutStrLn ("-> " ++ cmd)) >> return output
| True = return output
doOutput s output
| Set.member All s || (Set.member AllOnFail s && exitCodeOnly output /= ExitSuccess) =
liftIO (printOutput (prefixes opre epre output))
| Set.member Dots s =
liftIO (dotOutput 128 output)
| Set.member Errors s || (Set.member ErrorsOnFail s && exitCodeOnly output /= ExitSuccess) =
liftIO (printErrors (prefixes opre epre output))
| True = return output
doResult s output
| Set.member Result s || (Set.member ResultOnFail s && exitCodeOnly output /= ExitSuccess) =
liftIO (ePutStrLn ("<- " ++ show (exitCodeOnly output))) >> return output
| True = return output
doFail :: MonadIO m => ProgressState -> [Output] -> Progress m [Output]
doFail s output
| Set.member ExceptionOnFail s =
case exitCodeOnly output of
ExitSuccess -> return output
result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)
| True = return output
opre = B.pack " 1> "
epre = B.pack " 2> "
dotOutput :: MonadIO m => Int -> [Output] -> m [Output]
dotOutput groupSize output =
mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs >>= eMessageLn ""
where
pairs = zip (dots 0 (map length output)) output
dots _ [] = []
dots rem (count : more) =
let (count', rem') = divMod (count + rem) groupSize in
count' : dots rem' more
length (Stdout s) = B.length s
length (Stderr s) = B.length s
length _ = 0
prefixes :: B.ByteString -> B.ByteString -> [Output] -> [(Output, Output)]
prefixes opre epre output =
f True output
where
f :: Bool -> [Output] -> [(Output, Output)]
f _ [] = []
f bol (x@(Stdout s) : output') = let (s', bol') = doOutput bol opre s in (x, Stdout s') : f bol' output'
f bol (x@(Stderr s) : output') = let (s', bol') = doOutput bol epre s in (x, Stderr s') : f bol' output'
f bol (x : output') = (x, Stdout B.empty) : f bol output'
doOutput :: Bool -> B.ByteString -> B.ByteString -> (B.ByteString, Bool)
doOutput bol pre s =
let (a, b) = B.span (/= '\n') s in
if B.null a
then if B.null b
then (B.empty, bol)
else let x = (if bol then pre else B.empty)
(s', bol') = doOutput True pre (B.tail b) in
(B.concat [x, (B.pack "\n"), s'], bol')
else let x = (if bol then B.append pre a else a)
(s', bol') = doOutput False pre b in
(B.append x s', bol')
printOutput :: MonadIO m => [(Output, Output)] -> m [Output]
printOutput output =
mapM (liftIO . print') output
where
print' (x, y) = print y >> return x
print (Stdout s) = putStr (B.unpack s)
print (Stderr s) = ePutStr (B.unpack s)
print _ = return ()
printErrors :: MonadIO m => [(Output, Output)] -> m [Output]
printErrors output =
mapM print' output
where
print' (x, y) = print y >> return x
print (Stderr s) = ePutStr (B.unpack s)
print _ = return ()
timeTask :: MonadIO m => m a -> m (a, NominalDiffTime)
timeTask x =
do start <- liftIO getCurrentTime
result <- x >>= liftIO . evaluate
finish <- liftIO getCurrentTime
return (result, diffUTCTime finish start)
showElapsed :: MonadIO m => String -> m a -> m a
showElapsed label f =
do (result, time) <- timeTask f
ePutStr (label ++ formatTime' time)
return result
formatTime' :: NominalDiffTime -> String
formatTime' diff = show diff
ePutStr :: MonadIO m => String -> m ()
ePutStr = liftIO . hPutStr stderr
ePutStrLn :: MonadIO m => String -> m ()
ePutStrLn = liftIO . hPutStrLn stderr
qPutStr :: MonadIO m => String -> m ()
qPutStr s = quietness >>= \ q -> when (q < 0) (ePutStr s)
qPutStrLn :: MonadIO m => String -> m ()
qPutStrLn s = quietness >>= \ q -> when (q < 0) (ePutStrLn s)
eMessage :: MonadIO m => String -> a -> m a
eMessage message output = ePutStr message >> return output
eMessageLn :: MonadIO m => String -> a -> m a
eMessageLn message output = ePutStrLn message >> return output
qMessage :: MonadIO m => String -> a -> m a
qMessage message output = quietness >>= \ q -> when (q < 0) (ePutStr message) >> return output
qMessageLn :: MonadIO m => String -> a -> m a
qMessageLn message output = quietness >>= \ q -> when (q < 0) (ePutStrLn message) >> return output
tests :: [Test]
tests =
[TestCase (assertEqual "Check behavior of code to insert prefixes into Output"
(collect (prefixes (p "[1] ") (p "[2] ")
[Stdout (p "abc\ndef\n\n"), Stderr (p "\nghi\njkl\n")]))
"[1] abc\n[1] def\n[1] \n[2] \n[2] ghi\n[2] jkl\n")]
where
p = B.pack
collect :: [(Output, Output)] -> String
collect = L.unpack . stdoutOnly . mergeToStdout . snd . unzip
defaultLevels :: [Set.Set ProgressFlag]
defaultLevels =
map Set.fromList [ [Echo, All, Result]
, [Echo, Dots, Result]
, [Echo]
, [] ]
flags :: Int -> Set.Set ProgressFlag
flags = quietnessLevels defaultLevels
flagsF :: Int -> Set.Set ProgressFlag
flagsF = quietnessLevels (map (Set.union (Set.fromList [ExceptionOnFail])) defaultLevels)
flagsE :: Int -> Set.Set ProgressFlag
flagsE = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail])) defaultLevels)
flagsEF :: Int -> Set.Set ProgressFlag
flagsEF = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail])) defaultLevels)
lazyCommandV :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandV = lazyCommandP flags
lazyProcessV :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessV = lazyProcessP flags
lazyCommandF :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandF = lazyCommandP flagsF
lazyProcessF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessF = lazyProcessP flagsF
lazyCommandE :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandE = lazyCommandP flagsE
lazyProcessE :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessE = lazyProcessP flagsE
lazyCommandEF :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandEF = lazyCommandP flagsEF
lazyProcessEF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessEF = lazyProcessP flagsEF
lazyCommandD :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandD cmd input = quieter 1 $ lazyCommandP flagsE cmd input
lazyCommandQ :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandQ cmd input = quieter 3 $ lazyCommandP flagsE cmd input
lazyCommandS :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandS cmd input = quieter 4 $ lazyCommandP flagsE cmd input
lazyCommandSF :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandSF cmd input = quieter 4 $ lazyCommandP flagsEF cmd input