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 "error.h"
  13
  14
  15 module PrelHandle where
  16
  17 import PrelBase
  18 import PrelArr          ( newVar, readVar, writeVar, ByteArray )
  19 import PrelRead         ( Read )
  20 import PrelList         ( span )
  21 import PrelIOBase
  22 import PrelMaybe        ( Maybe(..) )
  23 import PrelAddr         ( Addr, nullAddr )
  24 import PrelBounded      ()   -- get at Bounded Int instance.
  25 import PrelNum          ( toInteger )
  26 import Ix
  27
  28 #ifndef __PARALLEL_HASKELL__
  29 import PrelForeign  ( ForeignObj, makeForeignObj, writeForeignObj )
  30 #endif
  31
  32 import PrelConc                         -- concurrent only
  33 \end{code}
  34
  35
  36 %*********************************************************
  37 %*                                                      *
  38 \subsection{Types @Handle@, @Handle__@}
  39 %*                                                      *
  40 %*********************************************************
  41
  42 The @Handle@ and @Handle__@ types are defined in @IOBase@.
  43
  44 \begin{code}
  45 {-# INLINE newHandle   #-}
  46 {-# INLINE readHandle  #-}
  47 {-# INLINE writeHandle #-}
  48 newHandle   :: Handle__ -> IO Handle
  49 readHandle  :: Handle   -> IO Handle__
  50 writeHandle :: Handle -> Handle__ -> IO ()
  51
  52 #if defined(__CONCURRENT_HASKELL__)
  53
  54 -- Use MVars for concurrent Haskell
  55 newHandle hc  = newMVar hc      >>= \ h ->
  56                 return (Handle h)
  57
  58 readHandle  (Handle h)    = takeMVar h
  59 writeHandle (Handle h) hc = putMVar h hc
  60
  61 #else
  62
  63 -- Use ordinary MutableVars for non-concurrent Haskell
  64 newHandle hc  = stToIO (newVar  hc      >>= \ h ->
  65                         return (Handle h))
  66
  67 readHandle  (Handle h)    = stToIO (readVar h)
  68 writeHandle (Handle h) hc = stToIO (writeVar h hc)
  69
  70 #endif
  71
  72 \end{code}
  73
  74 %*********************************************************
  75 %*                                                      *
  76 \subsection[StdHandles]{Standard handles}
  77 %*                                                      *
  78 %*********************************************************
  79
  80 Three handles are allocated during program initialisation.  The first
  81 two manage input or output from the Haskell program's standard input
  82 or output channel respectively.  The third manages output to the
  83 standard error channel. These handles are initially open.
  84
  85 \begin{code}
  86 stdin, stdout, stderr :: Handle
  87
  88 stdout = unsafePerformIO (do
  89     rc <- _ccall_ getLock 1 1   -- ConcHask: SAFE, won't block
  90     case rc of
  91        0 -> newHandle (mkClosedHandle__)
  92        1 -> do
  93 #ifndef __CONCURRENT_HASKELL__
  94             fo <- _ccall_ openStdFile 1 1{-flush on close-} 0{-writeable-}  -- ConcHask: SAFE, won't block
  95 #else
  96             fo <- _ccall_ openStdFile 1 (1{-flush on close-} + 128{-don't block on I/O-})
  97                                         0{-writeable-}  -- ConcHask: SAFE, won't block
  98 #endif
  99
 100 #ifndef __PARALLEL_HASKELL__
 101             fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
 102 #endif
 103             (bm, bf_size)  <- getBMode__ fo
 104             mkBuffer__ fo bf_size
 105             newHandle (Handle__ fo WriteHandle bm "stdout")
 106        _ -> do ioError <- constructError "stdout"
 107                newHandle (mkErrorHandle__ ioError)
 108   )
 109
 110 stdin = unsafePerformIO (do
 111     rc <- _ccall_ getLock 0 0   -- ConcHask: SAFE, won't block
 112     case rc of
 113        0 -> newHandle (mkClosedHandle__)
 114        1 -> do
 115 #ifndef __CONCURRENT_HASKELL__
 116             fo <- _ccall_ openStdFile 0 0{-don't flush on close -} 1{-readable-}  -- ConcHask: SAFE, won't block
 117 #else
 118             fo <- _ccall_ openStdFile 0 (0{-flush on close-} + 128{-don't block on I/O-})
 119                                         1{-readable-}  -- ConcHask: SAFE, won't block
 120 #endif
 121
 122 #ifndef __PARALLEL_HASKELL__
 123             fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
 124 #endif
 125             (bm, bf_size) <- getBMode__ fo
 126             mkBuffer__ fo bf_size
 127             hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
 128              -- when stdin and stdout are both connected to a terminal, ensure
 129              -- that anything buffered on stdout is flushed prior to reading from stdin.
 130              --
 131             hConnectTerms stdout hdl
 132             return hdl
 133        _ -> do ioError <- constructError "stdin"
 134                newHandle (mkErrorHandle__ ioError)
 135   )
 136
 137
 138 stderr = unsafePerformIO (do
 139     rc <- _ccall_ getLock 2 1  -- ConcHask: SAFE, won't block
 140     case rc of
 141        0 -> newHandle (mkClosedHandle__)
 142        1 -> do
 143 #ifndef __CONCURRENT_HASKELL__
 144             fo <- _ccall_ openStdFile 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
 145 #else
 146             fo <- _ccall_ openStdFile 2 (1{-flush on close-} + 128{-don't block on I/O-})
 147                                         0{-writeable-} -- ConcHask: SAFE, won't block
 148 #endif
 149
 150 #ifndef __PARALLEL_HASKELL__
 151             fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
 152 #endif
 153             newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
 154        _ -> do ioError <- constructError "stderr"
 155                newHandle (mkErrorHandle__ ioError)
 156   )
 157 \end{code}
 158
 159 %*********************************************************
 160 %*                                                      *
 161 \subsection[OpeningClosing]{Opening and Closing Files}
 162 %*                                                      *
 163 %*********************************************************
 164
 165 \begin{code}
 166 data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
 167                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 168
 169 data IOModeEx
 170  = BinaryMode IOMode
 171  | TextMode   IOMode
 172    deriving (Eq, Read, Show)
 173
 174 openFile :: FilePath -> IOMode -> IO Handle
 175 openFile fp im = openFileEx fp (TextMode im)
 176
 177 openFileEx :: FilePath -> IOModeEx -> IO Handle
 178
 179 openFileEx f m = do
 180     fo <- _ccall_ openFile f file_mode binary flush_on_close  -- ConcHask: SAFE, won't block
 181     if fo /= nullAddr then do
 182 #ifndef __PARALLEL_HASKELL__
 183         fo  <- makeForeignObj fo ((``&freeFileObject'')::Addr)
 184 #endif
 185         (bm, bf_size)  <- getBMode__ fo
 186         mkBuffer__ fo bf_size
 187         newHandle (Handle__ fo htype bm f)
 188       else do
 189         constructErrorAndFailWithInfo "openFile" f
 190   where
 191     (imo, binary) =
 192       case m of
 193         BinaryMode imo -> (imo, 1)
 194         TextMode imo   -> (imo, 0)
 195
 196 #ifndef __CONCURRENT_HASKELL__
 197     file_mode = file_mode'
 198 #else
 199     file_mode = file_mode' + 128{-Don't block on I/O-}
 200 #endif
 201
 202     (flush_on_close, file_mode') =
 203       case imo of
 204            AppendMode    -> (1, 0)
 205            WriteMode     -> (1, 1)
 206            ReadMode      -> (0, 2)
 207            ReadWriteMode -> (1, 3)
 208
 209     htype = case imo of
 210               ReadMode      -> ReadHandle
 211               WriteMode     -> WriteHandle
 212               AppendMode    -> AppendHandle
 213               ReadWriteMode -> ReadWriteHandle
 214 \end{code}
 215
 216 Computation $openFile file mode$ allocates and returns a new, open
 217 handle to manage the file {\em file}.  It manages input if {\em mode}
 218 is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
 219 and both input and output if mode is $ReadWriteMode$.
 220
 221 If the file does not exist and it is opened for output, it should be
 222 created as a new file.  If {\em mode} is $WriteMode$ and the file
 223 already exists, then it should be truncated to zero length.  The
 224 handle is positioned at the end of the file if {\em mode} is
 225 $AppendMode$, and otherwise at the beginning (in which case its
 226 internal position is 0).
 227
 228 Implementations should enforce, locally to the Haskell process,
 229 multiple-reader single-writer locking on files, which is to say that
 230 there may either be many handles on the same file which manage input,
 231 or just one handle on the file which manages output.  If any open or
 232 semi-closed handle is managing a file for output, no new handle can be
 233 allocated for that file.  If any open or semi-closed handle is
 234 managing a file for input, new handles can only be allocated if they
 235 do not manage output.
 236
 237 Two files are the same if they have the same absolute name.  An
 238 implementation is free to impose stricter conditions.
 239
 240 \begin{code}
 241 hClose :: Handle -> IO ()
 242
 243 hClose handle = do
 244     handle_ <- readHandle handle
 245     case haType__ handle_ of
 246       ErrorHandle ioError -> do
 247           writeHandle handle handle_
 248           fail ioError
 249       ClosedHandle -> do
 250           writeHandle handle handle_
 251           ioe_closedHandle "hClose" handle
 252       _ -> do
 253           rc      <- _ccall_ closeFile (haFO__ handle_) 1{-flush if you can-}  -- ConcHask: SAFE, won't block
 254           {- We explicitly close a file object so that we can be told
 255              if there were any errors. Note that after @hClose@
 256              has been performed, the ForeignObj embedded in the Handle
 257              is still lying around in the heap, so care is taken
 258              to avoid closing the file object when the ForeignObj
 259              is finalised. (we overwrite the file ptr in the underlying
 260              FileObject with a NULL as part of closeFile())
 261           -}
 262           if rc == 0
 263            then
 264               writeHandle handle (handle_{ haType__   = ClosedHandle,
 265                                            haFO__     = nullFile__ })
 266            else do
 267              writeHandle handle handle_
 268              constructErrorAndFail "hClose"
 269
 270 \end{code}
 271
 272 Computation $hClose hdl$ makes handle {\em hdl} closed.  Before the
 273 computation finishes, any items buffered for output and not already
 274 sent to the operating system are flushed as for $flush$.
 275
 276 %*********************************************************
 277 %*                                                      *
 278 \subsection[EOF]{Detecting the End of Input}
 279 %*                                                      *
 280 %*********************************************************
 281
 282
 283 For a handle {\em hdl} which attached to a physical file, $hFileSize
 284 hdl$ returns the size of {\em hdl} in terms of the number of items
 285 which can be read from {\em hdl}.
 286
 287 \begin{code}
 288 hFileSize :: Handle -> IO Integer
 289 hFileSize handle = do
 290     handle_ <- readHandle handle
 291     case haType__ handle_ of
 292       ErrorHandle ioError -> do
 293           writeHandle handle handle_
 294           fail ioError
 295       ClosedHandle -> do
 296           writeHandle handle handle_
 297           ioe_closedHandle "hFileSize" handle
 298       SemiClosedHandle -> do
 299           writeHandle handle handle_
 300           ioe_closedHandle "hFileSize" handle
 301       other ->
 302           -- HACK!  We build a unique MP_INT of the right shape to hold
 303           -- a single unsigned word, and we let the C routine
 304           -- change the data bits
 305           --
 306           -- For some reason, this fails to typecheck if converted to a do
 307           -- expression --SDM
 308           _casm_ ``%r = 1;'' >>= \(I# hack#) ->
 309           case int2Integer# hack# of
 310             result@(J# _ _ d#) -> do
 311                 rc <- _ccall_ fileSize (haFO__ handle_) d#  -- ConcHask: SAFE, won't block
 312                 writeHandle handle handle_
 313                 if rc == 0 then
 314                    return result
 315                  else
 316                    constructErrorAndFail "hFileSize"
 317 \end{code}
 318
 319 For a readable handle {\em hdl}, @hIsEOF hdl@ returns
 320 @True@ if no further input can be taken from @hdl@ or for a
 321 physical file, if the current I/O position is equal to the length of
 322 the file.  Otherwise, it returns @False@.
 323
 324 \begin{code}
 325 hIsEOF :: Handle -> IO Bool
 326 hIsEOF handle = do
 327     handle_ <- wantReadableHandle "hIsEOF" handle
 328     let fo = haFO__ handle_
 329     rc      <- mayBlock fo (_ccall_ fileEOF fo)  -- ConcHask: UNSAFE, may block
 330     writeHandle handle handle_
 331     case rc of
 332       0 -> return False
 333       1 -> return True
 334       _ -> constructErrorAndFail "hIsEOF"
 335
 336 isEOF :: IO Bool
 337 isEOF = hIsEOF stdin
 338 \end{code}
 339
 340 %*********************************************************
 341 %*                                                      *
 342 \subsection[Buffering]{Buffering Operations}
 343 %*                                                      *
 344 %*********************************************************
 345
 346 Three kinds of buffering are supported: line-buffering,
 347 block-buffering or no-buffering.  See @IOBase@ for definition
 348 and further explanation of what the type represent.
 349
 350 Computation @hSetBuffering hdl mode@ sets the mode of buffering for
 351 handle {\em hdl} on subsequent reads and writes.
 352
 353 \begin{itemize}
 354 \item
 355 If {\em mode} is @LineBuffering@, line-buffering should be
 356 enabled if possible.
 357 \item
 358 If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
 359 should be enabled if possible.  The size of the buffer is {\em n} items
 360 if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
 361 \item
 362 If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
 363 \end{itemize}
 364
 365 If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
 366 to @NoBuffering@, then any items in the output buffer are written to
 367 the device, and any items in the input buffer are discarded.  The
 368 default buffering mode when a handle is opened is
 369 implementation-dependent and may depend on the object which is
 370 attached to that handle.
 371
 372 \begin{code}
 373 hSetBuffering :: Handle -> BufferMode -> IO ()
 374
 375 hSetBuffering handle mode =
 376     case mode of
 377       BlockBuffering (Just n)
 378         | n <= 0 -> fail (IOError (Just handle)
 379                                   InvalidArgument
 380                                   "hSetBuffering"
 381                                   ("illegal buffer size " ++ showsPrec 9 n []))  -- 9 => should be parens'ified.
 382       _ -> do
 383           handle_ <- readHandle handle
 384           case haType__ handle_ of
 385              ErrorHandle ioError -> do
 386                 writeHandle handle handle_
 387                 fail ioError
 388              ClosedHandle -> do
 389                 writeHandle handle handle_
 390                 ioe_closedHandle "hSetBuffering" handle
 391              _ -> do
 392                 {- Note:
 393                     - we flush the old buffer regardless of whether
 394                       the new buffer could fit the contents of the old buffer
 395                       or not.
 396                     - allow a handle's buffering to change even if IO has
 397                       occurred (ANSI C spec. does not allow this, nor did
 398                       the previous implementation of IO.hSetBuffering).
 399                     - a non-standard extension is to allow the buffering
 400                       of semi-closed handles to change [sof 6/98]
 401                 -}
 402                 let fo = haFO__ handle_
 403                 rc <- mayBlock fo (_ccall_ setBuffering fo bsize) -- ConcHask: UNSAFE, may block
 404                 if rc == 0
 405                  then do
 406                    writeHandle handle (handle_{ haBufferMode__ = mode })
 407                  else do
 408                    -- Note: failure to change the buffer size will cause old buffer to be flushed.
 409                    writeHandle handle handle_
 410                    constructErrorAndFail "hSetBuffering"
 411   where
 412     bsize :: Int
 413     bsize = case mode of
 414               NoBuffering             ->  0
 415               LineBuffering           -> -1
 416               BlockBuffering Nothing  -> -2
 417               BlockBuffering (Just n) ->  n
 418 \end{code}
 419
 420 The action @hFlush hdl@ causes any items buffered for output
 421 in handle {\em hdl} to be sent immediately to the operating
 422 system.
 423
 424 \begin{code}
 425 hFlush :: Handle -> IO ()
 426 hFlush handle = do
 427     handle_ <- wantWriteableHandle "hFlush" handle
 428     let fo = haFO__ handle_
 429     rc      <- mayBlock fo (_ccall_ flushFile fo)   -- ConcHask: UNSAFE, may block
 430     writeHandle handle handle_
 431     if rc == 0 then
 432        return ()
 433      else
 434        constructErrorAndFail "hFlush"
 435
 436 \end{code}
 437
 438
 439 %*********************************************************
 440 %*                                                      *
 441 \subsection[Seeking]{Repositioning Handles}
 442 %*                                                      *
 443 %*********************************************************
 444
 445 \begin{code}
 446 data HandlePosn
 447  = HandlePosn
 448         Handle   -- Q: should this be a weak or strong ref. to the handle?
 449         Int
 450
 451 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 452                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 453 \end{code}
 454
 455 Computation @hGetPosn hdl@ returns the current I/O
 456 position of {\em hdl} as an abstract position.  Computation
 457 $hSetPosn p$ sets the position of {\em hdl}
 458 to a previously obtained position {\em p}.
 459
 460 \begin{code}
 461 hGetPosn :: Handle -> IO HandlePosn
 462 hGetPosn handle = do
 463     handle_ <- wantSeekableHandle "hGetPosn" handle
 464     posn    <- _ccall_ getFilePosn (haFO__ handle_)   -- ConcHask: SAFE, won't block
 465     writeHandle handle handle_
 466     if posn /= -1 then
 467       return (HandlePosn handle posn)
 468      else
 469       constructErrorAndFail "hGetPosn"
 470
 471 hSetPosn :: HandlePosn -> IO ()
 472 hSetPosn (HandlePosn handle posn) = do
 473     handle_ <- wantSeekableHandle "hSetPosn" handle -- not as silly as it looks: the handle may have been closed in the meantime.
 474     let fo = haFO__ handle_
 475     rc     <- mayBlock fo (_ccall_ setFilePosn fo posn)    -- ConcHask: UNSAFE, may block
 476     writeHandle handle handle_
 477     if rc == 0 then
 478        return ()
 479      else
 480         constructErrorAndFail "hSetPosn"
 481 \end{code}
 482
 483 The action @hSeek hdl mode i@ sets the position of handle
 484 @hdl@ depending on @mode@.  If @mode@ is
 485 \begin{itemize}
 486 \item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
 487 \item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
 488 the current position.
 489 \item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
 490 the end of the file.
 491 \end{itemize}
 492
 493 Some handles may not be seekable (see @hIsSeekable@), or only support a
 494 subset of the possible positioning operations (e.g. it may only be
 495 possible to seek to the end of a tape, or to a positive offset from
 496 the beginning or current position).
 497
 498 It is not possible to set a negative I/O position, or for a physical
 499 file, an I/O position beyond the current end-of-file.
 500
 501 Note:
 502  - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
 503    at or past EOF.
 504  - relative seeking on buffered handles can lead to non-obvious results.
 505
 506 \begin{code}
 507 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 508 hSeek handle mode offset@(J# _ s# d#) =  do
 509     handle_ <- wantSeekableHandle "hSeek" handle
 510     let fo = haFO__ handle_
 511     rc      <- mayBlock fo (_ccall_ seekFile  fo whence (I# s#) d#)  -- ConcHask: UNSAFE, may block
 512     writeHandle handle handle_
 513     if rc == 0 then
 514        return ()
 515      else
 516         constructErrorAndFail "hSeek"
 517   where
 518     whence :: Int
 519     whence = case mode of
 520                AbsoluteSeek -> 0
 521                RelativeSeek -> 1
 522                SeekFromEnd  -> 2
 523 \end{code}
 524
 525 %*********************************************************
 526 %*                                                      *
 527 \subsection[Query]{Handle Properties}
 528 %*                                                      *
 529 %*********************************************************
 530
 531 A number of operations return information about the properties of a
 532 handle.  Each of these operations returns $True$ if the
 533 handle has the specified property, and $False$
 534 otherwise.
 535
 536 Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
 537 {\em hdl} is not block-buffered.  Otherwise it returns
 538 $( True, size )$, where {\em size} is $Nothing$ for default buffering, and
 539 $( Just n )$ for block-buffering of {\em n} bytes.
 540
 541 \begin{code}
 542 hIsOpen :: Handle -> IO Bool
 543 hIsOpen handle = do
 544     handle_ <- readHandle handle
 545     case haType__ handle_ of
 546       ErrorHandle ioError -> do
 547           writeHandle handle handle_
 548           fail ioError
 549       ClosedHandle -> do
 550           writeHandle handle handle_
 551           return False
 552       SemiClosedHandle -> do
 553           writeHandle handle handle_
 554           return False
 555       _ -> do
 556           writeHandle handle handle_
 557           return True
 558
 559 hIsClosed :: Handle -> IO Bool
 560 hIsClosed handle = do
 561     handle_ <- readHandle handle
 562     case haType__ handle_ of
 563       ErrorHandle ioError -> do
 564           writeHandle handle handle_
 565           fail ioError
 566       ClosedHandle -> do
 567           writeHandle handle handle_
 568           return True
 569       _ -> do
 570           writeHandle handle handle_
 571           return False
 572
 573 {- not defined, nor exported, but mentioned
 574    here for documentation purposes:
 575
 576     hSemiClosed :: Handle -> IO Bool
 577     hSemiClosed h = do
 578        ho <- hIsOpen h
 579        hc <- hIsClosed h
 580        return (not (ho || hc))
 581 -}
 582
 583 hIsReadable :: Handle -> IO Bool
 584 hIsReadable handle = do
 585     handle_ <- readHandle handle
 586     case haType__ handle_ of
 587       ErrorHandle ioError -> do
 588           writeHandle handle handle_
 589           fail ioError
 590       ClosedHandle -> do
 591           writeHandle handle handle_
 592           ioe_closedHandle "hIsReadable" handle
 593       SemiClosedHandle -> do
 594           writeHandle handle handle_
 595           ioe_closedHandle "hIsReadable" handle
 596       htype -> do
 597           writeHandle handle handle_
 598           return (isReadable htype)
 599   where
 600     isReadable ReadHandle      = True
 601     isReadable ReadWriteHandle = True
 602     isReadable _               = False
 603
 604 hIsWritable :: Handle -> IO Bool
 605 hIsWritable handle = do
 606     handle_ <- readHandle handle
 607     case haType__ handle_ of
 608       ErrorHandle ioError -> do
 609           writeHandle handle handle_
 610           fail ioError
 611       ClosedHandle -> do
 612           writeHandle handle handle_
 613           ioe_closedHandle "hIsWritable" handle
 614       SemiClosedHandle -> do
 615           writeHandle handle handle_
 616           ioe_closedHandle "hIsWritable" handle
 617       htype -> do
 618           writeHandle handle handle_
 619           return (isWritable htype)
 620   where
 621     isWritable AppendHandle    = True
 622     isWritable WriteHandle     = True
 623     isWritable ReadWriteHandle = True
 624     isWritable _               = False
 625
 626
 627 #ifndef __PARALLEL_HASKELL__
 628 getBMode__ :: ForeignObj -> IO (BufferMode, Int)
 629 #else
 630 getBMode__ :: Addr -> IO (BufferMode, Int)
 631 #endif
 632 getBMode__ fo = do
 633   rc <- _ccall_ getBufferMode fo    -- ConcHask: SAFE, won't block
 634   case (rc::Int) of
 635     0  -> return (NoBuffering, 0)
 636     -1 -> return (LineBuffering, default_buffer_size)
 637     -2 -> return (BlockBuffering Nothing, default_buffer_size)
 638     -3 -> return (NoBuffering, 0)               -- only happens on un-stat()able files.
 639     n  -> return (BlockBuffering (Just n), n)
 640  where
 641    default_buffer_size :: Int
 642    default_buffer_size = (``BUFSIZ'' - 1)
 643 \end{code}
 644
 645 Querying how a handle buffers its data:
 646
 647 \begin{code}
 648 hGetBuffering :: Handle -> IO BufferMode
 649 hGetBuffering handle = do
 650     handle_ <- readHandle handle
 651     case haType__ handle_ of
 652       ErrorHandle ioError -> do
 653           writeHandle handle handle_
 654           fail ioError
 655       ClosedHandle -> do
 656           writeHandle handle handle_
 657           ioe_closedHandle "hGetBuffering" handle
 658       _ -> do
 659           {-
 660            We're being non-standard here, and allow the buffering
 661            of a semi-closed handle to be queried.   -- sof 6/98
 662           -}
 663           let v = haBufferMode__ handle_
 664           writeHandle handle handle_
 665           return v  -- could be stricter..
 666
 667 \end{code}
 668
 669 \begin{code}
 670 hIsSeekable :: Handle -> IO Bool
 671 hIsSeekable handle = do
 672     handle_ <- readHandle handle
 673     case haType__ handle_ of
 674       ErrorHandle ioError -> do
 675           writeHandle handle handle_
 676           fail ioError
 677       ClosedHandle -> do
 678           writeHandle handle handle_
 679           ioe_closedHandle "hIsSeekable" handle
 680       SemiClosedHandle -> do
 681           writeHandle handle handle_
 682           ioe_closedHandle "hIsSeekable" handle
 683       AppendHandle -> do
 684           writeHandle handle handle_
 685           return False
 686       other -> do
 687           rc <- _ccall_ seekFileP (haFO__ handle_)   -- ConcHask: SAFE, won't block
 688           writeHandle handle handle_
 689           case rc of
 690             0 -> return False
 691             1 -> return True
 692             _ -> constructErrorAndFail "hIsSeekable"
 693 \end{code}
 694
 695
 696 %*********************************************************
 697 %*                                                      *
 698 \subsection{Changing echo status}
 699 %*                                                      *
 700 %*********************************************************
 701
 702 Non-standard GHC extension is to allow the echoing status
 703 of a handles connected to terminals to be reconfigured:
 704
 705 \begin{code}
 706 hSetEcho :: Handle -> Bool -> IO ()
 707 hSetEcho hdl on = do
 708     isT   <- hIsTerminalDevice hdl
 709     if not isT
 710      then return ()
 711      else do
 712       handle_ <- readHandle hdl
 713       case haType__ handle_ of
 714          ErrorHandle ioError ->  do
 715             writeHandle hdl handle_
 716             fail ioError
 717          ClosedHandle      ->  do
 718             writeHandle hdl handle_
 719             ioe_closedHandle "hSetEcho" hdl
 720          other -> do
 721             rc <- _ccall_ setTerminalEcho (haFO__ handle_) (if on then 1 else 0)  -- ConcHask: SAFE, won't block
 722             writeHandle hdl handle_
 723             if rc /= -1
 724              then return ()
 725              else constructErrorAndFail "hSetEcho"
 726
 727 hGetEcho :: Handle -> IO Bool
 728 hGetEcho hdl = do
 729     isT   <- hIsTerminalDevice hdl
 730     if not isT
 731      then return False
 732      else do
 733        handle_ <- readHandle hdl
 734        case haType__ handle_ of
 735          ErrorHandle ioError ->  do
 736             writeHandle hdl handle_
 737             fail ioError
 738          ClosedHandle      ->  do
 739             writeHandle hdl handle_
 740             ioe_closedHandle "hGetEcho" hdl
 741          other -> do
 742             rc <- _ccall_ getTerminalEcho (haFO__ handle_)  -- ConcHask: SAFE, won't block
 743             writeHandle hdl handle_
 744             case rc of
 745               1 -> return True
 746               0 -> return False
 747               _ -> constructErrorAndFail "hSetEcho"
 748
 749 hIsTerminalDevice :: Handle -> IO Bool
 750 hIsTerminalDevice hdl = do
 751     handle_ <- readHandle hdl
 752     case haType__ handle_ of
 753        ErrorHandle ioError ->  do
 754             writeHandle hdl handle_
 755             fail ioError
 756        ClosedHandle        ->  do
 757             writeHandle hdl handle_
 758             ioe_closedHandle "hIsTerminalDevice" hdl
 759        other -> do
 760           rc <- _ccall_ isTerminalDevice (haFO__ handle_)   -- ConcHask: SAFE, won't block
 761           writeHandle hdl handle_
 762           case rc of
 763             1 -> return True
 764             0 -> return False
 765             _ -> constructErrorAndFail "hIsTerminalDevice"
 766 \end{code}
 767
 768 \begin{code}
 769 hConnectTerms :: Handle -> Handle -> IO ()
 770 hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
 771
 772 hConnectTo :: Handle -> Handle -> IO ()
 773 hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
 774
 775 hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
 776 hConnectHdl_ hW hR is_tty = do
 777   hW_ <- wantWriteableHandle "hConnectTo" hW
 778   hR_ <- wantReadableHandle  "hConnectTo" hR
 779   _ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty  -- ConcHask: SAFE, won't block
 780   writeHandle hR hR_
 781   writeHandle hW hW_
 782
 783 \end{code}
 784
 785 As an extension, we also allow characters to be pushed back.
 786 Like ANSI C stdio, we guarantee no more than one character of
 787 pushback. (For unbuffered channels, the (default) push-back limit is
 788 2 chars tho.)
 789
 790 \begin{code}
 791 hUngetChar :: Handle -> Char -> IO ()
 792 hUngetChar handle c = do
 793     handle_ <- wantReadableHandle "hLookAhead" handle
 794     rc      <- _ccall_ ungetChar (haFO__ handle_) (ord c)  -- ConcHask: SAFE, won't block
 795     writeHandle handle handle_
 796     if rc == (-1)
 797      then constructErrorAndFail "hUngetChar"
 798      else return ()
 799
 800 \end{code}
 801
 802
 803 Hoisting files in in one go is sometimes useful, so we support
 804 this as an extension:
 805
 806 \begin{code}
 807 -- in one go, read file into an externally allocated buffer.
 808 slurpFile :: FilePath -> IO (Addr, Int)
 809 slurpFile fname = do
 810   hdl <- openFile fname ReadMode
 811   sz  <- hFileSize hdl
 812   if sz > toInteger (maxBound::Int) then
 813     fail (userError "slurpFile: file too big")
 814    else do
 815      let sz_i = fromInteger sz
 816      chunk <- _ccall_ allocMemory__ (sz_i::Int)
 817      if chunk == nullAddr
 818       then do
 819         hClose hdl
 820         constructErrorAndFail "slurpFile"
 821       else do
 822         handle_ <- readHandle hdl
 823         let fo = haFO__ handle_
 824         rc      <- mayBlock fo (_ccall_ readChunk fo chunk sz_i)    -- ConcHask: UNSAFE, may block.
 825         writeHandle hdl handle_
 826         hClose hdl
 827         if rc < 0
 828          then constructErrorAndFail "slurpFile"
 829          else return (chunk, rc)
 830
 831 hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
 832 hFillBufBA handle buf sz
 833   | sz <= 0 = fail (IOError (Just handle)
 834                             InvalidArgument
 835                             "hFillBufBA"
 836                             ("illegal buffer size " ++ showsPrec 9 sz []))  -- 9 => should be parens'ified.
 837   | otherwise = do
 838     handle_ <- wantReadableHandle "hFillBufBA" handle
 839     let fo  = haFO__ handle_
 840     rc      <- mayBlock fo (_ccall_ readChunk fo buf sz)    -- ConcHask: UNSAFE, may block.
 841     writeHandle handle handle_
 842     if rc >= 0
 843      then return rc
 844      else constructErrorAndFail "hFillBufBA"
 845
 846 hFillBuf :: Handle -> Addr -> Int -> IO Int
 847 hFillBuf handle buf sz
 848   | sz <= 0 = fail (IOError (Just handle)
 849                             InvalidArgument
 850                             "hFillBuf"
 851                             ("illegal buffer size " ++ showsPrec 9 sz []))  -- 9 => should be parens'ified.
 852   | otherwise = do
 853     handle_ <- wantReadableHandle "hFillBuf" handle
 854     let fo  = haFO__ handle_
 855     rc      <- mayBlock fo (_ccall_ readChunk fo buf sz)    -- ConcHask: UNSAFE, may block.
 856     writeHandle handle handle_
 857     if rc >= 0
 858      then return rc
 859      else constructErrorAndFail "hFillBuf"
 860
 861 \end{code}
 862
 863 The @hPutBuf hdl buf len@ action writes an already packed sequence of
 864 bytes to the file/channel managed by @hdl@ - non-standard.
 865
 866 \begin{code}
 867 hPutBuf :: Handle -> Addr -> Int -> IO ()
 868 hPutBuf handle buf len = do
 869     handle_ <- wantWriteableHandle "hPutBuf" handle
 870     let fo  = haFO__ handle_
 871     rc      <- mayBlock fo (_ccall_ writeBuf fo buf len)  -- ConcHask: UNSAFE, may block.
 872     writeHandle handle handle_
 873     if rc == 0
 874      then return ()
 875      else constructErrorAndFail "hPutBuf"
 876
 877 hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
 878 hPutBufBA handle buf len = do
 879     handle_ <- wantWriteableHandle "hPutBufBA" handle
 880     let fo = haFO__ handle_
 881     rc      <- mayBlock fo (_ccall_ writeBufBA fo buf len)  -- ConcHask: UNSAFE, may block.
 882     writeHandle handle handle_
 883     if rc == 0
 884      then return ()
 885      else constructErrorAndFail "hPutBuf"
 886 \end{code}
 887
 888 Sometimes it's useful to get at the file descriptor that
 889 the Handle contains..
 890
 891 \begin{code}
 892 getHandleFd :: Handle -> IO Int
 893 getHandleFd handle = do
 894     handle_ <- readHandle handle
 895     case (haType__ handle_) of
 896       ErrorHandle ioError -> do
 897           writeHandle handle handle_
 898           fail ioError
 899       ClosedHandle -> do
 900           writeHandle handle handle_
 901           ioe_closedHandle "getHandleFd" handle
 902       _ -> do
 903           fd <- _ccall_ getFileFd (haFO__ handle_)
 904           writeHandle handle handle_
 905           return fd
 906 \end{code}
 907
 908
 909 %*********************************************************
 910 %*                                                      *
 911 \subsection{Miscellaneous}
 912 %*                                                      *
 913 %*********************************************************
 914
 915 These three functions are meant to get things out of @IOErrors@.
 916
 917 (ToDo: improve!)
 918
 919 \begin{code}
 920 ioeGetFileName        :: IOError -> Maybe FilePath
 921 ioeGetErrorString     :: IOError -> String
 922 ioeGetHandle          :: IOError -> Maybe Handle
 923
 924 ioeGetHandle   (IOError h _ _ _)   = h
 925 ioeGetErrorString (IOError _ iot _ str) =
 926  case iot of
 927    EOF -> "end of file"
 928    _   -> str
 929
 930 ioeGetFileName (IOError _ _  _ str) =
 931  case span (/=':') str of
 932    (fs,[]) -> Nothing
 933    (fs,_)  -> Just fs
 934
 935 \end{code}
 936
 937 A number of operations want to get at a readable or writeable handle, and fail
 938 if it isn't:
 939
 940 \begin{code}
 941 wantReadableHandle :: String -> Handle -> IO Handle__
 942 wantReadableHandle fun handle = do
 943     handle_ <- readHandle handle
 944     case haType__ handle_ of
 945       ErrorHandle ioError -> do
 946           writeHandle handle handle_
 947           fail ioError
 948       ClosedHandle -> do
 949           writeHandle handle handle_
 950           ioe_closedHandle fun handle
 951       SemiClosedHandle -> do
 952           writeHandle handle handle_
 953           ioe_closedHandle fun handle
 954       AppendHandle -> do
 955           writeHandle handle handle_
 956           fail not_readable_error
 957       WriteHandle -> do
 958           writeHandle handle handle_
 959           fail not_readable_error
 960       other -> return handle_
 961   where
 962    not_readable_error =
 963            IOError (Just handle) IllegalOperation fun
 964                    ("handle is not open for reading")
 965
 966 wantWriteableHandle :: String -> Handle -> IO Handle__
 967 wantWriteableHandle fun handle = do
 968     handle_ <- readHandle handle
 969     case haType__ handle_ of
 970       ErrorHandle ioError -> do
 971           writeHandle handle handle_
 972           fail ioError
 973       ClosedHandle -> do
 974           writeHandle handle handle_
 975           ioe_closedHandle fun handle
 976       SemiClosedHandle -> do
 977           writeHandle handle handle_
 978           ioe_closedHandle fun handle
 979       ReadHandle -> do
 980           writeHandle handle handle_
 981           fail not_writeable_error
 982       other -> return handle_
 983   where
 984    not_writeable_error =
 985            IOError (Just handle) IllegalOperation fun
 986                    ("handle is not open for writing")
 987
 988 wantSeekableHandle :: String -> Handle -> IO Handle__
 989 wantSeekableHandle fun handle = do
 990     handle_ <- readHandle handle
 991     case haType__ handle_ of
 992       ErrorHandle ioError -> do
 993           writeHandle handle handle_
 994           fail ioError
 995       ClosedHandle -> do
 996           writeHandle handle handle_
 997           ioe_closedHandle fun handle
 998       SemiClosedHandle -> do
 999           writeHandle handle handle_
1000           ioe_closedHandle fun handle
1001       AppendHandle -> do
1002           writeHandle handle handle_
1003           fail not_seekable_error
1004       _ -> return handle_
1005   where
1006    not_seekable_error =
1007            IOError (Just handle)
1008                    IllegalOperation fun
1009                    ("handle is not seekable")
1010
1011 \end{code}
1012
1013 Internal function for creating an @IOError@ representing the
1014 access to a closed file.
1015
1016 \begin{code}
1017 ioe_closedHandle :: String -> Handle -> IO a
1018 ioe_closedHandle fun h = fail (IOError (Just h) IllegalOperation fun "handle is closed")
1019 \end{code}
1020
1021 Internal helper functions for Concurrent Haskell implementation
1022 of IO:
1023
1024 \begin{code}
1025 #ifndef __PARALLEL_HASKELL__
1026 mayBlock :: ForeignObj -> IO Int -> IO Int
1027 #else
1028 mayBlock :: Addr  -> IO Int -> IO Int
1029 #endif
1030
1031 #ifndef __CONCURRENT_HASKELL__
1032 mayBlock  _ act = act
1033 #else
1034 mayBlock fo act = do
1035    rc <- act
1036    case rc of
1037      -5 -> do  -- (possibly blocking) read
1038         fd <- _ccall_ getFileFd fo
1039         threadWaitRead fd
1040         _ccall_ clearNonBlockingIOFlag__ fo  -- force read to happen this time.
1041         mayBlock fo act  -- input available, re-try
1042      -6 -> do  -- (possibly blocking) write
1043         fd <- _ccall_ getFileFd fo
1044         threadWaitWrite fd
1045         _ccall_ clearNonBlockingIOFlag__ fo  -- force write to happen this time.
1046         mayBlock fo act  -- output possible
1047      -7 -> do  -- (possibly blocking) write on connected handle
1048         fd <- _ccall_ getConnFileFd fo
1049         threadWaitWrite fd
1050         _ccall_ clearConnNonBlockingIOFlag__ fo  -- force write to happen this time.
1051         mayBlock fo act  -- output possible
1052      _ -> do
1053         _ccall_ setNonBlockingIOFlag__ fo      -- reset file object.
1054         _ccall_ setConnNonBlockingIOFlag__ fo  -- reset (connected) file object.
1055         return rc
1056
1057 #endif
1058 \end{code}
1059
1060