module Z.IO.StdStream
(
StdStream
, isStdStreamTTY
, getStdStreamFD
, setStdinTTYMode
, getStdoutWinSize
, stdin, stdout, stderr
, stdinBuf, stdoutBuf, stderrBuf
, readLineStd
, printStd
, printLineStd
, putStd
, putLineStd
, withMVar
, TTYMode
, pattern TTY_MODE_NORMAL
, pattern TTY_MODE_RAW
) where
import Control.Monad
import Control.Concurrent.MVar
import Foreign.Ptr
import System.IO.Unsafe
import Z.Data.Builder as B
import Z.Data.Vector as V
import Z.Data.Text.ShowT (ShowT, toUTF8Builder)
import Z.IO.UV.FFI
import Z.IO.UV.Manager
import Z.IO.UV.Errno
import Z.IO.Exception
import Z.IO.Buffered
import Z.Foreign
data StdStream
= StdTTY {-# UNPACK #-}!(Ptr UVHandle) {-# UNPACK #-}!UVSlot UVManager
| StdFile {-# UNPACK #-}!FD
isStdStreamTTY :: StdStream -> Bool
isStdStreamTTY :: StdStream -> Bool
isStdStreamTTY (StdTTY Ptr UVHandle
_ UVSlot
_ UVManager
_) = Bool
True
isStdStreamTTY StdStream
_ = Bool
False
getStdStreamFD :: StdStream -> IO FD
getStdStreamFD :: StdStream -> IO FD
getStdStreamFD (StdTTY Ptr UVHandle
hdl UVSlot
_ UVManager
_) = IO FD -> IO FD
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (Ptr UVHandle -> IO FD
hs_uv_fileno Ptr UVHandle
hdl)
getStdStreamFD (StdFile FD
fd) = FD -> IO FD
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd
instance Input StdStream where
{-# INLINE readInput #-}
readInput :: StdStream -> Ptr Word8 -> UVSlot -> IO UVSlot
readInput (StdTTY Ptr UVHandle
hdl UVSlot
slot UVManager
uvm) Ptr Word8
buf UVSlot
len = IO UVSlot -> IO UVSlot
forall a. IO a -> IO a
mask_ (IO UVSlot -> IO UVSlot) -> IO UVSlot -> IO UVSlot
forall a b. (a -> b) -> a -> b
$ do
UVManager -> UVSlot -> Ptr Word8 -> UVSlot -> IO ()
pokeBufferTable UVManager
uvm UVSlot
slot Ptr Word8
buf UVSlot
len
MVar UVSlot
m <- UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
slot
Maybe UVSlot
_ <- MVar UVSlot -> IO (Maybe UVSlot)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ UVManager -> IO FD -> IO FD
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
hs_uv_read_start Ptr UVHandle
hdl)
UVSlot
r <- MVar UVSlot -> IO UVSlot
forall a. MVar a -> IO a
takeMVar MVar UVSlot
m IO UVSlot -> IO () -> IO UVSlot
forall a b. IO a -> IO b -> IO a
`onException` (do
FD
_ <- UVManager -> IO FD -> IO FD
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
uv_read_stop Ptr UVHandle
hdl)
IO (Maybe UVSlot) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar UVSlot -> IO (Maybe UVSlot)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m))
if | UVSlot
r UVSlot -> UVSlot -> Bool
forall a. Ord a => a -> a -> Bool
> UVSlot
0 -> UVSlot -> IO UVSlot
forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
r
| UVSlot
r UVSlot -> UVSlot -> Bool
forall a. Eq a => a -> a -> Bool
== FD -> UVSlot
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
UV_EOF -> UVSlot -> IO UVSlot
forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
0
| UVSlot
r UVSlot -> UVSlot -> Bool
forall a. Ord a => a -> a -> Bool
< UVSlot
0 -> IO UVSlot -> IO UVSlot
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (UVSlot -> IO UVSlot
forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
r)
| Bool
otherwise -> FD -> IOEInfo -> IO UVSlot
forall a. FD -> IOEInfo -> IO a
throwUVError FD
UV_UNKNOWN IOEInfo :: Text -> Text -> CallStack -> IOEInfo
IOEInfo{
ioeName :: Text
ioeName = Text
"StdStream read error"
, ioeDescription :: Text
ioeDescription = Text
"StdStream read should never return 0 before EOF"
, ioeCallStack :: CallStack
ioeCallStack = CallStack
HasCallStack => CallStack
callStack
}
readInput (StdFile FD
fd) Ptr Word8
buf UVSlot
len =
IO UVSlot -> IO UVSlot
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (IO UVSlot -> IO UVSlot) -> IO UVSlot -> IO UVSlot
forall a b. (a -> b) -> a -> b
$ FD -> Ptr Word8 -> UVSlot -> Int64 -> IO UVSlot
hs_uv_fs_read FD
fd Ptr Word8
buf UVSlot
len (-Int64
1)
instance Output StdStream where
{-# INLINE writeOutput #-}
writeOutput :: StdStream -> Ptr Word8 -> UVSlot -> IO ()
writeOutput (StdTTY Ptr UVHandle
hdl UVSlot
_ UVManager
uvm) Ptr Word8
buf UVSlot
len = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MVar UVSlot
m <- UVManager -> IO (MVar UVSlot) -> IO (MVar UVSlot)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO (MVar UVSlot) -> IO (MVar UVSlot))
-> IO (MVar UVSlot) -> IO (MVar UVSlot)
forall a b. (a -> b) -> a -> b
$ do
UVSlot
reqSlot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> Ptr Word8 -> UVSlot -> IO UVSlotUnsafe
hs_uv_write Ptr UVHandle
hdl Ptr Word8
buf UVSlot
len)
MVar UVSlot
m <- UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
reqSlot
Maybe UVSlot
_ <- MVar UVSlot -> IO (Maybe UVSlot)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m
MVar UVSlot -> IO (MVar UVSlot)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar UVSlot
m
IO UVSlot -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO UVSlot -> IO UVSlot
forall a. IO a -> IO a
uninterruptibleMask_ (IO UVSlot -> IO UVSlot) -> IO UVSlot -> IO UVSlot
forall a b. (a -> b) -> a -> b
$ MVar UVSlot -> IO UVSlot
forall a. MVar a -> IO a
takeMVar MVar UVSlot
m)
writeOutput (StdFile FD
fd) Ptr Word8
buf UVSlot
len = Ptr Word8 -> UVSlot -> IO ()
go Ptr Word8
buf UVSlot
len
where
go :: Ptr Word8 -> UVSlot -> IO ()
go !Ptr Word8
b !UVSlot
bufSiz = do
UVSlot
written <- IO UVSlot -> IO UVSlot
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus
(FD -> Ptr Word8 -> UVSlot -> Int64 -> IO UVSlot
hs_uv_fs_write FD
fd Ptr Word8
b UVSlot
bufSiz (-Int64
1))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UVSlot
written UVSlot -> UVSlot -> Bool
forall a. Ord a => a -> a -> Bool
< UVSlot
bufSiz)
(Ptr Word8 -> UVSlot -> IO ()
go (Ptr Word8
b Ptr Word8 -> UVSlot -> Ptr Word8
forall a b. Ptr a -> UVSlot -> Ptr b
`plusPtr` UVSlot
written) (UVSlot
bufSizUVSlot -> UVSlot -> UVSlot
forall a. Num a => a -> a -> a
-UVSlot
written))
stdin :: StdStream
{-# NOINLINE stdin #-}
stdin :: StdStream
stdin = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
0)
stdout :: StdStream
{-# NOINLINE stdout #-}
stdout :: StdStream
stdout = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
1)
stderr :: StdStream
{-# NOINLINE stderr #-}
stderr :: StdStream
stderr = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
2)
stdinBuf :: MVar BufferedInput
{-# NOINLINE stdinBuf #-}
stdinBuf :: MVar BufferedInput
stdinBuf = IO (MVar BufferedInput) -> MVar BufferedInput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedInput
forall i. Input i => i -> IO BufferedInput
newBufferedInput StdStream
stdin IO BufferedInput
-> (BufferedInput -> IO (MVar BufferedInput))
-> IO (MVar BufferedInput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedInput -> IO (MVar BufferedInput)
forall a. a -> IO (MVar a)
newMVar)
stdoutBuf :: MVar BufferedOutput
{-# NOINLINE stdoutBuf #-}
stdoutBuf :: MVar BufferedOutput
stdoutBuf = IO (MVar BufferedOutput) -> MVar BufferedOutput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedOutput
forall o. Output o => o -> IO BufferedOutput
newBufferedOutput StdStream
stdout IO BufferedOutput
-> (BufferedOutput -> IO (MVar BufferedOutput))
-> IO (MVar BufferedOutput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedOutput -> IO (MVar BufferedOutput)
forall a. a -> IO (MVar a)
newMVar)
stderrBuf :: MVar BufferedOutput
{-# NOINLINE stderrBuf #-}
stderrBuf :: MVar BufferedOutput
stderrBuf = IO (MVar BufferedOutput) -> MVar BufferedOutput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedOutput
forall o. Output o => o -> IO BufferedOutput
newBufferedOutput StdStream
stderr IO BufferedOutput
-> (BufferedOutput -> IO (MVar BufferedOutput))
-> IO (MVar BufferedOutput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedOutput -> IO (MVar BufferedOutput)
forall a. a -> IO (MVar a)
newMVar)
makeStdStream :: HasCallStack => FD -> IO StdStream
makeStdStream :: FD -> IO StdStream
makeStdStream FD
fd = do
FD
typ <- FD -> IO FD
uv_guess_handle FD
fd
if FD
typ FD -> FD -> Bool
forall a. Eq a => a -> a -> Bool
== FD
UV_TTY
then IO StdStream -> IO StdStream
forall a. IO a -> IO a
mask_ (IO StdStream -> IO StdStream) -> IO StdStream -> IO StdStream
forall a b. (a -> b) -> a -> b
$ do
UVManager
uvm <- IO UVManager
getUVManager
UVManager -> (Ptr UVLoop -> IO StdStream) -> IO StdStream
forall a. HasCallStack => UVManager -> (Ptr UVLoop -> IO a) -> IO a
withUVManager UVManager
uvm ((Ptr UVLoop -> IO StdStream) -> IO StdStream)
-> (Ptr UVLoop -> IO StdStream) -> IO StdStream
forall a b. (a -> b) -> a -> b
$ \ Ptr UVLoop
loop -> do
Ptr UVHandle
hdl <- Ptr UVLoop -> IO (Ptr UVHandle)
hs_uv_handle_alloc Ptr UVLoop
loop
UVSlot
slot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> IO UVSlotUnsafe
peekUVHandleData Ptr UVHandle
hdl)
Maybe UVSlot
_ <- MVar UVSlot -> IO (Maybe UVSlot)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MVar UVSlot -> IO (Maybe UVSlot))
-> IO (MVar UVSlot) -> IO (Maybe UVSlot)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
slot
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> FD -> IO FD
uv_tty_init Ptr UVLoop
loop Ptr UVHandle
hdl (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd))
StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr UVHandle -> UVSlot -> UVManager -> StdStream
StdTTY Ptr UVHandle
hdl UVSlot
slot UVManager
uvm)
else StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (FD -> StdStream
StdFile FD
fd)
setStdinTTYMode :: TTYMode -> IO ()
setStdinTTYMode :: FD -> IO ()
setStdinTTYMode FD
mode = case StdStream
stdin of
StdTTY Ptr UVHandle
hdl UVSlot
_ UVManager
uvm ->
UVManager -> IO () -> IO ()
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO () -> IO ()) -> (IO FD -> IO ()) -> IO FD -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> FD -> IO FD
uv_tty_set_mode Ptr UVHandle
hdl FD
mode
StdStream
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getStdoutWinSize :: HasCallStack => IO (CInt, CInt)
getStdoutWinSize :: IO (FD, FD)
getStdoutWinSize = case StdStream
stdout of
StdTTY Ptr UVHandle
hdl UVSlot
_ UVManager
uvm ->
UVManager -> IO (FD, FD) -> IO (FD, FD)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO (FD, FD) -> IO (FD, FD)) -> IO (FD, FD) -> IO (FD, FD)
forall a b. (a -> b) -> a -> b
$ do
(FD
w, (FD
h, ())) <- (MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ()))
forall a b. Prim a => (MBA# FD -> IO b) -> IO (a, b)
allocPrimUnsafe ((MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ())))
-> (MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ()))
forall a b. (a -> b) -> a -> b
$ \ MBA# FD
w ->
(MBA# FD -> IO ()) -> IO (FD, ())
forall a b. Prim a => (MBA# FD -> IO b) -> IO (a, b)
allocPrimUnsafe ((MBA# FD -> IO ()) -> IO (FD, ()))
-> (MBA# FD -> IO ()) -> IO (FD, ())
forall a b. (a -> b) -> a -> b
$ \ MBA# FD
h -> IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> MBA# FD -> MBA# FD -> IO FD
uv_tty_get_winsize Ptr UVHandle
hdl MBA# FD
w MBA# FD
h
(FD, FD) -> IO (FD, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
w, FD
h)
StdStream
_ -> (FD, FD) -> IO (FD, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
1, -FD
1)
printStd :: (HasCallStack, ShowT a) => a -> IO ()
printStd :: a -> IO ()
printStd a
s = Builder () -> IO ()
forall a. HasCallStack => Builder a -> IO ()
putStd (a -> Builder ()
forall a. ShowT a => a -> Builder ()
toUTF8Builder a
s)
putStd :: HasCallStack => Builder a -> IO ()
putStd :: Builder a -> IO ()
putStd Builder a
b = MVar BufferedOutput -> (BufferedOutput -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedOutput
stdoutBuf ((BufferedOutput -> IO ()) -> IO ())
-> (BufferedOutput -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BufferedOutput
o -> do
BufferedOutput -> Builder a -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
o Builder a
b
HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
o
printLineStd :: (HasCallStack, ShowT a) => a -> IO ()
printLineStd :: a -> IO ()
printLineStd a
s = Builder () -> IO ()
forall a. HasCallStack => Builder a -> IO ()
putLineStd (a -> Builder ()
forall a. ShowT a => a -> Builder ()
toUTF8Builder a
s)
putLineStd :: HasCallStack => Builder a -> IO ()
putLineStd :: Builder a -> IO ()
putLineStd Builder a
b = MVar BufferedOutput -> (BufferedOutput -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedOutput
stdoutBuf ((BufferedOutput -> IO ()) -> IO ())
-> (BufferedOutput -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BufferedOutput
o -> do
BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
o (Builder a
b Builder a -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Builder ()
B.char8 Char
'\n')
HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
o
readLineStd :: HasCallStack => IO V.Bytes
readLineStd :: IO Bytes
readLineStd = MVar BufferedInput -> (BufferedInput -> IO Bytes) -> IO Bytes
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedInput
stdinBuf ((BufferedInput -> IO Bytes) -> IO Bytes)
-> (BufferedInput -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \ BufferedInput
s -> do
Maybe Bytes
line <- HasCallStack => BufferedInput -> IO (Maybe Bytes)
BufferedInput -> IO (Maybe Bytes)
readLine BufferedInput
s
case Maybe Bytes
line of Just Bytes
line' -> Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
line'
Maybe Bytes
Nothing -> ResourceVanished -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (IOEInfo -> ResourceVanished
ResourceVanished
(Text -> Text -> CallStack -> IOEInfo
IOEInfo Text
"ECLOSED" Text
"stdin is closed" CallStack
HasCallStack => CallStack
callStack))