Implement basic ctrl-c-handling
parent
dfad695899
commit
8ca85432be
|
|
@ -10,7 +10,11 @@ where
|
||||||
import Control.Concurrent ( threadDelay )
|
import Control.Concurrent ( threadDelay )
|
||||||
import qualified Control.Concurrent.Async as A
|
import qualified Control.Concurrent.Async as A
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Exception ( IOException
|
import Control.Exception ( AsyncException(UserInterrupt)
|
||||||
|
, IOException
|
||||||
|
, catch
|
||||||
|
, mask
|
||||||
|
, throwIO
|
||||||
, try
|
, try
|
||||||
)
|
)
|
||||||
import Control.Monad ( forM_
|
import Control.Monad ( forM_
|
||||||
|
|
@ -350,9 +354,9 @@ main = B.mainFromCmdParser $ do
|
||||||
B.addCmdImpl $ if null rest
|
B.addCmdImpl $ if null rest
|
||||||
then do
|
then do
|
||||||
print $ B.ppHelpShallow helpDesc
|
print $ B.ppHelpShallow helpDesc
|
||||||
else withConcurrentOutput $ do
|
else withConcurrentOutput $ mask $ \restore -> do
|
||||||
setLocaleEncoding utf8
|
restore $ setLocaleEncoding utf8
|
||||||
termWidthMay <- try Ansi.getTerminalSize <&> \case
|
termWidthMay <- restore $ try Ansi.getTerminalSize <&> \case
|
||||||
Left (_e :: IOException) -> Nothing
|
Left (_e :: IOException) -> Nothing
|
||||||
Right Nothing -> Nothing
|
Right Nothing -> Nothing
|
||||||
Right (Just (_, w)) -> Just w
|
Right (Just (_, w)) -> Just w
|
||||||
|
|
@ -366,7 +370,7 @@ main = B.mainFromCmdParser $ do
|
||||||
$ [ () | keepStderr || keepBoth ]
|
$ [ () | keepStderr || keepBoth ]
|
||||||
++ [ () | conflateStderr || conflateBoth ]
|
++ [ () | conflateStderr || conflateBoth ]
|
||||||
++ [ () | dropStderr || dropBoth ]
|
++ [ () | dropStderr || dropBoth ]
|
||||||
(lastLine, ec) <- displayConsoleRegions $ do
|
(lastLine, ecMay) <- displayConsoleRegions $ do
|
||||||
initialState <- do
|
initialState <- do
|
||||||
startTime <- getTime RealtimeCoarse
|
startTime <- getTime RealtimeCoarse
|
||||||
line0 <- openConsoleRegion Linear
|
line0 <- openConsoleRegion Linear
|
||||||
|
|
@ -407,7 +411,17 @@ main = B.mainFromCmdParser $ do
|
||||||
}
|
}
|
||||||
stateVar :: MVar State <- newMVar initialState
|
stateVar :: MVar State <- newMVar initialState
|
||||||
|
|
||||||
let withCreateProcess f =
|
let outHandler out = forever $ do
|
||||||
|
x <- hGetLine out
|
||||||
|
modifyMVar_ stateVar (processLine (StdOut, x))
|
||||||
|
let errHandler err = forever $ do
|
||||||
|
x <- hGetLine err
|
||||||
|
modifyMVar_ stateVar (processLine (StdErr, x))
|
||||||
|
let tickHandler = forever $ do
|
||||||
|
threadDelay 333333
|
||||||
|
modifyMVar_ stateVar $ execStateT $ updateStateLine False
|
||||||
|
|
||||||
|
let mainBlock =
|
||||||
P.withCreateProcess
|
P.withCreateProcess
|
||||||
((P.shell rest) { P.std_in = P.CreatePipe
|
((P.shell rest) { P.std_in = P.CreatePipe
|
||||||
, P.std_out = P.CreatePipe
|
, P.std_out = P.CreatePipe
|
||||||
|
|
@ -415,33 +429,23 @@ main = B.mainFromCmdParser $ do
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
$ \(Just inp) (Just out) (Just err) hdl -> do
|
$ \(Just inp) (Just out) (Just err) hdl -> do
|
||||||
f inp out err hdl
|
A.withAsync (outHandler out) $ \outAsync ->
|
||||||
|
A.withAsync (errHandler err) $ \errAsync ->
|
||||||
withCreateProcess $ \inp out err hdl -> do
|
|
||||||
hClose inp
|
|
||||||
let outHandler = forever $ do
|
|
||||||
x <- hGetLine out
|
|
||||||
modifyMVar_ stateVar (processLine (StdOut, x))
|
|
||||||
let errHandler = forever $ do
|
|
||||||
x <- hGetLine err
|
|
||||||
modifyMVar_ stateVar (processLine (StdErr, x))
|
|
||||||
let tickHandler = forever $ do
|
|
||||||
threadDelay 333333
|
|
||||||
modifyMVar_ stateVar $ execStateT $ updateStateLine False
|
|
||||||
A.withAsync outHandler $ \outAsync ->
|
|
||||||
A.withAsync errHandler $ \errAsync ->
|
|
||||||
A.withAsync tickHandler $ \_tickAsync -> do
|
A.withAsync tickHandler $ \_tickAsync -> do
|
||||||
|
hClose inp
|
||||||
ec <- P.waitForProcess hdl
|
ec <- P.waitForProcess hdl
|
||||||
_a <- A.waitCatch outAsync
|
_a <- A.waitCatch outAsync
|
||||||
_b <- A.waitCatch errAsync
|
_b <- A.waitCatch errAsync
|
||||||
|
pure (Just ec)
|
||||||
|
ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing)
|
||||||
modifyMVar_ stateVar $ execStateT $ do
|
modifyMVar_ stateVar $ execStateT $ do
|
||||||
finalLines <- gets s_lines
|
finalLines <- gets s_lines
|
||||||
countOut <- gets s_countOut
|
countOut <- gets s_countOut
|
||||||
countErr <- gets s_countErr
|
countErr <- gets s_countErr
|
||||||
if countOut == 0 && countErr == 1
|
if countOut == 0 && countErr == 1
|
||||||
then do
|
then do
|
||||||
modify $ \s ->
|
modify
|
||||||
s { s_config = (s_config s) { c_keepStderr = Keep } }
|
$ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } }
|
||||||
reverse finalLines `forM_` dispatchLine
|
reverse finalLines `forM_` dispatchLine
|
||||||
else do
|
else do
|
||||||
-- we leave the lines in final state, but process them
|
-- we leave the lines in final state, but process them
|
||||||
|
|
@ -454,10 +458,14 @@ main = B.mainFromCmdParser $ do
|
||||||
finalState <- takeMVar stateVar
|
finalState <- takeMVar stateVar
|
||||||
line <- evalStateT (stateLine False False) finalState
|
line <- evalStateT (stateLine False False) finalState
|
||||||
s_regions finalState `forM_` \r -> closeConsoleRegion r
|
s_regions finalState `forM_` \r -> closeConsoleRegion r
|
||||||
-- outputConcurrent (show a ++ "\n")
|
let lastLine = case ecMay of
|
||||||
-- outputConcurrent (show b ++ "\n")
|
Nothing -> fGrey ++ line ++ ", UserInterrupt\n"
|
||||||
pure (fGrey ++ line ++ ", ec=" ++ showEC ec ++ "\n", ec)
|
Just ec -> fGrey ++ line ++ ", ec=" ++ showEC ec ++ "\n"
|
||||||
|
pure (lastLine, ecMay)
|
||||||
|
|
||||||
flushConcurrentOutput
|
flushConcurrentOutput
|
||||||
outputConcurrent lastLine
|
outputConcurrent lastLine
|
||||||
exitWith ec
|
case ecMay of
|
||||||
|
Nothing -> throwIO UserInterrupt -- essentially re-throw
|
||||||
|
Just ec -> exitWith ec
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue