ghc/tests/lib/IO/readwrite002.hs

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