Add IXANY, changelog entries, and TerminalMode comments
[packages/unix.git] / System / Posix / Terminal / Common.hsc
1 {-# LANGUAGE CApiFFI #-}
2 {-# LANGUAGE Trustworthy #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module      :  System.Posix.Terminal.Common
7 -- Copyright   :  (c) The University of Glasgow 2002
8 -- License     :  BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer  :  libraries@haskell.org
11 -- Stability   :  provisional
12 -- Portability :  non-portable (requires POSIX)
13 --
14 -- POSIX Terminal support
15 --
16 -----------------------------------------------------------------------------
17
18 -- see https://android.googlesource.com/platform/bionic/+/9ae59c0/libc/bionic/pathconf.c#37
19 #if !defined(_POSIX_VDISABLE) && defined(__ANDROID__)
20 #define _POSIX_VDISABLE -1
21 #endif
22
23
24 module System.Posix.Terminal.Common (
25   -- * Terminal support
26
27   -- ** Terminal attributes
28   TerminalAttributes,
29   getTerminalAttributes,
30   TerminalState(..),
31   setTerminalAttributes,
32
33   CTermios,
34   TerminalMode(..),
35   withoutMode,
36   withMode,
37   terminalMode,
38   bitsPerByte,
39   withBits,
40
41   ControlCharacter(..),
42   controlChar,
43   withCC,
44   withoutCC,
45
46   inputTime,
47   withTime,
48   minInput,
49   withMinInput,
50
51   BaudRate(..),
52   inputSpeed,
53   withInputSpeed,
54   outputSpeed,
55   withOutputSpeed,
56
57   -- ** Terminal operations
58   sendBreak,
59   drainOutput,
60   QueueSelector(..),
61   discardData,
62   FlowAction(..),
63   controlFlow,
64
65   -- ** Process groups
66   getTerminalProcessGroupID,
67   setTerminalProcessGroupID,
68
69   -- ** Testing a file descriptor
70   queryTerminal,
71   ) where
72
73 #include "HsUnix.h"
74
75 import Data.Bits
76 import Data.Char
77 import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ )
78 import Foreign.C.Types
79 import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
80 import Foreign.Marshal.Utils ( copyBytes )
81 import Foreign.Ptr ( Ptr, plusPtr )
82 import Foreign.Storable ( Storable(..) )
83 import System.IO.Unsafe ( unsafePerformIO )
84 import System.Posix.Types
85 import System.Posix.Internals ( CTermios )
86
87 #if !HAVE_TCDRAIN
88 import System.IO.Error ( ioeSetLocation )
89 import GHC.IO.Exception ( unsupportedOperation )
90 #endif
91
92 -- -----------------------------------------------------------------------------
93 -- Terminal attributes
94
95 newtype TerminalAttributes = TerminalAttributes (ForeignPtr CTermios)
96
97 makeTerminalAttributes :: ForeignPtr CTermios -> TerminalAttributes
98 makeTerminalAttributes = TerminalAttributes
99
100 withTerminalAttributes :: TerminalAttributes -> (Ptr CTermios -> IO a) -> IO a
101 withTerminalAttributes (TerminalAttributes termios) = withForeignPtr termios
102
103
104 data TerminalMode
105         -- input flags
106    = InterruptOnBreak           -- ^ @BRKINT@ - Signal interrupt on break
107    | MapCRtoLF                  -- ^ @ICRNL@ - Map CR to NL on input
108    | IgnoreBreak                -- ^ @IGNBRK@ - Ignore break condition
109    | IgnoreCR                   -- ^ @IGNCR@ - Ignore CR
110    | IgnoreParityErrors         -- ^ @IGNPAR@ - Ignore characters with parity errors
111    | MapLFtoCR                  -- ^ @INLCR@ - Map NL to CR on input
112    | CheckParity                -- ^ @INPCK@ - Enable input parity check
113    | StripHighBit               -- ^ @ISTRIP@ - Strip character
114    | RestartOnAny               -- ^ @IXANY@ - Enable any character to restart output
115    | StartStopInput             -- ^ @IXOFF@ - Enable start/stop input control
116    | StartStopOutput            -- ^ @IXON@ - Enable start/stop output control
117    | MarkParityErrors           -- ^ @PARMRK@ - Mark parity errors
118
119         -- output flags
120    | ProcessOutput              -- ^ @OPOST@ - Post-process output
121    | MapLFtoCRLF                -- ^ @ONLCR@ - (XSI) Map NL to CR-NL on output
122                                 --
123                                 -- @since 2.8.0.0
124    | OutputMapCRtoLF            -- ^ @OCRNL@ - (XSI) Map CR to NL on output
125                                 --
126                                 -- @since 2.8.0.0
127    | NoCRAtColumnZero           -- ^ @ONOCR@ - (XSI) No CR output at column 0
128                                 --
129                                 -- @since 2.8.0.0
130    | ReturnMeansLF              -- ^ @ONLRET@ - (XSI) NL performs CR function
131                                 --
132                                 -- @since 2.8.0.0
133    | FillIsDEL                  -- ^ @OFDEL@ - (XSI) Fill is DEL
134                                 --
135                                 -- @since 2.8.0.0
136    | SendFillOnDelay            -- ^ @OFILL@ - (XSI) Use fill characters for delay
137                                 --
138                                 -- @since 2.8.0.0
139    | LFDelayMask0               -- ^ @NLDLY(NL0)@ - (XSI) Select newline delay: type 0
140                                 --
141                                 -- @since 2.8.0.0
142    | LFDelayMask1               -- ^ @NLDLY(NL1)@ - (XSI) Select newline delay: type 1
143                                 --
144                                 -- @since 2.8.0.0
145    | CRDelayMask0               -- ^ @CRDLY(CR0)@ - (XSI) Select carriage-return delays: type 0
146                                 --
147                                 -- @since 2.8.0.0
148    | CRDelayMask1               -- ^ @CRDLY(CR1)@ - (XSI) Select carriage-return delays: type 1
149                                 --
150                                 -- @since 2.8.0.0
151    | CRDelayMask2               -- ^ @CRDLY(CR2)@ - (XSI) Select carriage-return delays: type 2
152                                 --
153                                 -- @since 2.8.0.0
154    | CRDelayMask3               -- ^ @CRDLY(CR3)@ - (XSI) Select carriage-return delays: type 3
155                                 --
156                                 -- @since 2.8.0.0
157    | TabDelayMask0              -- ^ @TABDLY(TAB0)@ - (XSI) Select horizontal-tab delays: type 0
158                                 --
159                                 -- @since 2.8.0.0
160    | TabDelayMask1              -- ^ @TABDLY(TAB1)@ - (XSI) Select horizontal-tab delays: type 1
161                                 --
162                                 -- @since 2.8.0.0
163    | TabDelayMask2              -- ^ @TABDLY(TAB2)@ - (XSI) Select horizontal-tab delays: type 2
164                                 --
165                                 -- @since 2.8.0.0
166    | TabDelayMask3              -- ^ @TABDLY(TAB3)@ - (XSI) Select horizontal-tab delays: type 3
167                                 --
168                                 -- @since 2.8.0.0
169    | BackspaceDelayMask0        -- ^ @BSDLY(BS0)@ - (XSI) Select backspace delays: type 0
170                                 --
171                                 -- @since 2.8.0.0
172    | BackspaceDelayMask1        -- ^ @BSDLY(BS1)@ - (XSI) Select backspace delays: type 1
173                                 --
174                                 -- @since 2.8.0.0
175    | VerticalTabDelayMask0      -- ^ @VTDLY(VT0)@ - (XSI) Select vertical-tab delays: type 0
176                                 --
177                                 -- @since 2.8.0.0
178    | VerticalTabDelayMask1      -- ^ @VTDLY(VT1)@ - (XSI) Select vertical-tab delays: type 1
179                                 --
180                                 -- @since 2.8.0.0
181    | FormfeedDelayMask0         -- ^ @FFDLY(FF0)@ - (XSI) Select form-feed delays: type 0
182                                 --
183                                 -- @since 2.8.0.0
184    | FormfeedDelayMask1         -- ^ @FFDLY(FF1)@ - (XSI) Select form-feed delays: type 1
185                                 --
186                                 -- @since 2.8.0.0
187
188         -- control flags
189    | LocalMode                  -- ^ @CLOCAL@ - Ignore modem status lines
190    | ReadEnable                 -- ^ @CREAD@ - Enable receiver
191    | TwoStopBits                -- ^ @CSTOPB@ - Send two stop bits, else one
192    | HangupOnClose              -- ^ @HUPCL@ - Hang up on last close
193    | EnableParity               -- ^ @PARENB@ - Parity enable
194    | OddParity                  -- ^ @PARODD@ - Odd parity, else even
195
196         -- local modes
197    | EnableEcho                 -- ^ @ECHO@ - Enable echo
198    | EchoErase                  -- ^ @ECHOE@ - Echo erase character as error-correcting backspace
199    | EchoKill                   -- ^ @ECHOK@ - Echo KILL
200    | EchoLF                     -- ^ @ECHONL@ - Echo NL
201    | ProcessInput               -- ^ @ICANON@ - Canonical input (erase and kill processing)
202    | ExtendedFunctions          -- ^ @IEXTEN@ - Enable extended input character processing
203    | KeyboardInterrupts         -- ^ @ISIG@ - Enable signals
204    | NoFlushOnInterrupt         -- ^ @NOFLSH@ - Disable flush after interrupt or quit
205    | BackgroundWriteInterrupt   -- ^ @TOSTOP@ - Send @SIGTTOU@ for background output
206
207 withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
208 withoutMode termios InterruptOnBreak = clearInputFlag (#const BRKINT) termios
209 withoutMode termios MapCRtoLF = clearInputFlag (#const ICRNL) termios
210 withoutMode termios IgnoreBreak = clearInputFlag (#const IGNBRK) termios
211 withoutMode termios IgnoreCR = clearInputFlag (#const IGNCR) termios
212 withoutMode termios IgnoreParityErrors = clearInputFlag (#const IGNPAR) termios
213 withoutMode termios MapLFtoCR = clearInputFlag (#const INLCR) termios
214 withoutMode termios CheckParity = clearInputFlag (#const INPCK) termios
215 withoutMode termios StripHighBit = clearInputFlag (#const ISTRIP) termios
216 withoutMode termios RestartOnAny = clearInputFlag (#const IXANY) termios
217 withoutMode termios StartStopInput = clearInputFlag (#const IXOFF) termios
218 withoutMode termios StartStopOutput = clearInputFlag (#const IXON) termios
219 withoutMode termios MarkParityErrors = clearInputFlag (#const PARMRK) termios
220 withoutMode termios ProcessOutput = clearOutputFlag (#const OPOST) termios
221 withoutMode termios MapLFtoCRLF = clearOutputFlag (#const ONLCR) termios
222 withoutMode termios OutputMapCRtoLF = clearOutputFlag (#const OCRNL) termios
223 withoutMode termios NoCRAtColumnZero = clearOutputFlag (#const ONOCR) termios
224 withoutMode termios ReturnMeansLF = clearOutputFlag (#const ONLRET) termios
225 withoutMode termios FillIsDEL = clearOutputFlag (#const OFDEL) termios
226 withoutMode termios SendFillOnDelay = clearOutputFlag (#const OFILL) termios
227 withoutMode termios LFDelayMask0 = clearOutputFlag (#const NL0) termios
228 withoutMode termios LFDelayMask1 = clearOutputFlag (#const NL1) termios
229 withoutMode termios CRDelayMask0 = clearOutputFlag (#const CR0) termios
230 withoutMode termios CRDelayMask1 = clearOutputFlag (#const CR1) termios
231 withoutMode termios CRDelayMask2 = clearOutputFlag (#const CR2) termios
232 withoutMode termios CRDelayMask3 = clearOutputFlag (#const CR3) termios
233 withoutMode termios TabDelayMask0 = clearOutputFlag (#const TAB0) termios
234 withoutMode termios TabDelayMask1 = clearOutputFlag (#const TAB1) termios
235 withoutMode termios TabDelayMask2 = clearOutputFlag (#const TAB2) termios
236 withoutMode termios TabDelayMask3 = clearOutputFlag (#const TAB3) termios
237 withoutMode termios BackspaceDelayMask0 = clearOutputFlag (#const BS0) termios
238 withoutMode termios BackspaceDelayMask1 = clearOutputFlag (#const BS1) termios
239 withoutMode termios VerticalTabDelayMask0 = clearOutputFlag (#const VT0) termios
240 withoutMode termios VerticalTabDelayMask1 = clearOutputFlag (#const VT1) termios
241 withoutMode termios FormfeedDelayMask0 = clearOutputFlag (#const FF0) termios
242 withoutMode termios FormfeedDelayMask1 = clearOutputFlag (#const FF1) termios
243 withoutMode termios LocalMode = clearControlFlag (#const CLOCAL) termios
244 withoutMode termios ReadEnable = clearControlFlag (#const CREAD) termios
245 withoutMode termios TwoStopBits = clearControlFlag (#const CSTOPB) termios
246 withoutMode termios HangupOnClose = clearControlFlag (#const HUPCL) termios
247 withoutMode termios EnableParity = clearControlFlag (#const PARENB) termios
248 withoutMode termios OddParity = clearControlFlag (#const PARODD) termios
249 withoutMode termios EnableEcho = clearLocalFlag (#const ECHO) termios
250 withoutMode termios EchoErase = clearLocalFlag (#const ECHOE) termios
251 withoutMode termios EchoKill = clearLocalFlag (#const ECHOK) termios
252 withoutMode termios EchoLF = clearLocalFlag (#const ECHONL) termios
253 withoutMode termios ProcessInput = clearLocalFlag (#const ICANON) termios
254 withoutMode termios ExtendedFunctions = clearLocalFlag (#const IEXTEN) termios
255 withoutMode termios KeyboardInterrupts = clearLocalFlag (#const ISIG) termios
256 withoutMode termios NoFlushOnInterrupt = setLocalFlag (#const NOFLSH) termios
257 withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (#const TOSTOP) termios
258
259 withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
260 withMode termios InterruptOnBreak = setInputFlag (#const BRKINT) termios
261 withMode termios MapCRtoLF = setInputFlag (#const ICRNL) termios
262 withMode termios IgnoreBreak = setInputFlag (#const IGNBRK) termios
263 withMode termios IgnoreCR = setInputFlag (#const IGNCR) termios
264 withMode termios IgnoreParityErrors = setInputFlag (#const IGNPAR) termios
265 withMode termios MapLFtoCR = setInputFlag (#const INLCR) termios
266 withMode termios CheckParity = setInputFlag (#const INPCK) termios
267 withMode termios StripHighBit = setInputFlag (#const ISTRIP) termios
268 withMode termios RestartOnAny = setInputFlag (#const IXANY) termios
269 withMode termios StartStopInput = setInputFlag (#const IXOFF) termios
270 withMode termios StartStopOutput = setInputFlag (#const IXON) termios
271 withMode termios MarkParityErrors = setInputFlag (#const PARMRK) termios
272 withMode termios ProcessOutput = setOutputFlag (#const OPOST) termios
273 withMode termios MapLFtoCRLF = setOutputFlag (#const ONLCR) termios
274 withMode termios OutputMapCRtoLF = setOutputFlag (#const OCRNL) termios
275 withMode termios NoCRAtColumnZero = setOutputFlag (#const ONOCR) termios
276 withMode termios ReturnMeansLF = setOutputFlag (#const ONLRET) termios
277 withMode termios FillIsDEL = setOutputFlag (#const OFDEL) termios
278 withMode termios SendFillOnDelay = setOutputFlag (#const OFILL) termios
279 withMode termios LFDelayMask0 = setOutputFlag (#const NL0) termios
280 withMode termios LFDelayMask1 = setOutputFlag (#const NL1) termios
281 withMode termios CRDelayMask0 = setOutputFlag (#const CR0) termios
282 withMode termios CRDelayMask1 = setOutputFlag (#const CR1) termios
283 withMode termios CRDelayMask2 = setOutputFlag (#const CR2) termios
284 withMode termios CRDelayMask3 = setOutputFlag (#const CR3) termios
285 withMode termios TabDelayMask0 = setOutputFlag (#const TAB0) termios
286 withMode termios TabDelayMask1 = setOutputFlag (#const TAB1) termios
287 withMode termios TabDelayMask2 = setOutputFlag (#const TAB2) termios
288 withMode termios TabDelayMask3 = setOutputFlag (#const TAB3) termios
289 withMode termios BackspaceDelayMask0 = setOutputFlag (#const BS0) termios
290 withMode termios BackspaceDelayMask1 = setOutputFlag (#const BS1) termios
291 withMode termios VerticalTabDelayMask0 = setOutputFlag (#const VT0) termios
292 withMode termios VerticalTabDelayMask1 = setOutputFlag (#const VT1) termios
293 withMode termios FormfeedDelayMask0 = setOutputFlag (#const FF0) termios
294 withMode termios FormfeedDelayMask1 = setOutputFlag (#const FF1) termios
295 withMode termios LocalMode = setControlFlag (#const CLOCAL) termios
296 withMode termios ReadEnable = setControlFlag (#const CREAD) termios
297 withMode termios TwoStopBits = setControlFlag (#const CSTOPB) termios
298 withMode termios HangupOnClose = setControlFlag (#const HUPCL) termios
299 withMode termios EnableParity = setControlFlag (#const PARENB) termios
300 withMode termios OddParity = setControlFlag (#const PARODD) termios
301 withMode termios EnableEcho = setLocalFlag (#const ECHO) termios
302 withMode termios EchoErase = setLocalFlag (#const ECHOE) termios
303 withMode termios EchoKill = setLocalFlag (#const ECHOK) termios
304 withMode termios EchoLF = setLocalFlag (#const ECHONL) termios
305 withMode termios ProcessInput = setLocalFlag (#const ICANON) termios
306 withMode termios ExtendedFunctions = setLocalFlag (#const IEXTEN) termios
307 withMode termios KeyboardInterrupts = setLocalFlag (#const ISIG) termios
308 withMode termios NoFlushOnInterrupt = clearLocalFlag (#const NOFLSH) termios
309 withMode termios BackgroundWriteInterrupt = setLocalFlag (#const TOSTOP) termios
310
311 terminalMode :: TerminalMode -> TerminalAttributes -> Bool
312 terminalMode InterruptOnBreak = testInputFlag (#const BRKINT)
313 terminalMode MapCRtoLF = testInputFlag (#const ICRNL)
314 terminalMode IgnoreBreak = testInputFlag (#const IGNBRK)
315 terminalMode IgnoreCR = testInputFlag (#const IGNCR)
316 terminalMode IgnoreParityErrors = testInputFlag (#const IGNPAR)
317 terminalMode MapLFtoCR = testInputFlag (#const INLCR)
318 terminalMode CheckParity = testInputFlag (#const INPCK)
319 terminalMode StripHighBit = testInputFlag (#const ISTRIP)
320 terminalMode RestartOnAny = testInputFlag (#const IXANY)
321 terminalMode StartStopInput = testInputFlag (#const IXOFF)
322 terminalMode StartStopOutput = testInputFlag (#const IXON)
323 terminalMode MarkParityErrors = testInputFlag (#const PARMRK)
324 terminalMode ProcessOutput = testOutputFlag (#const OPOST)
325 terminalMode MapLFtoCRLF = testOutputFlag (#const ONLCR)
326 terminalMode OutputMapCRtoLF = testOutputFlag (#const OCRNL)
327 terminalMode NoCRAtColumnZero = testOutputFlag (#const ONOCR)
328 terminalMode ReturnMeansLF = testOutputFlag (#const ONLRET)
329 terminalMode FillIsDEL = testOutputFlag (#const OFDEL)
330 terminalMode SendFillOnDelay = testOutputFlag (#const OFILL)
331 terminalMode LFDelayMask0 = testOutputFlag (#const NL0)
332 terminalMode LFDelayMask1 = testOutputFlag (#const NL1)
333 terminalMode CRDelayMask0 = testOutputFlag (#const CR0)
334 terminalMode CRDelayMask1 = testOutputFlag (#const CR1)
335 terminalMode CRDelayMask2 = testOutputFlag (#const CR2)
336 terminalMode CRDelayMask3 = testOutputFlag (#const CR3)
337 terminalMode TabDelayMask0 = testOutputFlag (#const TAB0)
338 terminalMode TabDelayMask1 = testOutputFlag (#const TAB1)
339 terminalMode TabDelayMask2 = testOutputFlag (#const TAB2)
340 terminalMode TabDelayMask3 = testOutputFlag (#const TAB3)
341 terminalMode BackspaceDelayMask0 = testOutputFlag (#const BS0)
342 terminalMode BackspaceDelayMask1 = testOutputFlag (#const BS1)
343 terminalMode VerticalTabDelayMask0 = testOutputFlag (#const VT0)
344 terminalMode VerticalTabDelayMask1 = testOutputFlag (#const VT1)
345 terminalMode FormfeedDelayMask0 = testOutputFlag (#const FF0)
346 terminalMode FormfeedDelayMask1 = testOutputFlag (#const FF1)
347 terminalMode LocalMode = testControlFlag (#const CLOCAL)
348 terminalMode ReadEnable = testControlFlag (#const CREAD)
349 terminalMode TwoStopBits = testControlFlag (#const CSTOPB)
350 terminalMode HangupOnClose = testControlFlag (#const HUPCL)
351 terminalMode EnableParity = testControlFlag (#const PARENB)
352 terminalMode OddParity = testControlFlag (#const PARODD)
353 terminalMode EnableEcho = testLocalFlag (#const ECHO)
354 terminalMode EchoErase = testLocalFlag (#const ECHOE)
355 terminalMode EchoKill = testLocalFlag (#const ECHOK)
356 terminalMode EchoLF = testLocalFlag (#const ECHONL)
357 terminalMode ProcessInput = testLocalFlag (#const ICANON)
358 terminalMode ExtendedFunctions = testLocalFlag (#const IEXTEN)
359 terminalMode KeyboardInterrupts = testLocalFlag (#const ISIG)
360 terminalMode NoFlushOnInterrupt = not . testLocalFlag (#const NOFLSH)
361 terminalMode BackgroundWriteInterrupt = testLocalFlag (#const TOSTOP)
362
363 bitsPerByte :: TerminalAttributes -> Int
364 bitsPerByte termios = unsafePerformIO $ do
365   withTerminalAttributes termios $ \p -> do
366     cflag <- (#peek struct termios, c_cflag) p
367     return $! (word2Bits (cflag .&. (#const CSIZE)))
368   where
369     word2Bits :: CTcflag -> Int
370     word2Bits x =
371         if x == (#const CS5) then 5
372         else if x == (#const CS6) then 6
373         else if x == (#const CS7) then 7
374         else if x == (#const CS8) then 8
375         else 0
376
377 withBits :: TerminalAttributes -> Int -> TerminalAttributes
378 withBits termios bits = unsafePerformIO $ do
379   withNewTermios termios $ \p -> do
380     cflag <- (#peek struct termios, c_cflag) p
381     (#poke struct termios, c_cflag) p
382        ((cflag .&. complement (#const CSIZE)) .|. mask bits)
383   where
384     mask :: Int -> CTcflag
385     mask 5 = (#const CS5)
386     mask 6 = (#const CS6)
387     mask 7 = (#const CS7)
388     mask 8 = (#const CS8)
389     mask _ = error "withBits bit value out of range [5..8]"
390
391 data ControlCharacter
392   = EndOfFile           -- VEOF
393   | EndOfLine           -- VEOL
394   | Erase               -- VERASE
395   | Interrupt           -- VINTR
396   | Kill                -- VKILL
397   | Quit                -- VQUIT
398   | Start               -- VSTART
399   | Stop                -- VSTOP
400   | Suspend             -- VSUSP
401
402 controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
403 controlChar termios cc = unsafePerformIO $ do
404   withTerminalAttributes termios $ \p -> do
405     let c_cc = (#ptr struct termios, c_cc) p
406     val <- peekElemOff c_cc (cc2Word cc)
407     if val == ((#const _POSIX_VDISABLE)::CCc)
408        then return Nothing
409        else return (Just (chr (fromEnum val)))
410
411 withCC :: TerminalAttributes
412        -> (ControlCharacter, Char)
413        -> TerminalAttributes
414 withCC termios (cc, c) = unsafePerformIO $ do
415   withNewTermios termios $ \p -> do
416     let c_cc = (#ptr struct termios, c_cc) p
417     pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc)
418
419 withoutCC :: TerminalAttributes
420           -> ControlCharacter
421           -> TerminalAttributes
422 withoutCC termios cc = unsafePerformIO $ do
423   withNewTermios termios $ \p -> do
424     let c_cc = (#ptr struct termios, c_cc) p
425     pokeElemOff c_cc (cc2Word cc) ((#const _POSIX_VDISABLE) :: CCc)
426
427 inputTime :: TerminalAttributes -> Int
428 inputTime termios = unsafePerformIO $ do
429   withTerminalAttributes termios $ \p -> do
430     c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VTIME)
431     return (fromEnum (c :: CCc))
432
433 withTime :: TerminalAttributes -> Int -> TerminalAttributes
434 withTime termios time = unsafePerformIO $ do
435   withNewTermios termios $ \p -> do
436     let c_cc = (#ptr struct termios, c_cc) p
437     pokeElemOff c_cc (#const VTIME) (fromIntegral time :: CCc)
438
439 minInput :: TerminalAttributes -> Int
440 minInput termios = unsafePerformIO $ do
441   withTerminalAttributes termios $ \p -> do
442     c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VMIN)
443     return (fromEnum (c :: CCc))
444
445 withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
446 withMinInput termios count = unsafePerformIO $ do
447   withNewTermios termios $ \p -> do
448     let c_cc = (#ptr struct termios, c_cc) p
449     pokeElemOff c_cc (#const VMIN) (fromIntegral count :: CCc)
450
451 data BaudRate
452   = B0
453   | B50
454   | B75
455   | B110
456   | B134
457   | B150
458   | B200
459   | B300
460   | B600
461   | B1200
462   | B1800
463   | B2400
464   | B4800
465   | B9600
466   | B19200
467   | B38400
468   | B57600
469   | B115200
470
471 inputSpeed :: TerminalAttributes -> BaudRate
472 inputSpeed termios = unsafePerformIO $ do
473   withTerminalAttributes termios $ \p -> do
474     w <- c_cfgetispeed p
475     return (word2Baud w)
476
477 foreign import capi unsafe "termios.h cfgetispeed"
478   c_cfgetispeed :: Ptr CTermios -> IO CSpeed
479
480 withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
481 withInputSpeed termios br = unsafePerformIO $ do
482   withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br)
483
484 foreign import capi unsafe "termios.h cfsetispeed"
485   c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt
486
487
488 outputSpeed :: TerminalAttributes -> BaudRate
489 outputSpeed termios = unsafePerformIO $ do
490   withTerminalAttributes termios $ \p ->  do
491     w <- c_cfgetospeed p
492     return (word2Baud w)
493
494 foreign import capi unsafe "termios.h cfgetospeed"
495   c_cfgetospeed :: Ptr CTermios -> IO CSpeed
496
497 withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
498 withOutputSpeed termios br = unsafePerformIO $ do
499   withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br)
500
501 foreign import capi unsafe "termios.h cfsetospeed"
502   c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
503
504 -- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain
505 --   the @TerminalAttributes@ associated with @Fd@ @fd@.
506 getTerminalAttributes :: Fd -> IO TerminalAttributes
507 getTerminalAttributes (Fd fd) = do
508   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
509   withForeignPtr fp $ \p ->
510       throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p)
511   return $ makeTerminalAttributes fp
512
513 foreign import capi unsafe "termios.h tcgetattr"
514   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
515
516 data TerminalState
517   = Immediately
518   | WhenDrained
519   | WhenFlushed
520
521 -- | @setTerminalAttributes fd attr ts@ calls @tcsetattr@ to change
522 --   the @TerminalAttributes@ associated with @Fd@ @fd@ to
523 --   @attr@, when the terminal is in the state indicated by @ts@.
524 setTerminalAttributes :: Fd
525                       -> TerminalAttributes
526                       -> TerminalState
527                       -> IO ()
528 setTerminalAttributes (Fd fd) termios state = do
529   withTerminalAttributes termios $ \p ->
530     throwErrnoIfMinus1_ "setTerminalAttributes"
531       (c_tcsetattr fd (state2Int state) p)
532   where
533     state2Int :: TerminalState -> CInt
534     state2Int Immediately = (#const TCSANOW)
535     state2Int WhenDrained = (#const TCSADRAIN)
536     state2Int WhenFlushed = (#const TCSAFLUSH)
537
538 foreign import capi unsafe "termios.h tcsetattr"
539    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
540
541 -- | @sendBreak fd duration@ calls @tcsendbreak@ to transmit a
542 --   continuous stream of zero-valued bits on @Fd@ @fd@ for the
543 --   specified implementation-dependent @duration@.
544 sendBreak :: Fd -> Int -> IO ()
545 sendBreak (Fd fd) duration
546   = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
547
548 foreign import capi unsafe "termios.h tcsendbreak"
549   c_tcsendbreak :: CInt -> CInt -> IO CInt
550
551 -- | @drainOutput fd@ calls @tcdrain@ to block until all output
552 --   written to @Fd@ @fd@ has been transmitted.
553 --
554 -- Throws 'IOError' (\"unsupported operation\") if platform does not
555 -- provide @tcdrain(3)@ (use @#if HAVE_TCDRAIN@ CPP guard to
556 -- detect availability).
557 drainOutput :: Fd -> IO ()
558 #if HAVE_TCDRAIN
559 drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
560
561 foreign import capi safe "termios.h tcdrain"
562   c_tcdrain :: CInt -> IO CInt
563 #else
564 {-# WARNING drainOutput
565     "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_TCDRAIN@)" #-}
566 drainOutput _ = ioError (ioeSetLocation unsupportedOperation "drainOutput")
567 #endif
568
569 data QueueSelector
570   = InputQueue          -- TCIFLUSH
571   | OutputQueue         -- TCOFLUSH
572   | BothQueues          -- TCIOFLUSH
573
574 -- | @discardData fd queues@ calls @tcflush@ to discard
575 --   pending input and\/or output for @Fd@ @fd@,
576 --   as indicated by the @QueueSelector@ @queues@.
577 discardData :: Fd -> QueueSelector -> IO ()
578 discardData (Fd fd) queue =
579   throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
580   where
581     queue2Int :: QueueSelector -> CInt
582     queue2Int InputQueue  = (#const TCIFLUSH)
583     queue2Int OutputQueue = (#const TCOFLUSH)
584     queue2Int BothQueues  = (#const TCIOFLUSH)
585
586 foreign import capi unsafe "termios.h tcflush"
587   c_tcflush :: CInt -> CInt -> IO CInt
588
589 data FlowAction
590   = SuspendOutput       -- ^ TCOOFF
591   | RestartOutput       -- ^ TCOON
592   | TransmitStop        -- ^ TCIOFF
593   | TransmitStart       -- ^ TCION
594
595 -- | @controlFlow fd action@ calls @tcflow@ to control the
596 --   flow of data on @Fd@ @fd@, as indicated by
597 --   @action@.
598 controlFlow :: Fd -> FlowAction -> IO ()
599 controlFlow (Fd fd) action =
600   throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
601   where
602     action2Int :: FlowAction -> CInt
603     action2Int SuspendOutput = (#const TCOOFF)
604     action2Int RestartOutput = (#const TCOON)
605     action2Int TransmitStop  = (#const TCIOFF)
606     action2Int TransmitStart = (#const TCION)
607
608 foreign import capi unsafe "termios.h tcflow"
609   c_tcflow :: CInt -> CInt -> IO CInt
610
611 -- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
612 --   obtain the @ProcessGroupID@ of the foreground process group
613 --   associated with the terminal attached to @Fd@ @fd@.
614 getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
615 getTerminalProcessGroupID (Fd fd) = do
616   throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
617
618 foreign import ccall unsafe "tcgetpgrp"
619   c_tcgetpgrp :: CInt -> IO CPid
620
621 -- | @setTerminalProcessGroupID fd pgid@ calls @tcsetpgrp@ to
622 --   set the @ProcessGroupID@ of the foreground process group
623 --   associated with the terminal attached to @Fd@
624 --   @fd@ to @pgid@.
625 setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
626 setTerminalProcessGroupID (Fd fd) pgid =
627   throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid)
628
629 foreign import ccall unsafe "tcsetpgrp"
630   c_tcsetpgrp :: CInt -> CPid -> IO CInt
631
632 -- -----------------------------------------------------------------------------
633 -- file descriptor queries
634
635 -- | @queryTerminal fd@ calls @isatty@ to determine whether or
636 --   not @Fd@ @fd@ is associated with a terminal.
637 queryTerminal :: Fd -> IO Bool
638 queryTerminal (Fd fd) = do
639   r <- c_isatty fd
640   return (r == 1)
641   -- ToDo: the spec says that it can set errno to EBADF if the result is zero
642
643 foreign import ccall unsafe "isatty"
644   c_isatty :: CInt -> IO CInt
645
646 -- -----------------------------------------------------------------------------
647 -- Local utility functions
648
649 -- Convert Haskell ControlCharacter to Int
650
651 cc2Word :: ControlCharacter -> Int
652 cc2Word EndOfFile = (#const VEOF)
653 cc2Word EndOfLine = (#const VEOL)
654 cc2Word Erase     = (#const VERASE)
655 cc2Word Interrupt = (#const VINTR)
656 cc2Word Kill      = (#const VKILL)
657 cc2Word Quit      = (#const VQUIT)
658 cc2Word Suspend   = (#const VSUSP)
659 cc2Word Start     = (#const VSTART)
660 cc2Word Stop      = (#const VSTOP)
661
662 -- Convert Haskell BaudRate to unsigned integral type (Word)
663
664 baud2Word :: BaudRate -> CSpeed
665 baud2Word B0 = (#const B0)
666 baud2Word B50 = (#const B50)
667 baud2Word B75 = (#const B75)
668 baud2Word B110 = (#const B110)
669 baud2Word B134 = (#const B134)
670 baud2Word B150 = (#const B150)
671 baud2Word B200 = (#const B200)
672 baud2Word B300 = (#const B300)
673 baud2Word B600 = (#const B600)
674 baud2Word B1200 = (#const B1200)
675 baud2Word B1800 = (#const B1800)
676 baud2Word B2400 = (#const B2400)
677 baud2Word B4800 = (#const B4800)
678 baud2Word B9600 = (#const B9600)
679 baud2Word B19200 = (#const B19200)
680 baud2Word B38400 = (#const B38400)
681 #ifdef B57600
682 baud2Word B57600 = (#const B57600)
683 #else
684 baud2Word B57600 = error "B57600 not available on this system"
685 #endif
686 #ifdef B115200
687 baud2Word B115200 = (#const B115200)
688 #else
689 baud2Word B115200 = error "B115200 not available on this system"
690 #endif
691
692 -- And convert a word back to a baud rate
693 -- We really need some cpp macros here.
694
695 word2Baud :: CSpeed -> BaudRate
696 word2Baud x =
697     if x == (#const B0) then B0
698     else if x == (#const B50) then B50
699     else if x == (#const B75) then B75
700     else if x == (#const B110) then B110
701     else if x == (#const B134) then B134
702     else if x == (#const B150) then B150
703     else if x == (#const B200) then B200
704     else if x == (#const B300) then B300
705     else if x == (#const B600) then B600
706     else if x == (#const B1200) then B1200
707     else if x == (#const B1800) then B1800
708     else if x == (#const B2400) then B2400
709     else if x == (#const B4800) then B4800
710     else if x == (#const B9600) then B9600
711     else if x == (#const B19200) then B19200
712     else if x == (#const B38400) then B38400
713 #ifdef B57600
714     else if x == (#const B57600) then B57600
715 #endif
716 #ifdef B115200
717     else if x == (#const B115200) then B115200
718 #endif
719     else error "unknown baud rate"
720
721 -- Clear termios i_flag
722
723 clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
724 clearInputFlag flag termios = unsafePerformIO $ do
725   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
726   withForeignPtr fp $ \p1 -> do
727     withTerminalAttributes termios $ \p2 -> do
728       copyBytes p1 p2 (#const sizeof(struct termios))
729       iflag <- (#peek struct termios, c_iflag) p2
730       (#poke struct termios, c_iflag) p1 (iflag .&. complement flag)
731   return $ makeTerminalAttributes fp
732
733 -- Set termios i_flag
734
735 setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
736 setInputFlag flag termios = unsafePerformIO $ do
737   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
738   withForeignPtr fp $ \p1 -> do
739     withTerminalAttributes termios $ \p2 -> do
740       copyBytes p1 p2 (#const sizeof(struct termios))
741       iflag <- (#peek struct termios, c_iflag) p2
742       (#poke struct termios, c_iflag) p1 (iflag .|. flag)
743   return $ makeTerminalAttributes fp
744
745 -- Examine termios i_flag
746
747 testInputFlag :: CTcflag -> TerminalAttributes -> Bool
748 testInputFlag flag termios = unsafePerformIO $
749   withTerminalAttributes termios $ \p ->  do
750     iflag <- (#peek struct termios, c_iflag) p
751     return $! ((iflag .&. flag) /= 0)
752
753 -- Clear termios c_flag
754
755 clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
756 clearControlFlag flag termios = unsafePerformIO $ do
757   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
758   withForeignPtr fp $ \p1 -> do
759     withTerminalAttributes termios $ \p2 -> do
760       copyBytes p1 p2 (#const sizeof(struct termios))
761       cflag <- (#peek struct termios, c_cflag) p2
762       (#poke struct termios, c_cflag) p1 (cflag .&. complement flag)
763   return $ makeTerminalAttributes fp
764
765 -- Set termios c_flag
766
767 setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
768 setControlFlag flag termios = unsafePerformIO $ do
769   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
770   withForeignPtr fp $ \p1 -> do
771     withTerminalAttributes termios $ \p2 -> do
772       copyBytes p1 p2 (#const sizeof(struct termios))
773       cflag <- (#peek struct termios, c_cflag) p2
774       (#poke struct termios, c_cflag) p1 (cflag .|. flag)
775   return $ makeTerminalAttributes fp
776
777 -- Examine termios c_flag
778
779 testControlFlag :: CTcflag -> TerminalAttributes -> Bool
780 testControlFlag flag termios = unsafePerformIO $
781   withTerminalAttributes termios $ \p -> do
782     cflag <- (#peek struct termios, c_cflag) p
783     return $! ((cflag .&. flag) /= 0)
784
785 -- Clear termios l_flag
786
787 clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
788 clearLocalFlag flag termios = unsafePerformIO $ do
789   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
790   withForeignPtr fp $ \p1 -> do
791     withTerminalAttributes termios $ \p2 -> do
792       copyBytes p1 p2 (#const sizeof(struct termios))
793       lflag <- (#peek struct termios, c_lflag) p2
794       (#poke struct termios, c_lflag) p1 (lflag .&. complement flag)
795   return $ makeTerminalAttributes fp
796
797 -- Set termios l_flag
798
799 setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
800 setLocalFlag flag termios = unsafePerformIO $ do
801   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
802   withForeignPtr fp $ \p1 -> do
803     withTerminalAttributes termios $ \p2 -> do
804       copyBytes p1 p2 (#const sizeof(struct termios))
805       lflag <- (#peek struct termios, c_lflag) p2
806       (#poke struct termios, c_lflag) p1 (lflag .|. flag)
807   return $ makeTerminalAttributes fp
808
809 -- Examine termios l_flag
810
811 testLocalFlag :: CTcflag -> TerminalAttributes -> Bool
812 testLocalFlag flag termios = unsafePerformIO $
813   withTerminalAttributes termios $ \p ->  do
814     lflag <- (#peek struct termios, c_lflag) p
815     return $! ((lflag .&. flag) /= 0)
816
817 -- Clear termios o_flag
818
819 clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
820 clearOutputFlag flag termios = unsafePerformIO $ do
821   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
822   withForeignPtr fp $ \p1 -> do
823     withTerminalAttributes termios $ \p2 -> do
824       copyBytes p1 p2 (#const sizeof(struct termios))
825       oflag <- (#peek struct termios, c_oflag) p2
826       (#poke struct termios, c_oflag) p1 (oflag .&. complement flag)
827   return $ makeTerminalAttributes fp
828
829 -- Set termios o_flag
830
831 setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
832 setOutputFlag flag termios = unsafePerformIO $ do
833   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
834   withForeignPtr fp $ \p1 -> do
835     withTerminalAttributes termios $ \p2 -> do
836       copyBytes p1 p2 (#const sizeof(struct termios))
837       oflag <- (#peek struct termios, c_oflag) p2
838       (#poke struct termios, c_oflag) p1 (oflag .|. flag)
839   return $ makeTerminalAttributes fp
840
841 -- Examine termios o_flag
842
843 testOutputFlag :: CTcflag -> TerminalAttributes -> Bool
844 testOutputFlag flag termios = unsafePerformIO $
845   withTerminalAttributes termios $ \p -> do
846     oflag <- (#peek struct termios, c_oflag) p
847     return $! ((oflag .&. flag) /= 0)
848
849 withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a)
850   -> IO TerminalAttributes
851 withNewTermios termios action = do
852   fp1 <- mallocForeignPtrBytes (#const sizeof(struct termios))
853   withForeignPtr fp1 $ \p1 -> do
854    withTerminalAttributes termios $ \p2 -> do
855     copyBytes p1 p2 (#const sizeof(struct termios))
856     _ <- action p1
857     return ()
858   return $ makeTerminalAttributes fp1