module System.Unix.Progress
(
systemTask,
otherTask,
Style (Start, Finish, Error, Output, Echo, Elapsed, Verbosity, Indent),
readStyle,
Output (Indented, Dots, Done, Quiet),
msg,
msgLn,
output,
verbosity,
setStyles,
setStyle,
addStyles,
addStyle,
removeStyle,
stripDist,
showElapsed,
System.Time.TimeDiff,
System.Time.noTimeDiff,
fixedTimeDiffToString
) where
import Control.Exception
import Data.List
import System.Exit
import System.IO
import System.Process
import System.Time
data Output
= Indented |
Dots |
Done |
Quiet
instance Show Output where
show Indented = "Indented"
show Dots = "Dots"
show Done = "Done"
show Quiet = "Quiet "
data Style
= Start String |
Finish String |
Error String |
Output Output |
Echo Bool |
Elapsed Bool |
Verbosity Int |
Indent String
instance Show Style where
show (Start s) = "Start " ++ show s
show (Finish s) = "Finish " ++ show s
show (Error s) = "Error " ++ show s
show (Output output) = "Output " ++ show output
show (Echo flag) = "Echo " ++ show flag
show (Elapsed flag) = "Elapsed " ++ show flag
show (Verbosity n) = "Verbosity " ++ show n
show (Indent s) = "Verbosity " ++ show s
styleClass (Start _) = "Start"
styleClass (Finish _) = "Finish"
styleClass (Error _) = "Error"
styleClass (Output _) = "Progress"
styleClass (Echo _) = "Echo"
styleClass (Elapsed _) = "Elapsed"
styleClass (Verbosity _) = "Verbosity"
styleClass (Indent _) = "Indent"
instance Eq Style where
a == b = styleClass a == styleClass b
systemTask :: [Style] -> String -> IO TimeDiff
systemTask style command =
do
start <- getClockTime
putIndent style
startMessage style
taskStart style
(_, _, outputHandle, processHandle) <- runInteractiveCommand ("{ " ++ command ++ "; } 1>&2")
text <- progressOutput (maybe Indented id (output style)) outputHandle;
result <- waitForProcess processHandle
finish <- getClockTime
let elapsed = diffClockTimes finish start
case result of
ExitSuccess -> finishMessage style elapsed
ExitFailure _ -> errorMessage style text
return elapsed
where
taskStart (Echo True : etc) = do hPutStrLn stderr ("\n -> " ++ command); taskStart etc
taskStart (_ : etc) = taskStart etc
taskStart [] = return ()
otherTask :: [Style] -> IO a -> IO a
otherTask style task =
do
start <- getClockTime
putIndent style
startMessage style
taskStart style
result <- try task
hPutStr stderr "..."
finish <- getClockTime
let elapsed = diffClockTimes finish start
case result of
Left e -> do errorMessage style (show e)
error (show e)
Right a ->
do finishMessage style elapsed
return a
where
taskStart (_ : etc) = taskStart etc
taskStart [] = return ()
msg :: [Style] -> String -> IO ()
msg style text =
do
putIndent style
hPutStr stderr text
msgLn :: [Style] -> String -> IO ()
msgLn style text =
do
putIndent style
hPutStrLn stderr text
putIndent :: [Style] -> IO ()
putIndent style = hPutStr stderr (indent style)
startMessage :: [Style] -> IO ()
startMessage (Start message : etc) = do hPutStr stderr message; startMessage etc
startMessage (_ : etc) = startMessage etc
startMessage [] = return ()
progressOutput :: Output -> Handle -> IO String
progressOutput Dots handle =
do
hPutStr stderr "..."
doText 0 ""
where
doText count text =
do
eof <- hIsEOF handle
case eof of
False ->
do
line <- hGetLine handle
let count' = count + length line + 1
let text' = text ++ line ++ "\n"
let (n, m) = quotRem count' 1024
hPutStr stderr (replicate n '.')
doText m text'
True ->
do
return text
progressOutput Done handle =
do
hPutStr stderr "..."
doText ""
where
doText text =
do
eof <- hIsEOF handle
case eof of
False ->
do
line <- hGetLine handle
let text' = text ++ line ++ "\n"
doText text'
True ->
do
return text
progressOutput Indented handle =
do
hPutStrLn stderr ""
doText
where
doText =
do
eof <- hIsEOF handle
case eof of
True -> return ""
False ->
do
line <- hGetLine handle
hPutStrLn stdout (prefix ++ line)
hFlush stdout
doText
prefix = " > "
progressOutput Quiet handle =
do
doText ""
where
doText text =
do
eof <- hIsEOF handle
case eof of
False ->
do
line <- hGetLine handle
let text' = text ++ line ++ "\n"
doText text'
True -> return text
finishMessage :: [Style] -> TimeDiff -> IO ()
finishMessage (Elapsed True : etc) elapsed =
do
hPutStr stderr (" (Elapsed: " ++ fixedTimeDiffToString elapsed ++ ")")
finishMessage etc elapsed
finishMessage (Finish message : etc) elapsed = do hPutStr stderr message; finishMessage etc elapsed
finishMessage (_ : etc) elapsed = finishMessage etc elapsed
finishMessage [] _ = do hPutStrLn stderr ""; return ()
errorMessage :: [Style] -> String -> IO ()
errorMessage (Error message : _) text =
do
hPutStrLn stderr text
error message
errorMessage (_ : etc) text = errorMessage etc text
errorMessage [] text = errorMessage [Error "failed"] text
removeStyle :: Style -> [Style] -> [Style]
removeStyle (Start _) style = filter (not . isStart) style
removeStyle (Finish _) style = filter (not . isFinish) style
removeStyle (Error _) style = filter (not. isError) style
removeStyle (Output _) style = filter (not . isOutput) style
removeStyle (Echo _) style = filter (not . isEcho) style
removeStyle old style = filter (/= old) style
setStyles :: [Style] -> [Style] -> [Style]
setStyles [] style = style
setStyles (x:xs) style = setStyles xs (x : (removeStyle x style))
setStyle :: Style -> [Style] -> [Style]
setStyle new style = setStyles [new] style
addStyle :: Style -> [Style] -> [Style]
addStyle x@(Start _) style = case filter isStart style of [] -> x : style; _ -> style
addStyle x@(Finish _) style = case filter isFinish style of [] -> x : style; _ -> style
addStyle x@(Error _) style = case filter isError style of [] -> x : style; _ -> style
addStyle x@(Output _) style = case filter isOutput style of [] -> x : style; _ -> style
addStyle x@(Echo _) style = case filter isEcho style of [] -> x : style; _ -> style
addStyle x style = if elem x style then style else x : style
isStart (Start _) = True
isStart _ = False
isFinish (Finish _) = True
isFinish _ = False
isError (Error _) = True
isError _ = False
isOutput (Output _) = True
isOutput _ = False
isEcho (Echo _) = True
isEcho _ = False
output :: [Style] -> Maybe Output
output (Output x : _) = Just x
output (_ : xs) = output xs
output [] = Nothing
addStyles :: [Style] -> [Style] -> [Style]
addStyles styles style = foldr addStyle style styles
stripDist :: FilePath -> FilePath
stripDist path = maybe path (\ n -> "..." ++ drop (n + 7) path) (isSublistOf "/dists/" path)
verbosity :: [Style] -> Int
verbosity [] = 0
verbosity (Verbosity n : _) = n
verbosity (_ : etc) = verbosity etc
indent :: [Style] -> String
indent [] = ""
indent (Indent s : _) = s
indent (_ : etc) = indent etc
readStyle :: String -> Maybe Style
readStyle text =
case (mapSnd tail . break (== '=')) text of
("Start", message) -> Just $ Start message
("Finish", message) -> Just $ Finish message
("Error", message) -> Just $ Error message
("Output", "Indented") -> Just $ Output Indented
("Output", "Dots") -> Just $ Output Dots
("Output", "Done") -> Just $ Output Done
("Output", "Quiet") -> Just $ Output Quiet
("Echo", flag) -> Just $ Echo (readFlag flag)
("Elapsed", flag) -> Just $ Elapsed (readFlag flag)
("Verbosity", value) -> Just $ Verbosity (read value)
("Indent", prefix) -> Just $ Indent prefix
_ -> Nothing
where
readFlag "yes" = True
readFlag "no" = False
readFlag "true" = True
readFlag "false" = True
readFlag text = error ("Unrecognized bool: " ++ text)
fixedTimeDiffToString :: TimeDiff -> [Char]
fixedTimeDiffToString diff =
case timeDiffToString diff of
"" -> "0 sec"
s -> s
showElapsed :: String -> IO a -> IO a
showElapsed label f =
do
(result, time) <- elapsed f
ePut (label ++ fixedTimeDiffToString time)
return result
elapsed :: IO a -> IO (a, TimeDiff)
elapsed f =
do
start <- getClockTime
result <- f
finish <- getClockTime
return (result, diffClockTimes finish start)
isSublistOf :: Eq a => [a] -> [a] -> Maybe Int
isSublistOf sub lst =
maybe Nothing (\ s -> Just (length s length sub))
(find (isSuffixOf sub) (inits lst))
mapSnd :: (b -> c) -> (a, b) -> (a, c)
mapSnd f (a, b) = (a, f b)
ePut :: String -> IO ()
ePut s = hPutStrLn stderr s