{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
# if defined(WINDOWS)
{-# LANGUAGE Trustworthy #-}
# else
# if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
# endif
#endif
module System.IO.Echo.Internal (
withoutInputEcho, bracketInputEcho
, getInputEchoState, setInputEchoState
, echoOff, echoOn
, getInputEcho, setInputEcho
, EchoState(..), STTYSettings
, getInputEchoSTTY, setInputEchoSTTY, sttyRaw
, minTTY
) where
import Control.Exception (bracket, throw)
import Control.Monad (void)
import Data.List (isInfixOf)
import System.Exit (ExitCode(..))
import System.IO (hGetContents, hGetEcho, hSetEcho, stdin)
import System.Process (StdStream(..), createProcess, shell,
std_in, std_out, waitForProcess)
#if defined(WINDOWS)
import Graphics.Win32.Misc (getStdHandle, sTD_INPUT_HANDLE)
import System.Console.MinTTY (isMinTTYHandle)
import System.IO.Unsafe (unsafePerformIO)
#endif
getInputEcho :: IO Bool
getInputEcho :: IO Bool
getInputEcho = if Bool
minTTY
then do STTYSettings
settings <- STTYSettings -> IO STTYSettings
sttyRaw STTYSettings
"-a"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (STTYSettings
"-echo " forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` STTYSettings
settings)
else Handle -> IO Bool
hGetEcho Handle
stdin
getInputEchoState :: IO EchoState
getInputEchoState :: IO EchoState
getInputEchoState = if Bool
minTTY
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap STTYSettings -> EchoState
MinTTY IO STTYSettings
getInputEchoSTTY
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> EchoState
DefaultTTY forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hGetEcho Handle
stdin
getInputEchoSTTY :: IO STTYSettings
getInputEchoSTTY :: IO STTYSettings
getInputEchoSTTY = STTYSettings -> IO STTYSettings
sttyRaw STTYSettings
"-g"
setInputEcho :: Bool -> IO ()
setInputEcho :: Bool -> IO ()
setInputEcho Bool
echo = if Bool
minTTY
then STTYSettings -> IO ()
setInputEchoSTTY forall a b. (a -> b) -> a -> b
$ [Char
'-' | Bool -> Bool
not Bool
echo] forall a. [a] -> [a] -> [a]
++ STTYSettings
"echo"
else Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
echo
setInputEchoState :: EchoState -> IO ()
setInputEchoState :: EchoState -> IO ()
setInputEchoState (MinTTY STTYSettings
settings) = STTYSettings -> IO ()
setInputEchoSTTY STTYSettings
settings
setInputEchoState (DefaultTTY Bool
echo) = Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
echo
setInputEchoSTTY :: STTYSettings -> IO ()
setInputEchoSTTY :: STTYSettings -> IO ()
setInputEchoSTTY = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. STTYSettings -> IO STTYSettings
sttyRaw
bracketInputEcho :: IO a -> IO a
bracketInputEcho :: forall a. IO a -> IO a
bracketInputEcho IO a
action = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO EchoState
getInputEchoState EchoState -> IO ()
setInputEchoState (forall a b. a -> b -> a
const IO a
action)
withoutInputEcho :: IO a -> IO a
withoutInputEcho :: forall a. IO a -> IO a
withoutInputEcho IO a
action = forall a. IO a -> IO a
bracketInputEcho (EchoState -> IO ()
setInputEchoState EchoState
echoOff forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action)
sttyRaw :: String -> IO STTYSettings
sttyRaw :: STTYSettings -> IO STTYSettings
sttyRaw STTYSettings
arg = do
let stty :: CreateProcess
stty = (STTYSettings -> CreateProcess
shell forall a b. (a -> b) -> a -> b
$ STTYSettings
"stty " forall a. [a] -> [a] -> [a]
++ STTYSettings
arg) {
std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
stdin
, std_out :: StdStream
std_out = StdStream
CreatePipe
}
(Maybe Handle
_, Maybe Handle
mbStdout, Maybe Handle
_, ProcessHandle
rStty) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
stty
ExitCode
exStty <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
rStty
case ExitCode
exStty of
e :: ExitCode
e@ExitFailure{} -> forall a e. Exception e => e -> a
throw ExitCode
e
ExitCode
ExitSuccess -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return STTYSettings
"") Handle -> IO STTYSettings
hGetContents Maybe Handle
mbStdout
data EchoState
= MinTTY STTYSettings
| DefaultTTY Bool
deriving (EchoState -> EchoState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EchoState -> EchoState -> Bool
$c/= :: EchoState -> EchoState -> Bool
== :: EchoState -> EchoState -> Bool
$c== :: EchoState -> EchoState -> Bool
Eq, Eq EchoState
EchoState -> EchoState -> Bool
EchoState -> EchoState -> Ordering
EchoState -> EchoState -> EchoState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EchoState -> EchoState -> EchoState
$cmin :: EchoState -> EchoState -> EchoState
max :: EchoState -> EchoState -> EchoState
$cmax :: EchoState -> EchoState -> EchoState
>= :: EchoState -> EchoState -> Bool
$c>= :: EchoState -> EchoState -> Bool
> :: EchoState -> EchoState -> Bool
$c> :: EchoState -> EchoState -> Bool
<= :: EchoState -> EchoState -> Bool
$c<= :: EchoState -> EchoState -> Bool
< :: EchoState -> EchoState -> Bool
$c< :: EchoState -> EchoState -> Bool
compare :: EchoState -> EchoState -> Ordering
$ccompare :: EchoState -> EchoState -> Ordering
Ord, Int -> EchoState -> ShowS
[EchoState] -> ShowS
EchoState -> STTYSettings
forall a.
(Int -> a -> ShowS)
-> (a -> STTYSettings) -> ([a] -> ShowS) -> Show a
showList :: [EchoState] -> ShowS
$cshowList :: [EchoState] -> ShowS
show :: EchoState -> STTYSettings
$cshow :: EchoState -> STTYSettings
showsPrec :: Int -> EchoState -> ShowS
$cshowsPrec :: Int -> EchoState -> ShowS
Show)
echoOff :: EchoState
echoOff :: EchoState
echoOff = if Bool
minTTY then STTYSettings -> EchoState
MinTTY STTYSettings
"-echo" else Bool -> EchoState
DefaultTTY Bool
False
echoOn :: EchoState
echoOn :: EchoState
echoOn = if Bool
minTTY then STTYSettings -> EchoState
MinTTY STTYSettings
"echo" else Bool -> EchoState
DefaultTTY Bool
True
type STTYSettings = String
minTTY :: Bool
#if defined(WINDOWS)
minTTY = unsafePerformIO $ do
h <- getStdHandle sTD_INPUT_HANDLE
isMinTTYHandle h
{-# NOINLINE minTTY #-}
#else
minTTY :: Bool
minTTY = Bool
False
#endif