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