ghc/lib/prelude/GHCio.hs

   1 {-
   2 %
   3 % (c) The AQUA Project, Glasgow University, 1994-1996
   4 %
   5
   6 This module defines Haskell {\em handles} and the basic operations
   7 which are supported for them.
   8 -}
   9
  10 #include "error.h"
  11
  12 module GHCio where
  13
  14 import GHCbase
  15 import qualified GHCps ( unpackPS, packCString )
  16 import Ix (Ix(..))
  17
  18 ---------------------------------
  19 infixr 1 `stThen`
  20
  21 -- a useful little number for doing _ccall_s in IO-land:
  22
  23 stThen :: PrimIO a -> (a -> IO b) -> IO b
  24 {-# INLINE stThen   #-}
  25
  26 stThen (ST m) k = IO $ ST $ \ s ->
  27     case (m s)     of { (m_res, new_s)    ->
  28     case (k m_res) of { (IO (ST k_m_res)) ->
  29     k_m_res new_s }}
  30
  31 ---------------------------------
  32 -- this one didn't make it into the 1.3 defn
  33
  34 -- The construct $try comp$ exposes errors which occur within a
  35 -- computation, and which are not fully handled.  It always succeeds.
  36
  37 tryIO :: IO a -> IO (Either IOError a)
  38 tryIO p = catch (p >>= (return . Right)) (return . Left)
  39
  40 ---------------------------------
  41
  42 data Handle__
  43   = ErrorHandle         IOError
  44   | ClosedHandle
  45   | SemiClosedHandle    Addr (Addr, Int)
  46   | ReadHandle          Addr (Maybe BufferMode) Bool
  47   | WriteHandle         Addr (Maybe BufferMode) Bool
  48   | AppendHandle        Addr (Maybe BufferMode) Bool
  49   | ReadWriteHandle     Addr (Maybe BufferMode) Bool
  50
  51 instance Eq Handle{-partain:????-}
  52
  53 {-# INLINE newHandle   #-}
  54 {-# INLINE readHandle  #-}
  55 {-# INLINE writeHandle #-}
  56
  57 newHandle   :: Handle__ -> IO Handle
  58 readHandle  :: Handle   -> IO Handle__
  59 writeHandle :: Handle -> Handle__ -> IO ()
  60
  61 #if defined(__CONCURRENT_HASKELL__)
  62
  63 type Handle = MVar Handle__
  64
  65 newHandle   = newMVar
  66 readHandle  = takeMVar
  67 writeHandle = putMVar
  68
  69 #else
  70 type Handle = MutableVar RealWorld Handle__
  71
  72 newHandle v     = stToIO (newVar   v)
  73 readHandle h    = stToIO (readVar  h)
  74 writeHandle h v = stToIO (writeVar h v)
  75
  76 #endif {- __CONCURRENT_HASKELL__ -}
  77
  78 type FilePath = String
  79
  80 filePtr :: Handle__ -> Addr
  81 filePtr (SemiClosedHandle fp _)  = fp
  82 filePtr (ReadHandle fp _ _)      = fp
  83 filePtr (WriteHandle fp _ _)     = fp
  84 filePtr (AppendHandle fp _ _)    = fp
  85 filePtr (ReadWriteHandle fp _ _) = fp
  86
  87 bufferMode :: Handle__ -> Maybe BufferMode
  88 bufferMode (ReadHandle _ m _)      = m
  89 bufferMode (WriteHandle _ m _)     = m
  90 bufferMode (AppendHandle _ m _)    = m
  91 bufferMode (ReadWriteHandle _ m _) = m
  92
  93 markHandle :: Handle__ -> Handle__
  94 markHandle h@(ReadHandle fp m b)
  95   | b = h
  96   | otherwise = ReadHandle fp m True
  97 markHandle h@(WriteHandle fp m b)
  98   | b = h
  99   | otherwise = WriteHandle fp m True
 100 markHandle h@(AppendHandle fp m b)
 101   | b = h
 102   | otherwise = AppendHandle fp m True
 103 markHandle h@(ReadWriteHandle fp m b)
 104   | b = h
 105   | otherwise = ReadWriteHandle fp m True
 106
 107 -------------------------------------------
 108
 109 stdin, stdout, stderr :: Handle
 110
 111 stdin = unsafePerformPrimIO (
 112     _ccall_ getLock (``stdin''::Addr) 0         >>= \ rc ->
 113     (case rc of
 114        0 -> new_handle ClosedHandle
 115        1 -> new_handle (ReadHandle ``stdin'' Nothing False)
 116        _ -> constructError "stdin"              >>= \ ioError ->
 117             new_handle (ErrorHandle ioError)
 118     )                                           >>= \ handle ->
 119     returnPrimIO handle
 120   )
 121   where
 122     new_handle x = ioToST (newHandle x)
 123
 124 stdout = unsafePerformPrimIO (
 125     _ccall_ getLock (``stdout''::Addr) 1        >>= \ rc ->
 126     (case rc of
 127        0 -> new_handle ClosedHandle
 128        1 -> new_handle (WriteHandle ``stdout'' Nothing False)
 129        _ -> constructError "stdout"             >>= \ ioError ->
 130             new_handle (ErrorHandle ioError)
 131     )                                           >>= \ handle ->
 132     returnPrimIO handle
 133   )
 134   where
 135     new_handle x = ioToST (newHandle x)
 136
 137 stderr = unsafePerformPrimIO (
 138     _ccall_ getLock (``stderr''::Addr) 1        >>= \ rc ->
 139     (case rc of
 140        0 -> new_handle ClosedHandle
 141        1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False)
 142        _ -> constructError "stderr"             >>= \ ioError ->
 143             new_handle (ErrorHandle ioError)
 144     )                                           >>= \ handle ->
 145     returnPrimIO handle
 146   )
 147   where
 148     new_handle x = ioToST (newHandle x)
 149 {-
 150 \end{code}
 151
 152 Three handles are allocated during program initialisation.  The first
 153 two manage input or output from the Haskell program's standard input
 154 or output channel respectively.  The third manages output to the
 155 standard error channel. These handles are initially open.
 156
 157 \subsubsection[OpeningClosing]{Opening and Closing Files}
 158
 159 \begin{code}
 160 -}
 161 data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
 162                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 163
 164 openFile :: FilePath -> IOMode -> IO Handle
 165
 166 openFile f m =
 167     stToIO (_ccall_ openFile f m')                  >>= \ ptr ->
 168     if ptr /= ``NULL'' then
 169         newHandle (htype ptr Nothing False)
 170     else
 171         stToIO (constructError "openFile")          >>= \ ioError ->
 172         let
 173             improved_error -- a HACK, I guess
 174               = case ioError of
 175                   AlreadyExists    msg -> AlreadyExists    (msg ++ ": " ++ f)
 176                   NoSuchThing      msg -> NoSuchThing      (msg ++ ": " ++ f)
 177                   PermissionDenied msg -> PermissionDenied (msg ++ ": " ++ f)
 178                   _                    -> ioError
 179         in
 180         fail improved_error
 181   where
 182     m' = case m of
 183            ReadMode      -> "r"
 184            WriteMode     -> "w"
 185            AppendMode    -> "a"
 186            ReadWriteMode -> "r+"
 187
 188     htype = case m of
 189               ReadMode      -> ReadHandle
 190               WriteMode     -> WriteHandle
 191               AppendMode    -> AppendHandle
 192               ReadWriteMode -> ReadWriteHandle
 193 {-
 194 \end{code}
 195
 196 Computation $openFile file mode$ allocates and returns a new, open
 197 handle to manage the file {\em file}.  It manages input if {\em mode}
 198 is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
 199 and both input and output if mode is $ReadWriteMode$.
 200
 201 If the file does not exist and it is opened for output, it should be
 202 created as a new file.  If {\em mode} is $WriteMode$ and the file
 203 already exists, then it should be truncated to zero length.  The
 204 handle is positioned at the end of the file if {\em mode} is
 205 $AppendMode$, and otherwise at the beginning (in which case its
 206 internal position is 0).
 207
 208 Implementations should enforce, locally to the Haskell process,
 209 multiple-reader single-writer locking on files, which is to say that
 210 there may either be many handles on the same file which manage input,
 211 or just one handle on the file which manages output.  If any open or
 212 semi-closed handle is managing a file for output, no new handle can be
 213 allocated for that file.  If any open or semi-closed handle is
 214 managing a file for input, new handles can only be allocated if they
 215 do not manage output.
 216
 217 Two files are the same if they have the same absolute name.  An
 218 implementation is free to impose stricter conditions.
 219
 220 \begin{code}
 221 -}
 222 hClose :: Handle -> IO ()
 223
 224 hClose handle =
 225     readHandle handle                               >>= \ htype ->
 226     writeHandle handle ClosedHandle                 >>
 227     case htype of
 228       ErrorHandle ioError ->
 229           fail ioError
 230       ClosedHandle ->
 231           fail (IllegalOperation "handle is closed")
 232       SemiClosedHandle fp (buf,_) ->
 233           (if buf /= ``NULL'' then
 234               _ccall_ free buf
 235            else
 236               returnPrimIO ())                      `stThen` \ () ->
 237           if fp /= ``NULL'' then
 238               _ccall_ closeFile fp                  `stThen` \ rc ->
 239               if rc == 0 then
 240                   return ()
 241               else
 242                   constructErrorAndFail "hClose"
 243           else
 244               return ()
 245       other ->
 246           _ccall_ closeFile (filePtr other)         `stThen` \ rc ->
 247           if rc == 0 then
 248               return ()
 249           else
 250               constructErrorAndFail "hClose"
 251 {-
 252 \end{code}
 253
 254 Computation $hClose hdl$ makes handle {\em hdl} closed.  Before the
 255 computation finishes, any items buffered for output and not already
 256 sent to the operating system are flushed as for $flush$.
 257
 258 \subsubsection[EOF]{Detecting the End of Input}
 259
 260 \begin{code}
 261 -}
 262 hFileSize :: Handle -> IO Integer
 263 hFileSize handle =
 264     readHandle handle                               >>= \ htype ->
 265     case htype of
 266       ErrorHandle ioError ->
 267           writeHandle handle htype                          >>
 268           fail ioError
 269       ClosedHandle ->
 270           writeHandle handle htype                          >>
 271           fail (IllegalOperation "handle is closed")
 272       SemiClosedHandle _ _ ->
 273           writeHandle handle htype                          >>
 274           fail (IllegalOperation "handle is closed")
 275       other ->
 276           -- HACK!  We build a unique MP_INT of the right shape to hold
 277           -- a single unsigned word, and we let the C routine change the data bits
 278           _casm_ ``%r = 1;''                        `stThen` \ (I# hack#) ->
 279           case int2Integer# hack# of
 280             result@(J# _ _ d#) ->
 281                 let
 282                     bogus_bounds = (error "fileSize"::(Int,Int))
 283                 in
 284                 _ccall_ fileSize (filePtr other) (ByteArray bogus_bounds d#)
 285                                                     `stThen` \ rc ->
 286                writeHandle handle htype             >>
 287                if rc == 0 then
 288                    return result
 289                else
 290                     constructErrorAndFail "hFileSize"
 291 {-
 292 \end{code}
 293
 294 For a handle {\em hdl} which attached to a physical file, $hFileSize
 295 hdl$ returns the size of {\em hdl} in terms of the number of items
 296 which can be read from {\em hdl}.
 297
 298 \begin{code}
 299 -}
 300 hIsEOF :: Handle -> IO Bool
 301 hIsEOF handle =
 302     readHandle handle                               >>= \ htype ->
 303     case htype of
 304       ErrorHandle ioError ->
 305           writeHandle handle htype                  >>
 306           fail ioError
 307       ClosedHandle ->
 308           writeHandle handle htype                  >>
 309           fail (IllegalOperation "handle is closed")
 310       SemiClosedHandle _ _ ->
 311           writeHandle handle htype                  >>
 312           fail (IllegalOperation "handle is closed")
 313       WriteHandle _ _ _ ->
 314           writeHandle handle htype                  >>
 315           fail (IllegalOperation "handle is not open for reading")
 316       AppendHandle _ _ _ ->
 317           writeHandle handle htype                  >>
 318           fail (IllegalOperation "handle is not open for reading")
 319       other ->
 320           _ccall_ fileEOF (filePtr other)           `stThen` \ rc ->
 321           writeHandle handle (markHandle htype)     >>
 322           case rc of
 323             0 -> return False
 324             1 -> return True
 325             _ -> constructErrorAndFail "hIsEOF"
 326
 327 isEOF :: IO Bool
 328 isEOF = hIsEOF stdin
 329 {-
 330 \end{code}
 331
 332 For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns
 333 $True$ if no further input can be taken from {\em hdl} or for a
 334 physical file, if the current I/O position is equal to the length of
 335 the file.  Otherwise, it returns $False$.
 336
 337 \subsubsection[Buffering]{Buffering Operations}
 338
 339 Three kinds of buffering are supported: line-buffering,
 340 block-buffering or no-buffering.  These modes have the following effects.
 341 For output, items are written out from the internal buffer
 342 according to the buffer mode:
 343 \begin{itemize}
 344 \item[line-buffering]  the entire output buffer is written
 345 out whenever a newline is output, the output buffer overflows,
 346 a flush is issued, or the handle is closed.
 347
 348 \item[block-buffering] the entire output buffer is written out whenever
 349 it overflows, a flush is issued, or the handle
 350 is closed.
 351
 352 \item[no-buffering] output is written immediately, and never stored
 353 in the output buffer.
 354 \end{itemize}
 355
 356 The output buffer is emptied as soon as it has been written out.
 357
 358 Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 359 \begin{itemize}
 360 \item[line-buffering] when the input buffer for {\em hdl} is not empty,
 361 the next item is obtained from the buffer;
 362 otherwise, when the input buffer is empty,
 363 characters up to and including the next newline
 364 character are read into the buffer.  No characters
 365 are available until the newline character is
 366 available.
 367 \item[block-buffering] when the input buffer for {\em hdl} becomes empty,
 368 the next block of data is read into this buffer.
 369 \item[no-buffering] the next input item is read and returned.
 370 \end{itemize}
 371 For most implementations, physical files will normally be block-buffered
 372 and terminals will normally be line-buffered.
 373
 374 \begin{code}
 375 -}
 376 data BufferMode  =  NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 377                     deriving (Eq, Ord, Read, Show)
 378
 379 hSetBuffering :: Handle -> BufferMode -> IO ()
 380
 381 hSetBuffering handle mode =
 382     case mode of
 383       (BlockBuffering (Just n))
 384         | n <= 0 -> fail (InvalidArgument "illegal buffer size")
 385       other ->
 386           readHandle handle                         >>= \ htype ->
 387           if isMarked htype then
 388               writeHandle handle htype              >>
 389               fail (UnsupportedOperation "can't set buffering for a dirty handle")
 390           else
 391               case htype of
 392                 ErrorHandle ioError ->
 393                     writeHandle handle htype        >>
 394                     fail ioError
 395                 ClosedHandle ->
 396                     writeHandle handle htype        >>
 397                     fail (IllegalOperation "handle is closed")
 398                 SemiClosedHandle _ _ ->
 399                     writeHandle handle htype        >>
 400                     fail (IllegalOperation "handle is closed")
 401                 other ->
 402                     _ccall_ setBuffering (filePtr other) bsize
 403                                                     `stThen` \ rc ->
 404                     if rc == 0 then
 405                         writeHandle handle ((hcon other) (filePtr other) (Just mode) True)
 406                                                     >>
 407                         return ()
 408                     else
 409                         writeHandle handle htype         >>
 410                         constructErrorAndFail "hSetBuffering"
 411
 412   where
 413     isMarked :: Handle__ -> Bool
 414     isMarked (ReadHandle fp m b) = b
 415     isMarked (WriteHandle fp m b) = b
 416     isMarked (AppendHandle fp m b) = b
 417     isMarked (ReadWriteHandle fp m b) = b
 418
 419     bsize :: Int
 420     bsize = case mode of
 421               NoBuffering -> 0
 422               LineBuffering -> -1
 423               BlockBuffering Nothing -> -2
 424               BlockBuffering (Just n) -> n
 425
 426     hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
 427     hcon (ReadHandle _ _ _) = ReadHandle
 428     hcon (WriteHandle _ _ _) = WriteHandle
 429     hcon (AppendHandle _ _ _) = AppendHandle
 430     hcon (ReadWriteHandle _ _ _) = ReadWriteHandle
 431 {-
 432 \end{code}
 433
 434 Computation $hSetBuffering hdl mode$ sets the mode of buffering for
 435 handle {\em hdl} on subsequent reads and writes.
 436
 437 \begin{itemize}
 438 \item
 439 If {\em mode} is $LineBuffering$, line-buffering should be
 440 enabled if possible.
 441 \item
 442 If {\em mode} is $BlockBuffering$ {\em size}, then block-buffering
 443 should be enabled if possible.  The size of the buffer is {\em n} items
 444 if {\em size} is $Just${\em n} and is otherwise implementation-dependent.
 445 \item
 446 If {\em mode} is $NoBuffering$, then buffering is disabled if possible.
 447 \end{itemize}
 448
 449 If the buffer mode is changed from $BlockBuffering$ or $LineBuffering$
 450 to $NoBuffering$, then any items in the output buffer are written to
 451 the device, and any items in the input buffer are discarded.  The
 452 default buffering mode when a handle is opened is
 453 implementation-dependent and may depend on the object which is
 454 attached to that handle.
 455
 456 \begin{code}
 457 -}
 458 hFlush :: Handle -> IO ()
 459 hFlush handle =
 460     readHandle handle                               >>= \ htype ->
 461     case htype of
 462       ErrorHandle ioError ->
 463           writeHandle handle htype                  >>
 464           fail ioError
 465       ClosedHandle ->
 466           writeHandle handle htype                  >>
 467           fail (IllegalOperation "handle is closed")
 468       SemiClosedHandle _ _ ->
 469           writeHandle handle htype                  >>
 470           fail (IllegalOperation "handle is closed")
 471       other ->
 472           _ccall_ flushFile (filePtr other)         `stThen` \ rc ->
 473           writeHandle handle (markHandle htype)   >>
 474                if rc == 0 then
 475                    return ()
 476                else
 477                     constructErrorAndFail "hFlush"
 478 {-
 479 \end{code}
 480
 481 Computation $flush hdl$ causes any items
 482 buffered for output in handle {\em hdl} to be sent immediately to
 483 the operating system.
 484
 485 \subsubsection[Seeking]{Repositioning Handles}
 486
 487 \begin{code}
 488 -}
 489 data HandlePosn = HandlePosn Handle Int
 490
 491 instance Eq HandlePosn{-partain-}
 492
 493 hGetPosn :: Handle -> IO HandlePosn
 494 hGetPosn handle =
 495     readHandle handle                               >>= \ htype ->
 496     case htype of
 497       ErrorHandle ioError ->
 498           writeHandle handle htype                  >>
 499           fail ioError
 500       ClosedHandle ->
 501           writeHandle handle htype                  >>
 502           fail (IllegalOperation "handle is closed")
 503       SemiClosedHandle _ _ ->
 504           writeHandle handle htype                  >>
 505           fail (IllegalOperation "handle is closed")
 506       other ->
 507           _ccall_ getFilePosn (filePtr other)      `stThen` \ posn ->
 508           writeHandle handle htype                  >>
 509           if posn /= -1 then
 510               return (HandlePosn handle posn)
 511           else
 512               constructErrorAndFail "hGetPosn"
 513
 514 hSetPosn :: HandlePosn -> IO ()
 515 hSetPosn (HandlePosn handle posn) =
 516     readHandle handle                               >>= \ htype ->
 517     case htype of
 518       ErrorHandle ioError ->
 519           writeHandle handle htype                  >>
 520           fail ioError
 521       ClosedHandle ->
 522           writeHandle handle htype                  >>
 523           fail (IllegalOperation "handle is closed")
 524       SemiClosedHandle _ _ ->
 525           writeHandle handle htype                  >>
 526           fail (IllegalOperation "handle is closed")
 527       AppendHandle _ _ _ ->
 528           writeHandle handle htype                  >>
 529           fail (IllegalOperation "handle is not seekable")
 530       other ->
 531           _ccall_ setFilePosn (filePtr other) posn `stThen` \ rc ->
 532           writeHandle handle (markHandle htype)    >>
 533                if rc == 0 then
 534                    return ()
 535                else
 536                    constructErrorAndFail "hSetPosn"
 537 {-
 538 \end{code}
 539
 540 Computation $hGetPosn hdl$ returns the current I/O
 541 position of {\em hdl} as an abstract position.  Computation
 542 $hSetPosn p$ sets the position of {\em hdl}
 543 to a previously obtained position {\em p}.
 544
 545 \begin{code}
 546 -}
 547 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 548                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 549
 550 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 551 hSeek handle mode offset@(J# _ s# d#) =
 552     readHandle handle                               >>= \ htype ->
 553     case htype of
 554       ErrorHandle ioError ->
 555           writeHandle handle htype                  >>
 556           fail ioError
 557       ClosedHandle ->
 558           writeHandle handle htype                  >>
 559           fail (IllegalOperation "handle is closed")
 560       SemiClosedHandle _ _ ->
 561           writeHandle handle htype                  >>
 562           fail (IllegalOperation "handle is closed")
 563       AppendHandle _ _ _ ->
 564           writeHandle handle htype                  >>
 565           fail (IllegalOperation "handle is not seekable")
 566       other ->
 567           _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#)
 568                                                     `stThen` \ rc ->
 569           writeHandle handle (markHandle htype)   >>
 570                if rc == 0 then
 571                    return ()
 572                else
 573                     constructErrorAndFail "hSeek"
 574   where
 575     whence :: Int
 576     whence = case mode of
 577                AbsoluteSeek -> ``SEEK_SET''
 578                RelativeSeek -> ``SEEK_CUR''
 579                SeekFromEnd -> ``SEEK_END''
 580 {-
 581 \end{code}
 582
 583 Computation $hSeek hdl mode i$ sets the position of handle
 584 {\em hdl} depending on $mode$.  If {\em mode} is
 585 \begin{itemize}
 586 \item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}.
 587 \item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from
 588 the current position.
 589 \item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from
 590 the end of the file.
 591 \item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from
 592 the beginning of the file.
 593 \end{itemize}
 594
 595 Some handles may not be seekable $hIsSeekable$, or only support a
 596 subset of the possible positioning operations (e.g. it may only be
 597 possible to seek to the end of a tape, or to a positive offset from
 598 the beginning or current position).
 599
 600 It is not possible to set a negative I/O position, or for a physical
 601 file, an I/O position beyond the current end-of-file.
 602
 603 \subsubsection[Query]{Handle Properties}
 604
 605 \begin{code}
 606 -}
 607 hIsOpen :: Handle -> IO Bool
 608 hIsOpen handle =
 609     readHandle handle                               >>= \ htype ->
 610     case htype of
 611       ErrorHandle ioError ->
 612           writeHandle handle htype                  >>
 613           fail ioError
 614       ClosedHandle ->
 615           writeHandle handle htype                  >>
 616           return False
 617       SemiClosedHandle _ _ ->
 618           writeHandle handle htype                  >>
 619           return False
 620       other ->
 621           writeHandle handle htype                  >>
 622           return True
 623
 624 hIsClosed :: Handle -> IO Bool
 625 hIsClosed handle =
 626     readHandle handle                               >>= \ htype ->
 627     case htype of
 628       ErrorHandle ioError ->
 629           writeHandle handle htype                  >>
 630           fail ioError
 631       ClosedHandle ->
 632           writeHandle handle htype                  >>
 633           return True
 634       other ->
 635           writeHandle handle htype                  >>
 636           return False
 637
 638 hIsReadable :: Handle -> IO Bool
 639 hIsReadable handle =
 640     readHandle handle                               >>= \ htype ->
 641     case htype of
 642       ErrorHandle ioError ->
 643           writeHandle handle htype                  >>
 644           fail ioError
 645       ClosedHandle ->
 646           writeHandle handle htype                  >>
 647           fail (IllegalOperation "handle is closed")
 648       SemiClosedHandle _ _ ->
 649           writeHandle handle htype                  >>
 650           fail (IllegalOperation "handle is closed")
 651       other ->
 652           writeHandle handle htype                  >>
 653           return (isReadable other)
 654   where
 655     isReadable (ReadHandle _ _ _) = True
 656     isReadable (ReadWriteHandle _ _ _) = True
 657     isReadable _ = False
 658
 659 hIsWritable :: Handle -> IO Bool
 660 hIsWritable handle =
 661     readHandle handle                       >>= \ htype ->
 662     case htype of
 663       ErrorHandle ioError ->
 664           writeHandle handle htype          >>
 665           fail ioError
 666       ClosedHandle ->
 667           writeHandle handle htype          >>
 668           fail (IllegalOperation "handle is closed")
 669       SemiClosedHandle _ _ ->
 670           writeHandle handle htype          >>
 671           fail (IllegalOperation "handle is closed")
 672       other ->
 673           writeHandle handle htype          >>
 674           return (isWritable other)
 675   where
 676     isWritable (AppendHandle _ _ _) = True
 677     isWritable (WriteHandle _ _ _) = True
 678     isWritable (ReadWriteHandle _ _ _) = True
 679     isWritable _ = False
 680
 681 getBufferMode :: Handle__ -> PrimIO Handle__
 682 getBufferMode htype =
 683     case bufferMode htype of
 684       Just x -> returnPrimIO htype
 685       Nothing ->
 686         _ccall_ getBufferMode (filePtr htype)       `thenPrimIO` \ rc ->
 687         let
 688             mode =
 689                 case rc of
 690                   0  -> Just NoBuffering
 691                   -1 -> Just LineBuffering
 692                   -2 -> Just (BlockBuffering Nothing)
 693                   -3 -> Nothing
 694                   n  -> Just (BlockBuffering (Just n))
 695         in
 696         returnPrimIO (case htype of
 697           ReadHandle      fp _ b -> ReadHandle      fp mode b
 698           WriteHandle     fp _ b -> WriteHandle     fp mode b
 699           AppendHandle    fp _ b -> AppendHandle    fp mode b
 700           ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b)
 701
 702 hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int)
 703 hIsBlockBuffered handle =
 704     readHandle handle                               >>= \ htype ->
 705     case htype of
 706       ErrorHandle ioError ->
 707           writeHandle handle htype                  >>
 708           fail ioError
 709       ClosedHandle ->
 710           writeHandle handle htype                  >>
 711           fail (IllegalOperation "handle is closed")
 712       SemiClosedHandle _ _ ->
 713           writeHandle handle htype                  >>
 714           fail (IllegalOperation "handle is closed")
 715       other ->
 716           getBufferMode other                       `stThen` \ other ->
 717           case bufferMode other of
 718             Just (BlockBuffering size) ->
 719                 writeHandle handle other            >>
 720                 return (True, size)
 721             Just _ ->
 722                 writeHandle handle other            >>
 723                 return (False, Nothing)
 724             Nothing ->
 725                 constructErrorAndFail "hIsBlockBuffered"
 726
 727 hIsLineBuffered :: Handle -> IO Bool
 728 hIsLineBuffered handle =
 729     readHandle handle                               >>= \ htype ->
 730     case htype of
 731       ErrorHandle ioError ->
 732           writeHandle handle htype                  >>
 733           fail ioError
 734       ClosedHandle ->
 735           writeHandle handle htype                  >>
 736           fail (IllegalOperation "handle is closed")
 737       SemiClosedHandle _ _ ->
 738           writeHandle handle htype                  >>
 739           fail (IllegalOperation "handle is closed")
 740       other ->
 741           getBufferMode other                       `stThen` \ other ->
 742           case bufferMode other of
 743             Just LineBuffering ->
 744                 writeHandle handle other            >>
 745                 return True
 746             Just _ ->
 747                 writeHandle handle other            >>
 748                 return False
 749             Nothing ->
 750                 constructErrorAndFail "hIsLineBuffered"
 751
 752 hIsNotBuffered :: Handle -> IO Bool
 753 hIsNotBuffered handle =
 754     readHandle handle                               >>= \ htype ->
 755     case htype of
 756       ErrorHandle ioError ->
 757           writeHandle handle htype                  >>
 758           fail ioError
 759       ClosedHandle ->
 760           writeHandle handle htype                  >>
 761           fail (IllegalOperation "handle is closed")
 762       SemiClosedHandle _ _ ->
 763           writeHandle handle htype                  >>
 764           fail (IllegalOperation "handle is closed")
 765       other ->
 766           getBufferMode other                       `stThen` \ other ->
 767           case bufferMode other of
 768             Just NoBuffering ->
 769                 writeHandle handle other            >>
 770                 return True
 771             Just _ ->
 772                 writeHandle handle other            >>
 773                 return False
 774             Nothing ->
 775                 constructErrorAndFail "hIsNotBuffered"
 776
 777 hGetBuffering :: Handle -> IO BufferMode
 778 hGetBuffering hndl =
 779     readHandle hndl                                 >>= \ htype ->
 780     case htype of
 781       ErrorHandle ioError ->
 782           writeHandle hndl htype                    >>
 783           fail ioError
 784       ClosedHandle ->
 785           writeHandle hndl htype                    >>
 786           fail (IllegalOperation "handle is closed")
 787       SemiClosedHandle _ _ ->
 788           writeHandle hndl htype                    >>
 789           fail (IllegalOperation "handle is closed")
 790       other ->
 791           getBufferMode other                       `stThen` \ other ->
 792           case bufferMode other of
 793             Just v ->
 794                 writeHandle hndl other              >>
 795                 return v
 796             Nothing ->
 797                 constructErrorAndFail "hGetBuffering"
 798
 799 hIsSeekable :: Handle -> IO Bool
 800 hIsSeekable handle =
 801     readHandle handle                               >>= \ htype ->
 802     case htype of
 803       ErrorHandle ioError ->
 804           writeHandle handle htype                  >>
 805           fail ioError
 806       ClosedHandle ->
 807           writeHandle handle htype                  >>
 808           fail (IllegalOperation "handle is closed")
 809       SemiClosedHandle _ _ ->
 810           writeHandle handle htype                  >>
 811           fail (IllegalOperation "handle is closed")
 812       AppendHandle _ _ _ ->
 813           writeHandle handle htype                  >>
 814           return False
 815       other ->
 816           _ccall_ seekFileP (filePtr other)         `stThen` \ rc ->
 817           writeHandle handle htype                  >>
 818           case rc of
 819             0 -> return False
 820             1 -> return True
 821             _ -> constructErrorAndFail "hIsSeekable"
 822 {-
 823 \end{code}
 824
 825 A number of operations return information about the properties of a
 826 handle.  Each of these operations returns $True$ if the
 827 handle has the specified property, and $False$
 828 otherwise.
 829
 830 Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
 831 {\em hdl} is not block-buffered.  Otherwise it returns
 832 $( True, size )$, where {\em size} is $Nothing$ for default buffering, and
 833 $( Just n )$ for block-buffering of {\em n} bytes.
 834 -}
 835
 836 -------------------------------------------------------------------
 837 data IOError
 838   = AlreadyExists               String
 839   | HardwareFault               String
 840   | IllegalOperation            String
 841   | InappropriateType           String
 842   | Interrupted                 String
 843   | InvalidArgument             String
 844   | NoSuchThing                 String
 845   | OtherError                  String
 846   | PermissionDenied            String
 847   | ProtocolError               String
 848   | ResourceBusy                String
 849   | ResourceExhausted           String
 850   | ResourceVanished            String
 851   | SystemError                 String
 852   | TimeExpired                 String
 853   | UnsatisfiedConstraints      String
 854   | UnsupportedOperation        String
 855   | UserError                   String
 856   | EOF
 857
 858 instance Eq IOError where
 859     -- I don't know what the (pointless) idea is here,
 860     -- presumably just compare them by their tags (WDP)
 861     a == b = tag a == tag b
 862       where
 863         tag (AlreadyExists _)           = (1::Int)
 864         tag (HardwareFault _)           = 2
 865         tag (IllegalOperation _)        = 3
 866         tag (InappropriateType _)       = 4
 867         tag (Interrupted _)             = 5
 868         tag (InvalidArgument _)         = 6
 869         tag (NoSuchThing _)             = 7
 870         tag (OtherError _)              = 8
 871         tag (PermissionDenied _)        = 9
 872         tag (ProtocolError _)           = 10
 873         tag (ResourceBusy _)            = 11
 874         tag (ResourceExhausted _)       = 12
 875         tag (ResourceVanished _)        = 13
 876         tag (SystemError _)             = 14
 877         tag (TimeExpired _)             = 15
 878         tag (UnsatisfiedConstraints _)  = 16
 879         tag (UnsupportedOperation _)    = 17
 880         tag (UserError _)               = 18
 881         tag EOF                         = 19
 882
 883 instance Show IOError where
 884     showsPrec p (AlreadyExists s)       = show2 "AlreadyExists: "       s
 885     showsPrec p (HardwareFault s)       = show2 "HardwareFault: "       s
 886     showsPrec p (IllegalOperation s)    = show2 "IllegalOperation: "    s
 887     showsPrec p (InappropriateType s)   = show2 "InappropriateType: "   s
 888     showsPrec p (Interrupted s)         = show2 "Interrupted: "         s
 889     showsPrec p (InvalidArgument s)     = show2 "InvalidArgument: "     s
 890     showsPrec p (NoSuchThing s)         = show2 "NoSuchThing: "         s
 891     showsPrec p (OtherError s)          = show2 "OtherError: "          s
 892     showsPrec p (PermissionDenied s)    = show2 "PermissionDenied: "    s
 893     showsPrec p (ProtocolError s)       = show2 "ProtocolError: "       s
 894     showsPrec p (ResourceBusy s)        = show2 "ResourceBusy: "        s
 895     showsPrec p (ResourceExhausted s)   = show2 "ResourceExhausted: "   s
 896     showsPrec p (ResourceVanished s)    = show2 "ResourceVanished: "    s
 897     showsPrec p (SystemError s)         = show2 "SystemError: "         s
 898     showsPrec p (TimeExpired s)         = show2 "TimeExpired: "         s
 899     showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s
 900     showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s
 901     showsPrec p (UserError s)           = showString s
 902     showsPrec p EOF                     = showString "EOF"
 903
 904 show2 x y = showString x . showString y
 905
 906 {-
 907
 908 The @String@ part of an @IOError@ is platform-dependent.  However, to
 909 provide a uniform mechanism for distinguishing among errors within
 910 these broad categories, each platform-specific standard shall specify
 911 the exact strings to be used for particular errors.  For errors not
 912 explicitly mentioned in the standard, any descriptive string may be
 913 used.
 914
 915   SOF 4/96 - added argument to indicate function that flagged error
 916 -}
 917 constructErrorAndFail :: String -> IO a
 918 constructError        :: String -> PrimIO IOError
 919
 920 constructErrorAndFail call_site
 921   = stToIO (constructError call_site) >>= \ io_error ->
 922     fail io_error
 923
 924 constructError call_site
 925   = _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
 926     _casm_ ``%r = ghc_errstr;''     >>= \ str ->
 927     let
 928         msg = call_site ++ ':' : ' ' : GHCps.unpackPS (GHCps.packCString str)
 929     in
 930     return (case errtype# of
 931         ERR_ALREADYEXISTS#              -> AlreadyExists msg
 932         ERR_HARDWAREFAULT#              -> HardwareFault msg
 933         ERR_ILLEGALOPERATION#           -> IllegalOperation msg
 934         ERR_INAPPROPRIATETYPE#          -> InappropriateType msg
 935         ERR_INTERRUPTED#                -> Interrupted msg
 936         ERR_INVALIDARGUMENT#            -> InvalidArgument msg
 937         ERR_NOSUCHTHING#                -> NoSuchThing msg
 938         ERR_OTHERERROR#                 -> OtherError msg
 939         ERR_PERMISSIONDENIED#           -> PermissionDenied msg
 940         ERR_PROTOCOLERROR#              -> ProtocolError msg
 941         ERR_RESOURCEBUSY#               -> ResourceBusy msg
 942         ERR_RESOURCEEXHAUSTED#          -> ResourceExhausted msg
 943         ERR_RESOURCEVANISHED#           -> ResourceVanished msg
 944         ERR_SYSTEMERROR#                -> SystemError msg
 945         ERR_TIMEEXPIRED#                -> TimeExpired msg
 946         ERR_UNSATISFIEDCONSTRAINTS#     -> UnsatisfiedConstraints msg
 947         ERR_UNSUPPORTEDOPERATION#       -> UnsupportedOperation msg
 948         ERR_EOF#                        -> EOF
 949         _                               -> OtherError "bad error construct"
 950     )