ghc/tests/lib/IO/readwrite002.hs

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