ghc/lib/std/PrelHandle.lhs

   1
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[PrelHandle]{Module @PrelHandle@}
   6
   7 This module defines Haskell {\em handles} and the basic operations
   8 which are supported for them.
   9
  10 \begin{code}
  11 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
  12 #include "cbits/error.h"
  13
  14 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
  15 module PrelHandle where
  16
  17 import PrelBase
  18 import PrelAddr         ( Addr, nullAddr )
  19 import PrelArr          ( newVar, readVar, writeVar, ByteArray(..) )
  20 import PrelRead         ( Read )
  21 import PrelList         ( span )
  22 import PrelIOBase
  23 import PrelException
  24 import PrelMaybe        ( Maybe(..) )
  25 import PrelEnum
  26 import PrelNum
  27 import PrelShow
  28 import PrelAddr         ( Addr, nullAddr )
  29 import PrelNum          ( toInteger, toBig )
  30 import PrelPack         ( packString )
  31 import PrelWeak         ( addForeignFinalizer )
  32 import Ix
  33
  34 #if __CONCURRENT_HASKELL__
  35 import PrelConc
  36 #endif
  37
  38 #ifndef __PARALLEL_HASKELL__
  39 import PrelForeign  ( makeForeignObj )
  40 #endif
  41
  42 #endif /* ndef(__HUGS__) */
  43
  44 #ifdef __HUGS__
  45 #define cat2(x,y)  x##y
  46 #define CCALL(fun) cat2(prim_,fun)
  47 #define __CONCURRENT_HASKELL__
  48 #define stToIO id
  49 #define sizeof_int64 8
  50 #else
  51 #define CCALL(fun) _ccall_ fun
  52 #define const_BUFSIZ ``BUFSIZ''
  53 #define primPackString
  54 #endif
  55
  56 #ifndef __PARALLEL_HASKELL__
  57 #define FILE_OBJECT         ForeignObj
  58 #else
  59 #define FILE_OBJECT         Addr
  60 #endif
  61 \end{code}
  62
  63 %*********************************************************
  64 %*                                                      *
  65 \subsection{Types @Handle@, @Handle__@}
  66 %*                                                      *
  67 %*********************************************************
  68
  69 The @Handle@ and @Handle__@ types are defined in @IOBase@.
  70
  71 \begin{code}
  72 {-# INLINE newHandle   #-}
  73 {-# INLINE withHandle #-}
  74 {-# INLINE writeHandle #-}
  75 newHandle     :: Handle__ -> IO Handle
  76 withHandle    :: Handle   -> (Handle__ -> IO a) -> IO a
  77 writeHandle   :: Handle -> Handle__ -> IO ()
  78
  79 #if defined(__CONCURRENT_HASKELL__)
  80
  81 -- Use MVars for concurrent Haskell
  82 newHandle hc  = newMVar hc      >>= \ h ->
  83                 return (Handle h)
  84
  85   -- withHandle grabs the handle lock, performs
  86   -- some operation over it, making sure that we
  87   -- unlock & reset the handle state should an
  88   -- exception occur while performing said op.
  89 withHandle (Handle h) act = do
  90    h_ <- takeMVar h
  91    v  <- catchNonIO (act h_) (\ ex -> putMVar h h_ >> throw ex)
  92    return v
  93
  94 writeHandle (Handle h) hc = putMVar h hc
  95 #else
  96
  97 -- Use ordinary MutableVars for non-concurrent Haskell
  98 newHandle hc  = stToIO (newVar  hc      >>= \ h ->
  99                         return (Handle h))
 100
 101    -- of questionable value to install this exception
 102    -- handler, but let's do it in the non-concurrent
 103    -- case too, for now.
 104 withHandle (Handle h) act = do
 105    h_ <- stToIO (readVar h)
 106    v  <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
 107    return v
 108
 109 writeHandle (Handle h) hc = stToIO (writeVar h hc)
 110 #endif
 111 \end{code}
 112
 113 nullFile__ is only used for closed handles, plugging it in as a null
 114 file object reference.
 115
 116 \begin{code}
 117 nullFile__ :: FILE_OBJECT
 118 nullFile__ =
 119 #ifndef __PARALLEL_HASKELL__
 120     unsafePerformIO (makeForeignObj nullAddr)
 121 #else
 122     nullAddr
 123 #endif
 124
 125
 126 mkClosedHandle__ :: Handle__
 127 mkClosedHandle__ =
 128   Handle__
 129            nullFile__
 130            ClosedHandle
 131            NoBuffering
 132            "closed file"
 133
 134 mkErrorHandle__ :: IOError -> Handle__
 135 mkErrorHandle__ ioe =
 136   Handle__
 137            nullFile__
 138            (ErrorHandle ioe)
 139            NoBuffering
 140            "error handle"
 141 \end{code}
 142
 143 %*********************************************************
 144 %*                                                      *
 145 \subsection{Handle Finalizers}
 146 %*                                                      *
 147 %*********************************************************
 148
 149 \begin{code}
 150 #ifndef __HUGS__
 151 freeStdFileObject :: ForeignObj -> IO ()
 152 freeStdFileObject fo = CCALL(freeStdFileObject) fo
 153
 154 freeFileObject :: ForeignObj -> IO ()
 155 freeFileObject fo = CCALL(freeFileObject) fo
 156 #else
 157 foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
 158 foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
 159 #endif
 160 \end{code}
 161
 162 %*********************************************************
 163 %*                                                      *
 164 \subsection[StdHandles]{Standard handles}
 165 %*                                                      *
 166 %*********************************************************
 167
 168 Three handles are allocated during program initialisation.  The first
 169 two manage input or output from the Haskell program's standard input
 170 or output channel respectively.  The third manages output to the
 171 standard error channel. These handles are initially open.
 172
 173
 174 \begin{code}
 175 stdin, stdout, stderr :: Handle
 176
 177 stdout = unsafePerformIO (do
 178     rc <- CCALL(getLock) (1::Int) (1::Int)   -- ConcHask: SAFE, won't block
 179     case (rc::Int) of
 180        0 -> newHandle (mkClosedHandle__)
 181        1 -> do
 182 #ifndef __CONCURRENT_HASKELL__
 183             fo <- CCALL(openStdFile) (1::Int)
 184                                      (1::Int){-flush on close-}
 185                                      (0::Int){-writeable-}  -- ConcHask: SAFE, won't block
 186 #else
 187             fo <- CCALL(openStdFile) (1::Int)
 188                                      ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int)
 189                                      (0::Int){-writeable-}  -- ConcHask: SAFE, won't block
 190 #endif
 191                                             -- NOTE: turn off non-blocking I/O until
 192                                             -- we've got proper support for threadWait{Read,Write}
 193
 194 #ifndef __PARALLEL_HASKELL__
 195             fo <- makeForeignObj fo
 196             addForeignFinalizer fo (freeStdFileObject fo)
 197 #endif
 198
 199 #ifdef __HUGS__
 200 /* I dont care what the Haskell report says, in an interactive system,
 201  * stdout should be unbuffered by default.
 202  */
 203             let bm = NoBuffering
 204 #else
 205             (bm, bf_size)  <- getBMode__ fo
 206             mkBuffer__ fo bf_size
 207 #endif
 208             newHandle (Handle__ fo WriteHandle bm "stdout")
 209        _ -> do ioError <- constructError "stdout"
 210                newHandle (mkErrorHandle__ ioError)
 211   )
 212
 213 stdin = unsafePerformIO (do
 214     rc <- CCALL(getLock) (0::Int) (0::Int)   -- ConcHask: SAFE, won't block
 215     case (rc::Int) of
 216        0 -> newHandle (mkClosedHandle__)
 217        1 -> do
 218 #ifndef __CONCURRENT_HASKELL__
 219             fo <- CCALL(openStdFile) (0::Int)
 220                                      (0::Int){-don't flush on close -}
 221                                      (1::Int){-readable-}  -- ConcHask: SAFE, won't block
 222 #else
 223             fo <- CCALL(openStdFile) (0::Int)
 224                                      ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int)
 225                                      (1::Int){-readable-}  -- ConcHask: SAFE, won't block
 226 #endif
 227
 228 #ifndef __PARALLEL_HASKELL__
 229             fo <- makeForeignObj fo
 230             addForeignFinalizer fo (freeStdFileObject fo)
 231 #endif
 232             (bm, bf_size) <- getBMode__ fo
 233             mkBuffer__ fo bf_size
 234             hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
 235              -- when stdin and stdout are both connected to a terminal, ensure
 236              -- that anything buffered on stdout is flushed prior to reading from stdin.
 237              --
 238             hConnectTerms stdout hdl
 239             return hdl
 240        _ -> do ioError <- constructError "stdin"
 241                newHandle (mkErrorHandle__ ioError)
 242   )
 243
 244
 245 stderr = unsafePerformIO (do
 246     rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-}  -- ConcHask: SAFE, won't block
 247     case (rc::Int) of
 248        0 -> newHandle (mkClosedHandle__)
 249        1 -> do
 250 #ifndef __CONCURRENT_HASKELL__
 251             fo <- CCALL(openStdFile) (2::Int)
 252                                      (1::Int){-flush on close-}
 253                                      (0::Int){-writeable-} -- ConcHask: SAFE, won't block
 254 #else
 255             fo <- CCALL(openStdFile) (2::Int)
 256                                      ((1{-flush on close-} {- + 128 don't block on I/O-})::Int)
 257                                      (0::Int){-writeable-} -- ConcHask: SAFE, won't block
 258 #endif
 259
 260 #ifndef __PARALLEL_HASKELL__
 261             fo <- makeForeignObj fo
 262             addForeignFinalizer fo (freeStdFileObject fo)
 263 #endif
 264             hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
 265             -- when stderr and stdout are both connected to a terminal, ensure
 266             -- that anything buffered on stdout is flushed prior to writing to
 267             -- stderr.
 268             hConnectTo stdout hdl
 269             return hdl
 270
 271        _ -> do ioError <- constructError "stderr"
 272                newHandle (mkErrorHandle__ ioError)
 273   )
 274 \end{code}
 275
 276 %*********************************************************
 277 %*                                                      *
 278 \subsection[OpeningClosing]{Opening and Closing Files}
 279 %*                                                      *
 280 %*********************************************************
 281
 282 \begin{code}
 283 data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
 284                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 285
 286 data IOModeEx
 287  = BinaryMode IOMode
 288  | TextMode   IOMode
 289    deriving (Eq, Read, Show)
 290
 291 openFile :: FilePath -> IOMode -> IO Handle
 292 openFile fp im = openFileEx fp (TextMode im)
 293
 294 openFileEx :: FilePath -> IOModeEx -> IO Handle
 295
 296 openFileEx f m = do
 297     fo <- CCALL(openFile) (primPackString f) (file_mode::Int)
 298                                              (binary::Int)
 299                                              (file_flags::Int) -- ConcHask: SAFE, won't block
 300     if fo /= nullAddr then do
 301 #ifndef __PARALLEL_HASKELL__
 302         fo  <- makeForeignObj fo
 303         addForeignFinalizer fo (freeFileObject fo)
 304 #endif
 305         (bm, bf_size)  <- getBMode__ fo
 306         mkBuffer__ fo bf_size
 307         newHandle (Handle__ fo htype bm f)
 308       else do
 309         constructErrorAndFailWithInfo "openFile" f
 310   where
 311     (imo, binary) =
 312       case m of
 313         BinaryMode bmo -> (bmo, 1)
 314         TextMode tmo   -> (tmo, 0)
 315
 316 #ifndef __CONCURRENT_HASKELL__
 317     file_flags = file_flags'
 318 #else
 319         -- See comment next to 'stderr' for why we leave
 320         -- non-blocking off for now.
 321     file_flags = file_flags' {-+ 128  Don't block on I/O-}
 322 #endif
 323
 324     (file_flags', file_mode) =
 325       case imo of
 326            AppendMode    -> (1, 0)
 327            WriteMode     -> (1, 1)
 328            ReadMode      -> (0, 2)
 329            ReadWriteMode -> (1, 3)
 330
 331     htype = case imo of
 332               ReadMode      -> ReadHandle
 333               WriteMode     -> WriteHandle
 334               AppendMode    -> AppendHandle
 335               ReadWriteMode -> ReadWriteHandle
 336 \end{code}
 337
 338 Computation $openFile file mode$ allocates and returns a new, open
 339 handle to manage the file {\em file}.  It manages input if {\em mode}
 340 is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
 341 and both input and output if mode is $ReadWriteMode$.
 342
 343 If the file does not exist and it is opened for output, it should be
 344 created as a new file.  If {\em mode} is $WriteMode$ and the file
 345 already exists, then it should be truncated to zero length.  The
 346 handle is positioned at the end of the file if {\em mode} is
 347 $AppendMode$, and otherwise at the beginning (in which case its
 348 internal position is 0).
 349
 350 Implementations should enforce, locally to the Haskell process,
 351 multiple-reader single-writer locking on files, which is to say that
 352 there may either be many handles on the same file which manage input,
 353 or just one handle on the file which manages output.  If any open or
 354 semi-closed handle is managing a file for output, no new handle can be
 355 allocated for that file.  If any open or semi-closed handle is
 356 managing a file for input, new handles can only be allocated if they
 357 do not manage output.
 358
 359 Two files are the same if they have the same absolute name.  An
 360 implementation is free to impose stricter conditions.
 361
 362 \begin{code}
 363 hClose :: Handle -> IO ()
 364
 365 hClose handle =
 366     withHandle handle $ \ handle_ -> do
 367     case haType__ handle_ of
 368       ErrorHandle theError -> do
 369           writeHandle handle handle_
 370           ioError theError
 371       ClosedHandle -> do
 372           writeHandle handle handle_
 373           return ()
 374       _ -> do
 375           rc      <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-}  -- ConcHask: SAFE, won't block
 376           {- We explicitly close a file object so that we can be told
 377              if there were any errors. Note that after @hClose@
 378              has been performed, the ForeignObj embedded in the Handle
 379              is still lying around in the heap, so care is taken
 380              to avoid closing the file object when the ForeignObj
 381              is finalized. (we overwrite the file ptr in the underlying
 382              FileObject with a NULL as part of closeFile())
 383           -}
 384           if rc == (0::Int)
 385            then
 386               writeHandle handle (handle_{ haType__   = ClosedHandle,
 387                                            haFO__     = nullFile__ })
 388            else do
 389              writeHandle handle handle_
 390              constructErrorAndFail "hClose"
 391
 392 \end{code}
 393
 394 Computation $hClose hdl$ makes handle {\em hdl} closed.  Before the
 395 computation finishes, any items buffered for output and not already
 396 sent to the operating system are flushed as for $flush$.
 397
 398 %*********************************************************
 399 %*                                                      *
 400 \subsection[EOF]{Detecting the End of Input}
 401 %*                                                      *
 402 %*********************************************************
 403
 404
 405 For a handle {\em hdl} which attached to a physical file, $hFileSize
 406 hdl$ returns the size of {\em hdl} in terms of the number of items
 407 which can be read from {\em hdl}.
 408
 409 \begin{code}
 410 hFileSize :: Handle -> IO Integer
 411 hFileSize handle =
 412     withHandle handle $ \ handle_ -> do
 413     case haType__ handle_ of
 414       ErrorHandle theError -> do
 415           writeHandle handle handle_
 416           ioError theError
 417       ClosedHandle -> do
 418           writeHandle handle handle_
 419           ioe_closedHandle "hFileSize" handle
 420       SemiClosedHandle -> do
 421           writeHandle handle handle_
 422           ioe_closedHandle "hFileSize" handle
 423 #ifdef __HUGS__
 424       _ -> do
 425           mem <- primNewByteArray sizeof_int64
 426           rc <- CCALL(fileSize_int64) (haFO__ handle_) mem  -- ConcHask: SAFE, won't block
 427           writeHandle handle handle_
 428           if rc == 0 then do
 429              result <- primReadInt64Array mem 0
 430              return (primInt64ToInteger result)
 431            else
 432              constructErrorAndFail "hFileSize"
 433 #else
 434       _ ->
 435           -- HACK!  We build a unique MP_INT of the right shape to hold
 436           -- a single unsigned word, and we let the C routine
 437           -- change the data bits
 438           --
 439           -- For some reason, this fails to typecheck if converted to a do
 440           -- expression --SDM
 441           _casm_ ``%r = 1;'' >>= \(I# hack#) ->
 442           case int2Integer# hack# of
 443               (# s, d #) -> do
 444                 rc <- CCALL(fileSize) (haFO__ handle_) d  -- ConcHask: SAFE, won't block
 445                 writeHandle handle handle_
 446                 if rc == (0::Int) then
 447                    return (J# s d)
 448                  else
 449                    constructErrorAndFail "hFileSize"
 450 #endif
 451 \end{code}
 452
 453 For a readable handle {\em hdl}, @hIsEOF hdl@ returns
 454 @True@ if no further input can be taken from @hdl@ or for a
 455 physical file, if the current I/O position is equal to the length of
 456 the file.  Otherwise, it returns @False@.
 457
 458 \begin{code}
 459 hIsEOF :: Handle -> IO Bool
 460 hIsEOF handle =
 461     wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
 462     let fo = haFO__ handle_
 463     rc      <- mayBlock fo (CCALL(fileEOF) fo)  -- ConcHask: UNSAFE, may block
 464     writeHandle handle handle_
 465     case rc of
 466       0 -> return False
 467       1 -> return True
 468       _ -> constructErrorAndFail "hIsEOF"
 469
 470 isEOF :: IO Bool
 471 isEOF = hIsEOF stdin
 472 \end{code}
 473
 474 %*********************************************************
 475 %*                                                      *
 476 \subsection[Buffering]{Buffering Operations}
 477 %*                                                      *
 478 %*********************************************************
 479
 480 Three kinds of buffering are supported: line-buffering,
 481 block-buffering or no-buffering.  See @IOBase@ for definition
 482 and further explanation of what the type represent.
 483
 484 Computation @hSetBuffering hdl mode@ sets the mode of buffering for
 485 handle {\em hdl} on subsequent reads and writes.
 486
 487 \begin{itemize}
 488 \item
 489 If {\em mode} is @LineBuffering@, line-buffering should be
 490 enabled if possible.
 491 \item
 492 If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
 493 should be enabled if possible.  The size of the buffer is {\em n} items
 494 if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
 495 \item
 496 If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
 497 \end{itemize}
 498
 499 If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
 500 to @NoBuffering@, then any items in the output buffer are written to
 501 the device, and any items in the input buffer are discarded.  The
 502 default buffering mode when a handle is opened is
 503 implementation-dependent and may depend on the object which is
 504 attached to that handle.
 505
 506 \begin{code}
 507 hSetBuffering :: Handle -> BufferMode -> IO ()
 508
 509 hSetBuffering handle mode =
 510     case mode of
 511       BlockBuffering (Just n)
 512         | n <= 0 -> ioError
 513                          (IOError (Just handle)
 514                                   InvalidArgument
 515                                   "hSetBuffering"
 516                                   ("illegal buffer size " ++ showsPrec 9 n []))  -- 9 => should be parens'ified.
 517       _ ->
 518           withHandle handle $ \ handle_ -> do
 519           case haType__ handle_ of
 520              ErrorHandle theError -> do
 521                 writeHandle handle handle_
 522                 ioError theError
 523              ClosedHandle -> do
 524                 writeHandle handle handle_
 525                 ioe_closedHandle "hSetBuffering" handle
 526              _ -> do
 527                 {- Note:
 528                     - we flush the old buffer regardless of whether
 529                       the new buffer could fit the contents of the old buffer
 530                       or not.
 531                     - allow a handle's buffering to change even if IO has
 532                       occurred (ANSI C spec. does not allow this, nor did
 533                       the previous implementation of IO.hSetBuffering).
 534                     - a non-standard extension is to allow the buffering
 535                       of semi-closed handles to change [sof 6/98]
 536                 -}
 537                 let fo = haFO__ handle_
 538                 rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
 539                 if rc == 0
 540                  then do
 541                    writeHandle handle (handle_{ haBufferMode__ = mode })
 542                  else do
 543                    -- Note: failure to change the buffer size will cause old buffer to be flushed.
 544                    writeHandle handle handle_
 545                    constructErrorAndFail "hSetBuffering"
 546   where
 547     bsize :: Int
 548     bsize = case mode of
 549               NoBuffering             ->  0
 550               LineBuffering           -> -1
 551               BlockBuffering Nothing  -> -2
 552               BlockBuffering (Just n) ->  n
 553 \end{code}
 554
 555 The action @hFlush hdl@ causes any items buffered for output
 556 in handle {\em hdl} to be sent immediately to the operating
 557 system.
 558
 559 \begin{code}
 560 hFlush :: Handle -> IO ()
 561 hFlush handle =
 562     wantWriteableHandle "hFlush" handle $ \ handle_ -> do
 563     let fo = haFO__ handle_
 564     rc      <- mayBlock fo (CCALL(flushFile) fo)   -- ConcHask: UNSAFE, may block
 565     writeHandle handle handle_
 566     if rc == 0 then
 567        return ()
 568      else
 569        constructErrorAndFail "hFlush"
 570
 571 \end{code}
 572
 573
 574 %*********************************************************
 575 %*                                                      *
 576 \subsection[Seeking]{Repositioning Handles}
 577 %*                                                      *
 578 %*********************************************************
 579
 580 \begin{code}
 581 data HandlePosn
 582  = HandlePosn
 583         Handle   -- Q: should this be a weak or strong ref. to the handle?
 584         Int
 585
 586 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 587                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 588 \end{code}
 589
 590 Computation @hGetPosn hdl@ returns the current I/O
 591 position of {\em hdl} as an abstract position.  Computation
 592 $hSetPosn p$ sets the position of {\em hdl}
 593 to a previously obtained position {\em p}.
 594
 595 \begin{code}
 596 hGetPosn :: Handle -> IO HandlePosn
 597 hGetPosn handle =
 598     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
 599     posn    <- CCALL(getFilePosn) (haFO__ handle_)   -- ConcHask: SAFE, won't block
 600     writeHandle handle handle_
 601     if posn /= -1 then
 602       return (HandlePosn handle posn)
 603      else
 604       constructErrorAndFail "hGetPosn"
 605
 606 hSetPosn :: HandlePosn -> IO ()
 607 hSetPosn (HandlePosn handle posn) =
 608     wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
 609     let fo = haFO__ handle_
 610     rc     <- mayBlock fo (CCALL(setFilePosn) fo posn)    -- ConcHask: UNSAFE, may block
 611     writeHandle handle handle_
 612     if rc == 0 then
 613        return ()
 614      else
 615         constructErrorAndFail "hSetPosn"
 616 \end{code}
 617
 618 The action @hSeek hdl mode i@ sets the position of handle
 619 @hdl@ depending on @mode@.  If @mode@ is
 620 \begin{itemize}
 621 \item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
 622 \item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
 623 the current position.
 624 \item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
 625 the end of the file.
 626 \end{itemize}
 627
 628 Some handles may not be seekable (see @hIsSeekable@), or only support a
 629 subset of the possible positioning operations (e.g. it may only be
 630 possible to seek to the end of a tape, or to a positive offset from
 631 the beginning or current position).
 632
 633 It is not possible to set a negative I/O position, or for a physical
 634 file, an I/O position beyond the current end-of-file.
 635
 636 Note:
 637  - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
 638    at or past EOF.
 639  - relative seeking on buffered handles can lead to non-obvious results.
 640
 641 \begin{code}
 642 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 643 #ifdef __HUGS__
 644 hSeek handle mode offset =
 645     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
 646     let fo = haFO__ handle_
 647     rc      <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset))  -- ConcHask: UNSAFE, may block
 648 #else
 649 hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
 650 hSeek handle mode (J# s# d#) =
 651     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
 652     let fo = haFO__ handle_
 653     rc      <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#)  -- ConcHask: UNSAFE, may block
 654 #endif
 655     writeHandle handle handle_
 656     if rc == 0 then
 657        return ()
 658      else
 659         constructErrorAndFail "hSeek"
 660   where
 661     whence :: Int
 662     whence = case mode of
 663                AbsoluteSeek -> 0
 664                RelativeSeek -> 1
 665                SeekFromEnd  -> 2
 666 \end{code}
 667
 668 %*********************************************************
 669 %*                                                      *
 670 \subsection[Query]{Handle Properties}
 671 %*                                                      *
 672 %*********************************************************
 673
 674 A number of operations return information about the properties of a
 675 handle.  Each of these operations returns $True$ if the
 676 handle has the specified property, and $False$
 677 otherwise.
 678
 679 Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
 680 {\em hdl} is not block-buffered.  Otherwise it returns
 681 $( True, size )$, where {\em size} is $Nothing$ for default buffering, and
 682 $( Just n )$ for block-buffering of {\em n} bytes.
 683
 684 \begin{code}
 685 hIsOpen :: Handle -> IO Bool
 686 hIsOpen handle =
 687     withHandle handle $ \ handle_ -> do
 688     case haType__ handle_ of
 689       ErrorHandle theError -> do
 690           writeHandle handle handle_
 691           ioError theError
 692       ClosedHandle -> do
 693           writeHandle handle handle_
 694           return False
 695       SemiClosedHandle -> do
 696           writeHandle handle handle_
 697           return False
 698       _ -> do
 699           writeHandle handle handle_
 700           return True
 701
 702 hIsClosed :: Handle -> IO Bool
 703 hIsClosed handle =
 704     withHandle handle $ \ handle_ -> do
 705     case haType__ handle_ of
 706       ErrorHandle theError -> do
 707           writeHandle handle handle_
 708           ioError theError
 709       ClosedHandle -> do
 710           writeHandle handle handle_
 711           return True
 712       _ -> do
 713           writeHandle handle handle_
 714           return False
 715
 716 {- not defined, nor exported, but mentioned
 717    here for documentation purposes:
 718
 719     hSemiClosed :: Handle -> IO Bool
 720     hSemiClosed h = do
 721        ho <- hIsOpen h
 722        hc <- hIsClosed h
 723        return (not (ho || hc))
 724 -}
 725
 726 hIsReadable :: Handle -> IO Bool
 727 hIsReadable handle =
 728     withHandle handle $ \ handle_ -> do
 729     case haType__ handle_ of
 730       ErrorHandle theError -> do
 731           writeHandle handle handle_
 732           ioError theError
 733       ClosedHandle -> do
 734           writeHandle handle handle_
 735           ioe_closedHandle "hIsReadable" handle
 736       SemiClosedHandle -> do
 737           writeHandle handle handle_
 738           ioe_closedHandle "hIsReadable" handle
 739       htype -> do
 740           writeHandle handle handle_
 741           return (isReadable htype)
 742   where
 743     isReadable ReadHandle      = True
 744     isReadable ReadWriteHandle = True
 745     isReadable _               = False
 746
 747 hIsWritable :: Handle -> IO Bool
 748 hIsWritable handle =
 749     withHandle handle $ \ handle_ -> do
 750     case haType__ handle_ of
 751       ErrorHandle theError -> do
 752           writeHandle handle handle_
 753           ioError theError
 754       ClosedHandle -> do
 755           writeHandle handle handle_
 756           ioe_closedHandle "hIsWritable" handle
 757       SemiClosedHandle -> do
 758           writeHandle handle handle_
 759           ioe_closedHandle "hIsWritable" handle
 760       htype -> do
 761           writeHandle handle handle_
 762           return (isWritable htype)
 763   where
 764     isWritable AppendHandle    = True
 765     isWritable WriteHandle     = True
 766     isWritable ReadWriteHandle = True
 767     isWritable _               = False
 768
 769
 770 #ifndef __PARALLEL_HASKELL__
 771 getBMode__ :: ForeignObj -> IO (BufferMode, Int)
 772 #else
 773 getBMode__ :: Addr -> IO (BufferMode, Int)
 774 #endif
 775 getBMode__ fo = do
 776   rc <- CCALL(getBufferMode) fo    -- ConcHask: SAFE, won't block
 777   case (rc::Int) of
 778     0  -> return (NoBuffering, 0)
 779     -1 -> return (LineBuffering, default_buffer_size)
 780     -2 -> return (BlockBuffering Nothing, default_buffer_size)
 781     -3 -> return (NoBuffering, 0)               -- only happens on un-stat()able files.
 782     n  -> return (BlockBuffering (Just n), n)
 783  where
 784    default_buffer_size :: Int
 785    default_buffer_size = (const_BUFSIZ - 1)
 786 \end{code}
 787
 788 Querying how a handle buffers its data:
 789
 790 \begin{code}
 791 hGetBuffering :: Handle -> IO BufferMode
 792 hGetBuffering handle =
 793     withHandle handle $ \ handle_ -> do
 794     case haType__ handle_ of
 795       ErrorHandle theError -> do
 796           writeHandle handle handle_
 797           ioError theError
 798       ClosedHandle -> do
 799           writeHandle handle handle_
 800           ioe_closedHandle "hGetBuffering" handle
 801       _ -> do
 802           {-
 803            We're being non-standard here, and allow the buffering
 804            of a semi-closed handle to be queried.   -- sof 6/98
 805           -}
 806           let v = haBufferMode__ handle_
 807           writeHandle handle handle_
 808           return v  -- could be stricter..
 809
 810 \end{code}
 811
 812 \begin{code}
 813 hIsSeekable :: Handle -> IO Bool
 814 hIsSeekable handle =
 815     withHandle handle $ \ handle_ -> do
 816     case haType__ handle_ of
 817       ErrorHandle theError -> do
 818           writeHandle handle handle_
 819           ioError theError
 820       ClosedHandle -> do
 821           writeHandle handle handle_
 822           ioe_closedHandle "hIsSeekable" handle
 823       SemiClosedHandle -> do
 824           writeHandle handle handle_
 825           ioe_closedHandle "hIsSeekable" handle
 826       AppendHandle -> do
 827           writeHandle handle handle_
 828           return False
 829       _ -> do
 830           rc <- CCALL(seekFileP) (haFO__ handle_)   -- ConcHask: SAFE, won't block
 831           writeHandle handle handle_
 832           case (rc::Int) of
 833             0 -> return False
 834             1 -> return True
 835             _ -> constructErrorAndFail "hIsSeekable"
 836 \end{code}
 837
 838
 839 %*********************************************************
 840 %*                                                      *
 841 \subsection{Changing echo status}
 842 %*                                                      *
 843 %*********************************************************
 844
 845 Non-standard GHC extension is to allow the echoing status
 846 of a handles connected to terminals to be reconfigured:
 847
 848 \begin{code}
 849 hSetEcho :: Handle -> Bool -> IO ()
 850 hSetEcho handle on = do
 851     isT   <- hIsTerminalDevice handle
 852     if not isT
 853      then return ()
 854      else
 855       withHandle handle $ \ handle_ -> do
 856       case haType__ handle_ of
 857          ErrorHandle theError ->  do
 858             writeHandle handle handle_
 859             ioError theError
 860          ClosedHandle      ->  do
 861             writeHandle handle handle_
 862             ioe_closedHandle "hSetEcho" handle
 863          _ -> do
 864             rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int)  -- ConcHask: SAFE, won't block
 865             writeHandle handle handle_
 866             if rc /= ((-1)::Int)
 867              then return ()
 868              else constructErrorAndFail "hSetEcho"
 869
 870 hGetEcho :: Handle -> IO Bool
 871 hGetEcho handle = do
 872     isT   <- hIsTerminalDevice handle
 873     if not isT
 874      then return False
 875      else
 876        withHandle handle $ \ handle_ -> do
 877        case haType__ handle_ of
 878          ErrorHandle theError ->  do
 879             writeHandle handle handle_
 880             ioError theError
 881          ClosedHandle      ->  do
 882             writeHandle handle handle_
 883             ioe_closedHandle "hGetEcho" handle
 884          _ -> do
 885             rc <- CCALL(getTerminalEcho) (haFO__ handle_)  -- ConcHask: SAFE, won't block
 886             writeHandle handle handle_
 887             case (rc::Int) of
 888               1 -> return True
 889               0 -> return False
 890               _ -> constructErrorAndFail "hSetEcho"
 891
 892 hIsTerminalDevice :: Handle -> IO Bool
 893 hIsTerminalDevice handle = do
 894     withHandle handle $ \ handle_ -> do
 895      case haType__ handle_ of
 896        ErrorHandle theError ->  do
 897             writeHandle handle handle_
 898             ioError theError
 899        ClosedHandle        ->  do
 900             writeHandle handle handle_
 901             ioe_closedHandle "hIsTerminalDevice" handle
 902        _ -> do
 903           rc <- CCALL(isTerminalDevice) (haFO__ handle_)   -- ConcHask: SAFE, won't block
 904           writeHandle handle handle_
 905           case (rc::Int) of
 906             1 -> return True
 907             0 -> return False
 908             _ -> constructErrorAndFail "hIsTerminalDevice"
 909 \end{code}
 910
 911 \begin{code}
 912 hConnectTerms :: Handle -> Handle -> IO ()
 913 hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
 914
 915 hConnectTo :: Handle -> Handle -> IO ()
 916 hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
 917
 918 hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
 919 hConnectHdl_ hW hR is_tty =
 920   wantRWHandle "hConnectTo" hW $ \ hW_ ->
 921   wantRWHandle "hConnectTo" hR $ \ hR_ -> do
 922   CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty  -- ConcHask: SAFE, won't block
 923   writeHandle hR hR_
 924   writeHandle hW hW_
 925
 926 #ifndef __PARALLEL_HASKELL__
 927 #define FILE_OBJECT     ForeignObj
 928 #else
 929 #define FILE_OBJECT     Addr
 930 #endif
 931
 932 flushConnectedBuf :: FILE_OBJECT -> IO ()
 933 flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
 934 \end{code}
 935
 936 As an extension, we also allow characters to be pushed back.
 937 Like ANSI C stdio, we guarantee no more than one character of
 938 pushback. (For unbuffered channels, the (default) push-back limit is
 939 2 chars tho.)
 940
 941 \begin{code}
 942 hUngetChar :: Handle -> Char -> IO ()
 943 hUngetChar handle c =
 944     wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
 945     rc      <- CCALL(ungetChar) (haFO__ handle_) c  -- ConcHask: SAFE, won't block
 946     writeHandle handle handle_
 947     if rc == ((-1)::Int)
 948      then constructErrorAndFail "hUngetChar"
 949      else return ()
 950
 951 \end{code}
 952
 953
 954 Hoisting files in in one go is sometimes useful, so we support
 955 this as an extension:
 956
 957 \begin{code}
 958 -- in one go, read file into an externally allocated buffer.
 959 slurpFile :: FilePath -> IO (Addr, Int)
 960 slurpFile fname = do
 961   handle <- openFile fname ReadMode
 962   sz     <- hFileSize handle
 963   if sz > toInteger (maxBound::Int) then
 964     ioError (userError "slurpFile: file too big")
 965    else do
 966      let sz_i = fromInteger sz
 967      chunk <- CCALL(allocMemory__) (sz_i::Int)
 968      if chunk == nullAddr
 969       then do
 970         hClose handle
 971         constructErrorAndFail "slurpFile"
 972       else
 973         withHandle handle $ \ handle_ -> do
 974         let fo = haFO__ handle_
 975         rc      <- mayBlock fo (CCALL(readChunk) fo chunk sz_i)    -- ConcHask: UNSAFE, may block.
 976         writeHandle handle handle_
 977         hClose handle
 978         if rc < (0::Int)
 979          then constructErrorAndFail "slurpFile"
 980          else return (chunk, rc)
 981
 982 #ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
 983 hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
 984 hFillBufBA handle buf sz
 985   | sz <= 0 = ioError (IOError (Just handle)
 986                             InvalidArgument
 987                             "hFillBufBA"
 988                             ("illegal buffer size " ++ showsPrec 9 sz []))  -- 9 => should be parens'ified.
 989   | otherwise =
 990     wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
 991     let fo  = haFO__ handle_
 992 #ifdef __HUGS__
 993     rc      <- mayBlock fo (CCALL(readChunkBA) fo buf sz)    -- ConcHask: UNSAFE, may block.
 994 #else
 995     rc      <- mayBlock fo (CCALL(readChunk) fo buf sz)    -- ConcHask: UNSAFE, may block.
 996 #endif
 997     writeHandle handle handle_
 998     if rc >= (0::Int)
 999      then return rc
1000      else constructErrorAndFail "hFillBufBA"
1001 #endif
1002
1003 hFillBuf :: Handle -> Addr -> Int -> IO Int
1004 hFillBuf handle buf sz
1005   | sz <= 0 = ioError (IOError (Just handle)
1006                             InvalidArgument
1007                             "hFillBuf"
1008                             ("illegal buffer size " ++ showsPrec 9 sz []))  -- 9 => should be parens'ified.
1009   | otherwise =
1010     wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
1011     let fo  = haFO__ handle_
1012     rc      <- mayBlock fo (CCALL(readChunk) fo buf sz)    -- ConcHask: UNSAFE, may block.
1013     writeHandle handle handle_
1014     if rc >= 0
1015      then return rc
1016      else constructErrorAndFail "hFillBuf"
1017
1018 \end{code}
1019
1020 The @hPutBuf hdl buf len@ action writes an already packed sequence of
1021 bytes to the file/channel managed by @hdl@ - non-standard.
1022
1023 \begin{code}
1024 hPutBuf :: Handle -> Addr -> Int -> IO ()
1025 hPutBuf handle buf len =
1026     wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
1027     let fo  = haFO__ handle_
1028     rc      <- mayBlock fo (CCALL(writeBuf) fo buf len)  -- ConcHask: UNSAFE, may block.
1029     writeHandle handle handle_
1030     if rc == (0::Int)
1031      then return ()
1032      else constructErrorAndFail "hPutBuf"
1033
1034 #ifndef __HUGS__ /* An_ one Hugs doesn't provide */
1035 hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
1036 hPutBufBA handle buf len =
1037     wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
1038     let fo = haFO__ handle_
1039     rc      <- mayBlock fo (CCALL(writeBufBA) fo buf len)  -- ConcHask: UNSAFE, may block.
1040     writeHandle handle handle_
1041     if rc == (0::Int)
1042      then return ()
1043      else constructErrorAndFail "hPutBuf"
1044 #endif
1045 \end{code}
1046
1047 Sometimes it's useful to get at the file descriptor that
1048 the Handle contains..
1049
1050 \begin{code}
1051 getHandleFd :: Handle -> IO Int
1052 getHandleFd handle =
1053     withHandle handle $ \ handle_ -> do
1054     case (haType__ handle_) of
1055       ErrorHandle theError -> do
1056           writeHandle handle handle_
1057           ioError theError
1058       ClosedHandle -> do
1059           writeHandle handle handle_
1060           ioe_closedHandle "getHandleFd" handle
1061       _ -> do
1062           fd <- CCALL(getFileFd) (haFO__ handle_)
1063           writeHandle handle handle_
1064           return fd
1065 \end{code}
1066
1067
1068 %*********************************************************
1069 %*                                                      *
1070 \subsection{Miscellaneous}
1071 %*                                                      *
1072 %*********************************************************
1073
1074 These three functions are meant to get things out of @IOErrors@.
1075
1076 (ToDo: improve!)
1077
1078 \begin{code}
1079 ioeGetFileName        :: IOError -> Maybe FilePath
1080 ioeGetErrorString     :: IOError -> String
1081 ioeGetHandle          :: IOError -> Maybe Handle
1082
1083 ioeGetHandle   (IOError h _ _ _)   = h
1084 ioeGetErrorString (IOError _ iot _ str) =
1085  case iot of
1086    EOF -> "end of file"
1087    _   -> str
1088
1089 ioeGetFileName (IOError _ _  _ str) =
1090  case span (/=':') str of
1091    (_,[])  -> Nothing
1092    (fs,_)  -> Just fs
1093
1094 \end{code}
1095
1096 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
1097 PrelMain.mainIO) and report them - topHandler is the exception
1098 handler they should use for this:
1099
1100 \begin{code}
1101 -- make sure we handle errors while reporting the error!
1102 -- (e.g. evaluating the string passed to 'error' might generate
1103 --  another error, etc.)
1104 topHandler :: Bool -> Exception -> IO ()
1105 topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
1106
1107 real_handler :: Bool -> Exception -> IO ()
1108 real_handler bombOut ex =
1109   case ex of
1110         AsyncException StackOverflow -> reportStackOverflow bombOut
1111         ErrorCall s -> reportError bombOut s
1112         other       -> reportError bombOut (showsPrec 0 other "\n")
1113
1114 reportStackOverflow :: Bool -> IO ()
1115 reportStackOverflow bombOut = do
1116    (hFlush stdout) `catchException` (\ _ -> return ())
1117    callStackOverflowHook
1118    if bombOut then
1119      stg_exit 2
1120     else
1121      return ()
1122
1123 reportError :: Bool -> String -> IO ()
1124 reportError bombOut str = do
1125    (hFlush stdout) `catchException` (\ _ -> return ())
1126    let bs@(ByteArray (_,len) _) = packString str
1127    writeErrString addrOf_ErrorHdrHook bs len
1128    if bombOut then
1129      stg_exit 1
1130     else
1131      return ()
1132
1133 foreign label "ErrorHdrHook"
1134         addrOf_ErrorHdrHook :: Addr
1135
1136 foreign import ccall "writeErrString__"
1137         writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
1138
1139 foreign import ccall "stackOverflow"
1140         callStackOverflowHook :: IO ()
1141
1142 foreign import ccall "stg_exit"
1143         stg_exit :: Int -> IO ()
1144 \end{code}
1145
1146
1147 A number of operations want to get at a readable or writeable handle, and fail
1148 if it isn't:
1149
1150 \begin{code}
1151 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1152 wantReadableHandle fun handle act =
1153     withHandle handle $ \ handle_ -> do
1154     case haType__ handle_ of
1155       ErrorHandle theError -> do
1156           writeHandle handle handle_
1157           ioError theError
1158       ClosedHandle -> do
1159           writeHandle handle handle_
1160           ioe_closedHandle fun handle
1161       SemiClosedHandle -> do
1162           writeHandle handle handle_
1163           ioe_closedHandle fun handle
1164       AppendHandle -> do
1165           writeHandle handle handle_
1166           ioError not_readable_error
1167       WriteHandle -> do
1168           writeHandle handle handle_
1169           ioError not_readable_error
1170       _ -> act handle_
1171   where
1172    not_readable_error =
1173            IOError (Just handle) IllegalOperation fun
1174                    ("handle is not open for reading")
1175
1176 wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1177 wantWriteableHandle fun handle act =
1178     withHandle handle $ \ handle_ -> do
1179     case haType__ handle_ of
1180       ErrorHandle theError -> do
1181           writeHandle handle handle_
1182           ioError theError
1183       ClosedHandle -> do
1184           writeHandle handle handle_
1185           ioe_closedHandle fun handle
1186       SemiClosedHandle -> do
1187           writeHandle handle handle_
1188           ioe_closedHandle fun handle
1189       ReadHandle -> do
1190           writeHandle handle handle_
1191           ioError not_writeable_error
1192       _ -> act handle_
1193   where
1194    not_writeable_error =
1195            IOError (Just handle) IllegalOperation fun
1196                    ("handle is not open for writing")
1197
1198 wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1199 wantRWHandle fun handle act =
1200     withHandle handle $ \ handle_ -> do
1201     case haType__ handle_ of
1202       ErrorHandle theError -> do
1203           writeHandle handle handle_
1204           ioError theError
1205       ClosedHandle -> do
1206           writeHandle handle handle_
1207           ioe_closedHandle fun handle
1208       SemiClosedHandle -> do
1209           writeHandle handle handle_
1210           ioe_closedHandle fun handle
1211       _ -> act handle_
1212   where
1213    not_rw_error =
1214            IOError (Just handle) IllegalOperation fun
1215                    ("handle is not open for reading or writing")
1216
1217 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1218 wantSeekableHandle fun handle act =
1219     withHandle handle $ \ handle_ -> do
1220     case haType__ handle_ of
1221       ErrorHandle theError -> do
1222           writeHandle handle handle_
1223           ioError theError
1224       ClosedHandle -> do
1225           writeHandle handle handle_
1226           ioe_closedHandle fun handle
1227       SemiClosedHandle -> do
1228           writeHandle handle handle_
1229           ioe_closedHandle fun handle
1230       AppendHandle -> do
1231           writeHandle handle handle_
1232           ioError not_seekable_error
1233       _ -> act handle_
1234   where
1235    not_seekable_error =
1236            IOError (Just handle)
1237                    IllegalOperation fun
1238                    ("handle is not seekable")
1239
1240 \end{code}
1241
1242 Internal function for creating an @IOError@ representing the
1243 access to a closed file.
1244
1245 \begin{code}
1246 ioe_closedHandle :: String -> Handle -> IO a
1247 ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed")
1248 \end{code}
1249
1250 Internal helper functions for Concurrent Haskell implementation
1251 of IO:
1252
1253 \begin{code}
1254 #ifndef __PARALLEL_HASKELL__
1255 mayBlock :: ForeignObj -> IO Int -> IO Int
1256 #else
1257 mayBlock :: Addr  -> IO Int -> IO Int
1258 #endif
1259
1260 #ifndef notyet /*__CONCURRENT_HASKELL__*/
1261 mayBlock  _ act = act
1262 #else
1263 mayBlock fo act = do
1264    rc <- act
1265    case rc of
1266      -5 -> do  -- (possibly blocking) read
1267         fd <- CCALL(getFileFd) fo
1268         threadWaitRead fd
1269         CCALL(clearNonBlockingIOFlag__) fo  -- force read to happen this time.
1270         mayBlock fo act  -- input available, re-try
1271      -6 -> do  -- (possibly blocking) write
1272         fd <- CCALL(getFileFd) fo
1273         threadWaitWrite fd
1274         CCALL(clearNonBlockingIOFlag__) fo  -- force write to happen this time.
1275         mayBlock fo act  -- output possible
1276      -7 -> do  -- (possibly blocking) write on connected handle
1277         fd <- CCALL(getConnFileFd) fo
1278         threadWaitWrite fd
1279         CCALL(clearConnNonBlockingIOFlag__) fo  -- force write to happen this time.
1280         mayBlock fo act  -- output possible
1281      _ -> do
1282         CCALL(setNonBlockingIOFlag__) fo      -- reset file object.
1283         CCALL(setConnNonBlockingIOFlag__) fo  -- reset (connected) file object.
1284         return rc
1285
1286 #endif
1287
1288 -- #ifdef __HUGS__
1289 #if 1
1290 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
1291
1292 -- Hugs does actually have the primops needed to implement these
1293 -- but, like GHC, the primops don't actually do anything...
1294 threadDelay     _ = return ()
1295 threadWaitRead  _ = return ()
1296 threadWaitWrite _ = return ()
1297 #endif
1298
1299 \end{code}
1300
1301
1302 \begin{code}
1303 #ifdef __HUGS__
1304 type FD           = Int
1305 type Exclusive    = Int  -- really Bool
1306 type How          = Int
1307 type Binary       = Int
1308 type OpenStdFlags = Int
1309 type OpenFlags    = Int
1310 type Readable     = Int  -- really Bool
1311 type Flush        = Int  -- really Bool
1312 type RC           = Int  -- standard return code
1313
1314 type IOFileAddr   = Addr  -- as returned from functions
1315 type CString      = PrimByteArray
1316 type Bytes        = PrimMutableByteArray RealWorld
1317
1318 #ifndef __PARALLEL_HASKELL__
1319 type FILE_OBJ  = ForeignObj -- as passed into functions
1320 #else
1321 type FILE_OBJ  = Addr
1322 #endif
1323
1324 foreign import ccall "libHS_cbits.so" "setBuf"                unsafe prim_setBuf           :: FILE_OBJ -> Addr -> Int -> IO ()
1325 foreign import ccall "libHS_cbits.so" "getBufSize"            unsafe prim_getBufSize       :: FILE_OBJ -> IO Int
1326 foreign import ccall "libHS_cbits.so" "inputReady"            unsafe prim_inputReady       :: FILE_OBJ -> Int -> IO RC
1327 foreign import ccall "libHS_cbits.so" "fileGetc"              unsafe prim_fileGetc         :: FILE_OBJ -> IO Int
1328 foreign import ccall "libHS_cbits.so" "fileLookAhead"         unsafe prim_fileLookAhead    :: FILE_OBJ -> IO Int
1329 foreign import ccall "libHS_cbits.so" "readBlock"             unsafe prim_readBlock        :: FILE_OBJ -> IO Int
1330 foreign import ccall "libHS_cbits.so" "readLine"              unsafe prim_readLine         :: FILE_OBJ -> IO Int
1331 foreign import ccall "libHS_cbits.so" "readChar"              unsafe prim_readChar         :: FILE_OBJ -> IO Int
1332 foreign import ccall "libHS_cbits.so" "writeFileObject"       unsafe prim_writeFileObject  :: FILE_OBJ -> Int -> IO RC
1333 foreign import ccall "libHS_cbits.so" "filePutc"              unsafe prim_filePutc         :: FILE_OBJ -> Char -> IO RC
1334 foreign import ccall "libHS_cbits.so" "getBufStart"           unsafe prim_getBufStart      :: FILE_OBJ -> Int -> IO Addr
1335 foreign import ccall "libHS_cbits.so" "getWriteableBuf"       unsafe prim_getWriteableBuf  :: FILE_OBJ -> IO Addr
1336 foreign import ccall "libHS_cbits.so" "getBufWPtr"            unsafe prim_getBufWPtr       :: FILE_OBJ -> IO Int
1337 foreign import ccall "libHS_cbits.so" "setBufWPtr"            unsafe prim_setBufWPtr       :: FILE_OBJ -> Int -> IO ()
1338 foreign import ccall "libHS_cbits.so" "closeFile"             unsafe prim_closeFile        :: FILE_OBJ -> Flush -> IO RC
1339 foreign import ccall "libHS_cbits.so" "fileEOF"               unsafe prim_fileEOF           :: FILE_OBJ -> IO RC
1340 foreign import ccall "libHS_cbits.so" "setBuffering"          unsafe prim_setBuffering      :: FILE_OBJ -> Int -> IO RC
1341 foreign import ccall "libHS_cbits.so" "flushFile"             unsafe prim_flushFile         :: FILE_OBJ -> IO RC
1342 foreign import ccall "libHS_cbits.so" "flushConnectedBuf"     unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
1343 foreign import ccall "libHS_cbits.so" "getBufferMode"         unsafe prim_getBufferMode     :: FILE_OBJ -> IO RC
1344 foreign import ccall "libHS_cbits.so" "seekFile_int64"        unsafe prim_seekFile_int64    :: FILE_OBJ -> Int -> Int64 -> IO RC
1345 foreign import ccall "libHS_cbits.so" "seekFileP"             unsafe prim_seekFileP        :: FILE_OBJ -> IO RC
1346 foreign import ccall "libHS_cbits.so" "setTerminalEcho"       unsafe prim_setTerminalEcho  :: FILE_OBJ -> Int -> IO RC
1347 foreign import ccall "libHS_cbits.so" "getTerminalEcho"       unsafe prim_getTerminalEcho  :: FILE_OBJ -> IO RC
1348 foreign import ccall "libHS_cbits.so" "isTerminalDevice"      unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC
1349 foreign import ccall "libHS_cbits.so" "setConnectedTo"        unsafe prim_setConnectedTo   :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1350 foreign import ccall "libHS_cbits.so" "ungetChar"             unsafe prim_ungetChar        :: FILE_OBJ -> Char -> IO RC
1351 foreign import ccall "libHS_cbits.so" "readChunk"             unsafe prim_readChunk        :: FILE_OBJ -> Addr          -> Int -> IO RC
1352 foreign import ccall "libHS_cbits.so" "writeBuf"              unsafe prim_writeBuf         :: FILE_OBJ -> Addr -> Int -> IO RC
1353 foreign import ccall "libHS_cbits.so" "getFileFd"             unsafe prim_getFileFd        :: FILE_OBJ -> IO FD
1354 foreign import ccall "libHS_cbits.so" "fileSize_int64"        unsafe prim_fileSize_int64   :: FILE_OBJ -> Bytes -> IO RC
1355 foreign import ccall "libHS_cbits.so" "getFilePosn"           unsafe prim_getFilePosn      :: FILE_OBJ -> IO Int
1356 foreign import ccall "libHS_cbits.so" "setFilePosn"           unsafe prim_setFilePosn      :: FILE_OBJ -> Int -> IO Int
1357 foreign import ccall "libHS_cbits.so" "getConnFileFd"         unsafe prim_getConnFileFd    :: FILE_OBJ -> IO FD
1358 foreign import ccall "libHS_cbits.so" "allocMemory__"         unsafe prim_allocMemory__    :: Int -> IO Addr
1359 foreign import ccall "libHS_cbits.so" "getLock"               unsafe prim_getLock          :: FD -> Exclusive -> IO RC
1360 foreign import ccall "libHS_cbits.so" "openStdFile"           unsafe prim_openStdFile      :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1361 foreign import ccall "libHS_cbits.so" "openFile"              unsafe prim_openFile         :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1362 foreign import ccall "libHS_cbits.so" "freeFileObject"        unsafe prim_freeFileObject    :: FILE_OBJ -> IO ()
1363 foreign import ccall "libHS_cbits.so" "freeStdFileObject"     unsafe prim_freeStdFileObject :: FILE_OBJ -> IO ()
1364 foreign import ccall "libHS_cbits.so" "const_BUFSIZ"          unsafe const_BUFSIZ          :: Int
1365
1366 foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__"   unsafe prim_setConnNonBlockingIOFlag__   :: FILE_OBJ -> IO ()
1367 foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1368 foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__"       unsafe prim_setNonBlockingIOFlag__       :: FILE_OBJ -> IO ()
1369 foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__"     unsafe prim_clearNonBlockingIOFlag__     :: FILE_OBJ -> IO ()
1370
1371 foreign import ccall "libHS_cbits.so" "getErrStr__"  unsafe prim_getErrStr__  :: IO Addr
1372 foreign import ccall "libHS_cbits.so" "getErrNo__"   unsafe prim_getErrNo__   :: IO Int
1373 foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int
1374
1375 #endif
1376 \end{code}
1377
1378