ghc/tests/io/should_run/io018.hs

   1 -- !!! Testing RW handles
   2 module Main(main) where
   3
   4 import IO
   5 import IOExts
   6 import Directory (removeFile, doesFileExist)
   7 import Monad
   8
   9 -- This test is weird, full marks to whoever dreamt it up!
  10
  11 main :: IO ()
  12 main = do
  13    let username = "io018.inout"
  14    f <- doesFileExist username
  15    when f (removeFile username)
  16    cd <- openFile username ReadWriteMode
  17    hSetBinaryMode cd True
  18    hSetBuffering stdin NoBuffering
  19    hSetBuffering stdout NoBuffering
  20    hSetBuffering cd NoBuffering
  21    hPutStr cd speakString
  22    hSeek cd AbsoluteSeek 0
  23    speak cd  `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
  24    hSeek cd AbsoluteSeek 0
  25    hSetBuffering cd LineBuffering
  26    speak cd  `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
  27    hSeek cd AbsoluteSeek 0
  28    hSetBuffering cd (BlockBuffering Nothing)
  29    speak cd  `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
  30
  31 speakString = "Someone wants to speak with you\n"
  32
  33 speak cd = do
  34      (do
  35         ready <- hReady cd
  36         if ready then
  37            hGetChar cd >>= putChar
  38          else
  39            return ()
  40         ready <- hReady stdin
  41         if ready then (do { ch <- getChar; hPutChar cd ch})
  42          else return ())
  43      speak cd