hexagoxel
/
hxtools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Support forwarding stdin (non-echoed)

master
Lennart Spitzner 2022-02-08 15:11:36 +00:00
parent 1cb4dd2cb8
commit 913916561c
1 changed files with 47 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
src-hxbrief/Main.hs
View File

@ -12,6 +12,7 @@ import qualified Control.Concurrent.Async as A
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Exception ( AsyncException(UserInterrupt) import Control.Exception ( AsyncException(UserInterrupt)
, IOException , IOException
, bracket
, catch , catch
, mask , mask
, throwIO , throwIO
@ -42,9 +43,7 @@ import Data.List ( isInfixOf
import Data.Maybe ( listToMaybe import Data.Maybe ( listToMaybe
, mapMaybe , mapMaybe
) )
import GHC.IO.Encoding ( setLocaleEncoding import qualified GHC.IO.Encoding
, utf8
)
import Lens.Micro ( (<&>) ) import Lens.Micro ( (<&>) )
import System.Clock ( Clock(RealtimeCoarse) import System.Clock ( Clock(RealtimeCoarse)
, TimeSpec , TimeSpec
@ -69,10 +68,8 @@ import qualified System.Environment
import System.Exit ( exitSuccess import System.Exit ( exitSuccess
, exitWith , exitWith
) )
import System.IO ( Handle import System.IO ( Handle )
, hClose import qualified System.IO
, hGetLine
)
import qualified System.Process as P import qualified System.Process as P
import Text.Printf ( printf ) import Text.Printf ( printf )
import qualified UI.Butcher.Monadic as B import qualified UI.Butcher.Monadic as B
@ -438,12 +435,28 @@ main = B.mainFromCmdParser $ do
P.callCommand rest P.callCommand rest
exitSuccess exitSuccess
Nothing -> pure () Nothing -> pure ()
withConcurrentOutput $ mask $ \restore -> do let mainBracket = bracket
restore $ setLocaleEncoding utf8 (do
termWidthMay <- restore $ try Ansi.getTerminalSize <&> \case System.IO.hSetEcho System.IO.stdin False
Left (_e :: IOException) -> Nothing System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
Right Nothing -> Nothing GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
Right (Just (_, w)) -> Just w pure ()
)
(\() -> do
System.IO.hSetEcho System.IO.stdin True
)
withConcurrentOutput $ mainBracket $ \() -> mask $ \restore -> do
-- restore $ GHC.IO.Encoding.setFileSystemEncoding GHC.IO.Encoding.utf8
-- restore $ System.IO.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8
-- restore $ System.IO.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8
termWidthMay <- restore $ do
support <- Ansi.hSupportsANSI System.IO.stdin
if support
then try Ansi.getTerminalSize <&> \case
Left (_e :: IOException) -> Nothing
Right Nothing -> Nothing
Right (Just (_, w)) -> Just w
else pure Nothing
let stdoutCheckCount = let stdoutCheckCount =
length length
$ [ () | keepStdout || keepBoth ] $ [ () | keepStdout || keepBoth ]
@ -496,11 +509,21 @@ main = B.mainFromCmdParser $ do
} }
stateVar :: MVar State <- newMVar initialState stateVar :: MVar State <- newMVar initialState
let inHandler inp =
let go = do
x <- try getLine
case x of
Left (_ :: IOException) -> System.IO.hClose inp
Right line -> do
System.IO.hPutStrLn inp line
System.IO.hFlush inp
go
in go
let outHandler out = forever $ do let outHandler out = forever $ do
x <- hGetLine out x <- System.IO.hGetLine out
modifyMVar_ stateVar (processLine (StdOut, x)) modifyMVar_ stateVar (processLine (StdOut, x))
let errHandler err = forever $ do let errHandler err = forever $ do
x <- hGetLine err x <- System.IO.hGetLine err
modifyMVar_ stateVar (processLine (StdErr, x)) modifyMVar_ stateVar (processLine (StdErr, x))
let tickHandler = forever $ do let tickHandler = forever $ do
threadDelay 333333 threadDelay 333333
@ -515,14 +538,15 @@ main = B.mainFromCmdParser $ do
} }
) )
$ \(Just inp) (Just out) (Just err) hdl -> do $ \(Just inp) (Just out) (Just err) hdl -> do
A.withAsync (outHandler out) $ \outAsync -> A.withAsync (inHandler inp) $ \inAsync ->
A.withAsync (errHandler err) $ \errAsync -> A.withAsync (outHandler out) $ \outAsync ->
A.withAsync tickHandler $ \_tickAsync -> do A.withAsync (errHandler err) $ \errAsync ->
hClose inp A.withAsync tickHandler $ \_tickAsync -> do
ec <- P.waitForProcess hdl ec <- P.waitForProcess hdl
_a <- A.waitCatch outAsync A.cancel inAsync
_b <- A.waitCatch errAsync _a <- A.waitCatch outAsync
pure (Just ec) _b <- A.waitCatch errAsync
pure (Just ec)
ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing) ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing)
modifyMVar_ stateVar $ execStateT $ do modifyMVar_ stateVar $ execStateT $ do
finalLines <- gets s_lines finalLines <- gets s_lines