module System.Posix.Terminal.Common (
TerminalAttributes,
getTerminalAttributes,
TerminalState(..),
setTerminalAttributes,
CTermios,
TerminalMode(..),
withoutMode,
withMode,
terminalMode,
bitsPerByte,
withBits,
ControlCharacter(..),
controlChar,
withCC,
withoutCC,
inputTime,
withTime,
minInput,
withMinInput,
BaudRate(..),
inputSpeed,
withInputSpeed,
outputSpeed,
withOutputSpeed,
sendBreak,
drainOutput,
QueueSelector(..),
discardData,
FlowAction(..),
controlFlow,
getTerminalProcessGroupID,
setTerminalProcessGroupID,
queryTerminal,
) where
import Data.Bits
import Data.Char
import Foreign.C.Error ( errnoToIOError, throwErrnoIfMinus1,
throwErrnoIfMinus1_, throwErrnoIfNull )
import Foreign.C.String ( CString, peekCString, withCString )
import Foreign.C.Types
import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Utils ( copyBytes )
import Foreign.Ptr ( Ptr, nullPtr, plusPtr )
import Foreign.Storable ( Storable(..) )
import System.IO.Error ( ioError )
import System.IO.Unsafe ( unsafePerformIO )
import System.Posix.IO ( OpenFileFlags(..), OpenMode(..), defaultFileFlags,
openFd )
import System.Posix.Types
type CTermios = ()
newtype TerminalAttributes = TerminalAttributes (ForeignPtr CTermios)
makeTerminalAttributes :: ForeignPtr CTermios -> TerminalAttributes
makeTerminalAttributes = TerminalAttributes
withTerminalAttributes :: TerminalAttributes -> (Ptr CTermios -> IO a) -> IO a
withTerminalAttributes (TerminalAttributes termios) = withForeignPtr termios
data TerminalMode
= InterruptOnBreak
| MapCRtoLF
| IgnoreBreak
| IgnoreCR
| IgnoreParityErrors
| MapLFtoCR
| CheckParity
| StripHighBit
| StartStopInput
| StartStopOutput
| MarkParityErrors
| ProcessOutput
| LocalMode
| ReadEnable
| TwoStopBits
| HangupOnClose
| EnableParity
| OddParity
| EnableEcho
| EchoErase
| EchoKill
| EchoLF
| ProcessInput
| ExtendedFunctions
| KeyboardInterrupts
| NoFlushOnInterrupt
| BackgroundWriteInterrupt
withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
withoutMode termios InterruptOnBreak = clearInputFlag (2) termios
withoutMode termios MapCRtoLF = clearInputFlag (256) termios
withoutMode termios IgnoreBreak = clearInputFlag (1) termios
withoutMode termios IgnoreCR = clearInputFlag (128) termios
withoutMode termios IgnoreParityErrors = clearInputFlag (4) termios
withoutMode termios MapLFtoCR = clearInputFlag (64) termios
withoutMode termios CheckParity = clearInputFlag (16) termios
withoutMode termios StripHighBit = clearInputFlag (32) termios
withoutMode termios StartStopInput = clearInputFlag (4096) termios
withoutMode termios StartStopOutput = clearInputFlag (1024) termios
withoutMode termios MarkParityErrors = clearInputFlag (8) termios
withoutMode termios ProcessOutput = clearOutputFlag (1) termios
withoutMode termios LocalMode = clearControlFlag (2048) termios
withoutMode termios ReadEnable = clearControlFlag (128) termios
withoutMode termios TwoStopBits = clearControlFlag (64) termios
withoutMode termios HangupOnClose = clearControlFlag (1024) termios
withoutMode termios EnableParity = clearControlFlag (256) termios
withoutMode termios OddParity = clearControlFlag (512) termios
withoutMode termios EnableEcho = clearLocalFlag (8) termios
withoutMode termios EchoErase = clearLocalFlag (16) termios
withoutMode termios EchoKill = clearLocalFlag (32) termios
withoutMode termios EchoLF = clearLocalFlag (64) termios
withoutMode termios ProcessInput = clearLocalFlag (2) termios
withoutMode termios ExtendedFunctions = clearLocalFlag (32768) termios
withoutMode termios KeyboardInterrupts = clearLocalFlag (1) termios
withoutMode termios NoFlushOnInterrupt = setLocalFlag (128) termios
withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (256) termios
withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
withMode termios InterruptOnBreak = setInputFlag (2) termios
withMode termios MapCRtoLF = setInputFlag (256) termios
withMode termios IgnoreBreak = setInputFlag (1) termios
withMode termios IgnoreCR = setInputFlag (128) termios
withMode termios IgnoreParityErrors = setInputFlag (4) termios
withMode termios MapLFtoCR = setInputFlag (64) termios
withMode termios CheckParity = setInputFlag (16) termios
withMode termios StripHighBit = setInputFlag (32) termios
withMode termios StartStopInput = setInputFlag (4096) termios
withMode termios StartStopOutput = setInputFlag (1024) termios
withMode termios MarkParityErrors = setInputFlag (8) termios
withMode termios ProcessOutput = setOutputFlag (1) termios
withMode termios LocalMode = setControlFlag (2048) termios
withMode termios ReadEnable = setControlFlag (128) termios
withMode termios TwoStopBits = setControlFlag (64) termios
withMode termios HangupOnClose = setControlFlag (1024) termios
withMode termios EnableParity = setControlFlag (256) termios
withMode termios OddParity = setControlFlag (512) termios
withMode termios EnableEcho = setLocalFlag (8) termios
withMode termios EchoErase = setLocalFlag (16) termios
withMode termios EchoKill = setLocalFlag (32) termios
withMode termios EchoLF = setLocalFlag (64) termios
withMode termios ProcessInput = setLocalFlag (2) termios
withMode termios ExtendedFunctions = setLocalFlag (32768) termios
withMode termios KeyboardInterrupts = setLocalFlag (1) termios
withMode termios NoFlushOnInterrupt = clearLocalFlag (128) termios
withMode termios BackgroundWriteInterrupt = setLocalFlag (256) termios
terminalMode :: TerminalMode -> TerminalAttributes -> Bool
terminalMode InterruptOnBreak = testInputFlag (2)
terminalMode MapCRtoLF = testInputFlag (256)
terminalMode IgnoreBreak = testInputFlag (1)
terminalMode IgnoreCR = testInputFlag (128)
terminalMode IgnoreParityErrors = testInputFlag (4)
terminalMode MapLFtoCR = testInputFlag (64)
terminalMode CheckParity = testInputFlag (16)
terminalMode StripHighBit = testInputFlag (32)
terminalMode StartStopInput = testInputFlag (4096)
terminalMode StartStopOutput = testInputFlag (1024)
terminalMode MarkParityErrors = testInputFlag (8)
terminalMode ProcessOutput = testOutputFlag (1)
terminalMode LocalMode = testControlFlag (2048)
terminalMode ReadEnable = testControlFlag (128)
terminalMode TwoStopBits = testControlFlag (64)
terminalMode HangupOnClose = testControlFlag (1024)
terminalMode EnableParity = testControlFlag (256)
terminalMode OddParity = testControlFlag (512)
terminalMode EnableEcho = testLocalFlag (8)
terminalMode EchoErase = testLocalFlag (16)
terminalMode EchoKill = testLocalFlag (32)
terminalMode EchoLF = testLocalFlag (64)
terminalMode ProcessInput = testLocalFlag (2)
terminalMode ExtendedFunctions = testLocalFlag (32768)
terminalMode KeyboardInterrupts = testLocalFlag (1)
terminalMode NoFlushOnInterrupt = not . testLocalFlag (128)
terminalMode BackgroundWriteInterrupt = testLocalFlag (256)
bitsPerByte :: TerminalAttributes -> Int
bitsPerByte termios = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
cflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
return $! (word2Bits (cflag .&. (48)))
where
word2Bits :: CTcflag -> Int
word2Bits x =
if x == (0) then 5
else if x == (16) then 6
else if x == (32) then 7
else if x == (48) then 8
else 0
withBits :: TerminalAttributes -> Int -> TerminalAttributes
withBits termios bits = unsafePerformIO $ do
withNewTermios termios $ \p -> do
cflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p
((cflag .&. complement (48)) .|. mask bits)
where
mask :: Int -> CTcflag
mask 5 = (0)
mask 6 = (16)
mask 7 = (32)
mask 8 = (48)
mask _ = error "withBits bit value out of range [5..8]"
data ControlCharacter
= EndOfFile
| EndOfLine
| Erase
| Interrupt
| Kill
| Quit
| Start
| Stop
| Suspend
controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
controlChar termios cc = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
let c_cc = ((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p
val <- peekElemOff c_cc (cc2Word cc)
if val == ((0)::CCc)
then return Nothing
else return (Just (chr (fromEnum val)))
withCC :: TerminalAttributes
-> (ControlCharacter, Char)
-> TerminalAttributes
withCC termios (cc, c) = unsafePerformIO $ do
withNewTermios termios $ \p -> do
let c_cc = ((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p
pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc)
withoutCC :: TerminalAttributes
-> ControlCharacter
-> TerminalAttributes
withoutCC termios cc = unsafePerformIO $ do
withNewTermios termios $ \p -> do
let c_cc = ((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p
pokeElemOff c_cc (cc2Word cc) ((0) :: CCc)
inputTime :: TerminalAttributes -> Int
inputTime termios = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
c <- peekElemOff (((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p) (5)
return (fromEnum (c :: CCc))
withTime :: TerminalAttributes -> Int -> TerminalAttributes
withTime termios time = unsafePerformIO $ do
withNewTermios termios $ \p -> do
let c_cc = ((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p
pokeElemOff c_cc (5) (fromIntegral time :: CCc)
minInput :: TerminalAttributes -> Int
minInput termios = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
c <- peekElemOff (((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p) (6)
return (fromEnum (c :: CCc))
withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
withMinInput termios count = unsafePerformIO $ do
withNewTermios termios $ \p -> do
let c_cc = ((\hsc_ptr -> hsc_ptr `plusPtr` 17)) p
pokeElemOff c_cc (6) (fromIntegral count :: CCc)
data BaudRate
= B0
| B50
| B75
| B110
| B134
| B150
| B200
| B300
| B600
| B1200
| B1800
| B2400
| B4800
| B9600
| B19200
| B38400
| B57600
| B115200
inputSpeed :: TerminalAttributes -> BaudRate
inputSpeed termios = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
w <- c_cfgetispeed p
return (word2Baud w)
foreign import ccall unsafe "cfgetispeed"
c_cfgetispeed :: Ptr CTermios -> IO CSpeed
withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
withInputSpeed termios br = unsafePerformIO $ do
withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br)
foreign import ccall unsafe "cfsetispeed"
c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt
outputSpeed :: TerminalAttributes -> BaudRate
outputSpeed termios = unsafePerformIO $ do
withTerminalAttributes termios $ \p -> do
w <- c_cfgetospeed p
return (word2Baud w)
foreign import ccall unsafe "cfgetospeed"
c_cfgetospeed :: Ptr CTermios -> IO CSpeed
withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
withOutputSpeed termios br = unsafePerformIO $ do
withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br)
foreign import ccall unsafe "cfsetospeed"
c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
getTerminalAttributes :: Fd -> IO TerminalAttributes
getTerminalAttributes (Fd fd) = do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p ->
throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p)
return $ makeTerminalAttributes fp
foreign import ccall unsafe "tcgetattr"
c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
data TerminalState
= Immediately
| WhenDrained
| WhenFlushed
setTerminalAttributes :: Fd
-> TerminalAttributes
-> TerminalState
-> IO ()
setTerminalAttributes (Fd fd) termios state = do
withTerminalAttributes termios $ \p ->
throwErrnoIfMinus1_ "setTerminalAttributes"
(c_tcsetattr fd (state2Int state) p)
where
state2Int :: TerminalState -> CInt
state2Int Immediately = (0)
state2Int WhenDrained = (1)
state2Int WhenFlushed = (2)
foreign import ccall unsafe "tcsetattr"
c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
sendBreak :: Fd -> Int -> IO ()
sendBreak (Fd fd) duration
= throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
foreign import ccall unsafe "tcsendbreak"
c_tcsendbreak :: CInt -> CInt -> IO CInt
drainOutput :: Fd -> IO ()
drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
foreign import ccall unsafe "tcdrain"
c_tcdrain :: CInt -> IO CInt
data QueueSelector
= InputQueue
| OutputQueue
| BothQueues
discardData :: Fd -> QueueSelector -> IO ()
discardData (Fd fd) queue =
throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
where
queue2Int :: QueueSelector -> CInt
queue2Int InputQueue = (0)
queue2Int OutputQueue = (1)
queue2Int BothQueues = (2)
foreign import ccall unsafe "tcflush"
c_tcflush :: CInt -> CInt -> IO CInt
data FlowAction
= SuspendOutput
| RestartOutput
| TransmitStop
| TransmitStart
controlFlow :: Fd -> FlowAction -> IO ()
controlFlow (Fd fd) action =
throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
where
action2Int :: FlowAction -> CInt
action2Int SuspendOutput = (0)
action2Int RestartOutput = (1)
action2Int TransmitStop = (2)
action2Int TransmitStart = (3)
foreign import ccall unsafe "tcflow"
c_tcflow :: CInt -> CInt -> IO CInt
getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
getTerminalProcessGroupID (Fd fd) = do
throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
foreign import ccall unsafe "tcgetpgrp"
c_tcgetpgrp :: CInt -> IO CPid
setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
setTerminalProcessGroupID (Fd fd) pgid =
throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid)
foreign import ccall unsafe "tcsetpgrp"
c_tcsetpgrp :: CInt -> CPid -> IO CInt
queryTerminal :: Fd -> IO Bool
queryTerminal (Fd fd) = do
r <- c_isatty fd
return (r == 1)
foreign import ccall unsafe "isatty"
c_isatty :: CInt -> IO CInt
cc2Word :: ControlCharacter -> Int
cc2Word EndOfFile = (4)
cc2Word EndOfLine = (11)
cc2Word Erase = (2)
cc2Word Interrupt = (0)
cc2Word Kill = (3)
cc2Word Quit = (1)
cc2Word Suspend = (10)
cc2Word Start = (8)
cc2Word Stop = (9)
baud2Word :: BaudRate -> CSpeed
baud2Word B0 = (0)
baud2Word B50 = (1)
baud2Word B75 = (2)
baud2Word B110 = (3)
baud2Word B134 = (4)
baud2Word B150 = (5)
baud2Word B200 = (6)
baud2Word B300 = (7)
baud2Word B600 = (8)
baud2Word B1200 = (9)
baud2Word B1800 = (10)
baud2Word B2400 = (11)
baud2Word B4800 = (12)
baud2Word B9600 = (13)
baud2Word B19200 = (14)
baud2Word B38400 = (15)
baud2Word B57600 = (4097)
baud2Word B115200 = (4098)
word2Baud :: CSpeed -> BaudRate
word2Baud x =
if x == (0) then B0
else if x == (1) then B50
else if x == (2) then B75
else if x == (3) then B110
else if x == (4) then B134
else if x == (5) then B150
else if x == (6) then B200
else if x == (7) then B300
else if x == (8) then B600
else if x == (9) then B1200
else if x == (10) then B1800
else if x == (11) then B2400
else if x == (12) then B4800
else if x == (13) then B9600
else if x == (14) then B19200
else if x == (15) then B38400
else if x == (4097) then B57600
else if x == (4098) then B115200
else error "unknown baud rate"
clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
clearInputFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
iflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p1 (iflag .&. complement flag)
return $ makeTerminalAttributes fp
setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
setInputFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
iflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p1 (iflag .|. flag)
return $ makeTerminalAttributes fp
testInputFlag :: CTcflag -> TerminalAttributes -> Bool
testInputFlag flag termios = unsafePerformIO $
withTerminalAttributes termios $ \p -> do
iflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
return $! ((iflag .&. flag) /= 0)
clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
clearControlFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
cflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p1 (cflag .&. complement flag)
return $ makeTerminalAttributes fp
setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
setControlFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
cflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p1 (cflag .|. flag)
return $ makeTerminalAttributes fp
testControlFlag :: CTcflag -> TerminalAttributes -> Bool
testControlFlag flag termios = unsafePerformIO $
withTerminalAttributes termios $ \p -> do
cflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
return $! ((cflag .&. flag) /= 0)
clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
clearLocalFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
lflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p1 (lflag .&. complement flag)
return $ makeTerminalAttributes fp
setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
setLocalFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
lflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p1 (lflag .|. flag)
return $ makeTerminalAttributes fp
testLocalFlag :: CTcflag -> TerminalAttributes -> Bool
testLocalFlag flag termios = unsafePerformIO $
withTerminalAttributes termios $ \p -> do
lflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
return $! ((lflag .&. flag) /= 0)
clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
clearOutputFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
oflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p1 (oflag .&. complement flag)
return $ makeTerminalAttributes fp
setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
setOutputFlag flag termios = unsafePerformIO $ do
fp <- mallocForeignPtrBytes (60)
withForeignPtr fp $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
oflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p2
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p1 (oflag .|. flag)
return $ makeTerminalAttributes fp
testOutputFlag :: CTcflag -> TerminalAttributes -> Bool
testOutputFlag flag termios = unsafePerformIO $
withTerminalAttributes termios $ \p -> do
oflag <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
return $! ((oflag .&. flag) /= 0)
withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a)
-> IO TerminalAttributes
withNewTermios termios action = do
fp1 <- mallocForeignPtrBytes (60)
withForeignPtr fp1 $ \p1 -> do
withTerminalAttributes termios $ \p2 -> do
copyBytes p1 p2 (60)
_ <- action p1
return ()
return $ makeTerminalAttributes fp1