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