ghc/lib/std/PrelIO.lhs

   1 %
   2 % (c) The GRAP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[PrelIO]{Module @PrelIO@}
   5
   6 This module defines all basic IO operations.
   7 These are needed for the IO operations exported by Prelude,
   8 but as it happens they also do everything required by library
   9 module IO.
  10
  11
  12 \begin{code}
  13 {-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
  14
  15 module PrelIO where
  16
  17 import PrelBase
  18
  19 import PrelIOBase
  20 import PrelHandle       -- much of the real stuff is in here
  21
  22 import PrelNum
  23 import PrelRead         ( readParen, Read(..), reads, lex,
  24                           readIO
  25                         )
  26 import PrelShow
  27 import PrelMaybe        ( Either(..), Maybe(..) )
  28 import PrelAddr         ( Addr(..), AddrOff(..), nullAddr, plusAddr )
  29 import PrelByteArr      ( ByteArray )
  30 import PrelPack         ( unpackNBytesAccST )
  31 import PrelException    ( ioError, catch, catchException, throw, blockAsyncExceptions )
  32 import PrelConc
  33 \end{code}
  34
  35
  36 %*********************************************************
  37 %*                                                       *
  38 \subsection{Standard IO}
  39 %*                                                       *
  40 %*********************************************************
  41
  42 The Prelude has from Day 1 provided a collection of common
  43 IO functions. We define these here, but let the Prelude
  44 export them.
  45
  46 \begin{code}
  47 putChar         :: Char -> IO ()
  48 putChar c       =  hPutChar stdout c
  49
  50 putStr          :: String -> IO ()
  51 putStr s        =  hPutStr stdout s
  52
  53 putStrLn        :: String -> IO ()
  54 putStrLn s      =  do putStr s
  55                       putChar '\n'
  56
  57 print           :: Show a => a -> IO ()
  58 print x         =  putStrLn (show x)
  59
  60 getChar         :: IO Char
  61 getChar         =  hGetChar stdin
  62
  63 getLine         :: IO String
  64 getLine         =  hGetLine stdin
  65
  66 getContents     :: IO String
  67 getContents     =  hGetContents stdin
  68
  69 interact        ::  (String -> String) -> IO ()
  70 interact f      =   do s <- getContents
  71                        putStr (f s)
  72
  73 readFile        :: FilePath -> IO String
  74 readFile name   =  openFile name ReadMode >>= hGetContents
  75
  76 writeFile       :: FilePath -> String -> IO ()
  77 writeFile name str = do
  78     hdl <- openFile name WriteMode
  79     hPutStr hdl str
  80     hClose hdl
  81
  82 appendFile      :: FilePath -> String -> IO ()
  83 appendFile name str = do
  84     hdl <- openFile name AppendMode
  85     hPutStr hdl str
  86     hClose hdl
  87
  88 readLn          :: Read a => IO a
  89 readLn          =  do l <- getLine
  90                       r <- readIO l
  91                       return r
  92 \end{code}
  93
  94
  95 %*********************************************************
  96 %*                                                      *
  97 \subsection{Simple input operations}
  98 %*                                                      *
  99 %*********************************************************
 100
 101 Computation @hReady hdl@ indicates whether at least
 102 one item is available for input from handle {\em hdl}.
 103
 104 @hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
 105 before deciding whether the Handle has run dry or not.
 106
 107 If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
 108 If not, it tries to read from the underlying OS handle. Notice that
 109 for buffered Handles connected to terminals this means waiting until a complete
 110 line is available.
 111
 112 \begin{code}
 113 hReady :: Handle -> IO Bool
 114 hReady h = hWaitForInput h 0
 115
 116 hWaitForInput :: Handle -> Int -> IO Bool
 117 hWaitForInput handle msecs =
 118     wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
 119     rc       <- inputReady (haFO__ handle_) (msecs::Int)     -- ConcHask: SAFE, won't block
 120     case (rc::Int) of
 121       0 -> return False
 122       1 -> return True
 123       _ -> constructErrorAndFail "hWaitForInput"
 124 \end{code}
 125
 126 @hGetChar hdl@ reads the next character from handle @hdl@,
 127 blocking until a character is available.
 128
 129 \begin{code}
 130 hGetChar :: Handle -> IO Char
 131 hGetChar handle = do
 132   c <- mayBlockRead "hGetChar" handle fileGetc
 133   return (chr c)
 134
 135 {-
 136   If EOF is reached before EOL is encountered, ignore the
 137   EOF and return the partial line. Next attempt at calling
 138   hGetLine on the handle will yield an EOF IO exception though.
 139 -}
 140 hGetLine :: Handle -> IO String
 141 hGetLine h = do
 142   c <- hGetChar h
 143   if c == '\n' then
 144      return ""
 145    else do
 146     l <- getRest
 147     return (c:l)
 148  where
 149   getRest = do
 150     c <-
 151       catch
 152         (hGetChar h)
 153         (\ err -> do
 154           if isEOFError err then
 155              return '\n'
 156            else
 157              ioError err)
 158     if c == '\n' then
 159        return ""
 160      else do
 161        s <- getRest
 162        return (c:s)
 163
 164 \end{code}
 165
 166 @hLookahead hdl@ returns the next character from handle @hdl@
 167 without removing it from the input buffer, blocking until a
 168 character is available.
 169
 170 \begin{code}
 171 hLookAhead :: Handle -> IO Char
 172 hLookAhead handle = do
 173   rc <- mayBlockRead "hLookAhead" handle fileLookAhead
 174   return (chr rc)
 175 \end{code}
 176
 177
 178 %*********************************************************
 179 %*                                                      *
 180 \subsection{Getting the entire contents of a handle}
 181 %*                                                      *
 182 %*********************************************************
 183
 184 @hGetContents hdl@ returns the list of characters corresponding
 185 to the unread portion of the channel or file managed by @hdl@,
 186 which is made semi-closed.
 187
 188 \begin{code}
 189 hGetContents :: Handle -> IO String
 190 hGetContents handle =
 191         -- can't use wantReadableHandle here, because we want to side effect
 192         -- the handle.
 193     withHandle handle $ \ handle_ -> do
 194     case haType__ handle_ of
 195       ErrorHandle theError -> ioError theError
 196       ClosedHandle         -> ioe_closedHandle "hGetContents" handle
 197       SemiClosedHandle     -> ioe_closedHandle "hGetContents" handle
 198       AppendHandle         -> ioError not_readable_error
 199       WriteHandle          -> ioError not_readable_error
 200       _ -> do
 201           {-
 202             To avoid introducing an extra layer of buffering here,
 203             we provide three lazy read methods, based on character,
 204             line, and block buffering.
 205           -}
 206         let handle_' = handle_{ haType__ = SemiClosedHandle }
 207         case (haBufferMode__ handle_) of
 208          LineBuffering    -> do
 209             str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
 210             return (handle_', str)
 211          BlockBuffering _ -> do
 212             str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
 213             return (handle_', str)
 214          NoBuffering      -> do
 215             str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
 216             return (handle_', str)
 217   where
 218    not_readable_error =
 219            IOError (Just handle) IllegalOperation "hGetContents"
 220                    ("handle is not open for reading")
 221 \end{code}
 222
 223 Note that someone may close the semi-closed handle (or change its buffering),
 224 so each these lazy read functions are pulled on, they have to check whether
 225 the handle has indeed been closed.
 226
 227 \begin{code}
 228 #ifndef __PARALLEL_HASKELL__
 229 lazyReadBlock :: Handle -> ForeignObj -> IO String
 230 lazyReadLine  :: Handle -> ForeignObj -> IO String
 231 lazyReadChar  :: Handle -> ForeignObj -> IO String
 232 #else
 233 lazyReadBlock :: Handle -> Addr -> IO String
 234 lazyReadLine  :: Handle -> Addr -> IO String
 235 lazyReadChar  :: Handle -> Addr -> IO String
 236 #endif
 237
 238 lazyReadBlock handle fo = do
 239    buf   <- getBufStart fo 0
 240    bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
 241    case (bytes::Int) of
 242      -3 -> -- buffering has been turned off, use lazyReadChar instead
 243            lazyReadChar handle fo
 244      -2 -> return ""
 245      -1 -> -- an error occurred, close the handle
 246           withHandle handle $ \ handle_ -> do
 247           closeFile (haFO__ handle_) 0{-don't bother flushing-}  -- ConcHask: SAFE, won't block.
 248           return (handle_ { haType__    = ClosedHandle,
 249                             haFO__      = nullFile__ },
 250                   "")
 251      _ -> do
 252       more <- unsafeInterleaveIO (lazyReadBlock handle fo)
 253       stToIO (unpackNBytesAccST buf bytes more)
 254
 255 lazyReadLine handle fo = do
 256      bytes <- mayBlock fo (readLine fo)   -- ConcHask: UNSAFE, may block.
 257      case (bytes::Int) of
 258        -3 -> -- buffering has been turned off, use lazyReadChar instead
 259              lazyReadChar handle fo
 260        -2 -> return "" -- handle closed by someone else, stop reading.
 261        -1 -> -- an error occurred, close the handle
 262              withHandle handle $ \ handle_ -> do
 263              closeFile (haFO__ handle_) 0{- don't bother flushing-}  -- ConcHask: SAFE, won't block
 264              return (handle_ { haType__    = ClosedHandle,
 265                                haFO__      = nullFile__ },
 266                      "")
 267        _ -> do
 268           more <- unsafeInterleaveIO (lazyReadLine handle fo)
 269           buf  <- getBufStart fo bytes  -- ConcHask: won't block
 270           stToIO (unpackNBytesAccST buf bytes more)
 271
 272 lazyReadChar handle fo = do
 273     char <- mayBlock fo (readChar fo)   -- ConcHask: UNSAFE, may block.
 274     case (char::Int) of
 275       -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
 276             lazyReadBlock handle fo
 277
 278       -3 -> -- buffering is now line-buffered, use lazyReadLine instead
 279             lazyReadLine handle fo
 280       -2 -> return ""
 281       -1 -> -- error, silently close handle.
 282          withHandle handle $ \ handle_ -> do
 283          closeFile (haFO__ handle_) 0{-don't bother flusing-}  -- ConcHask: SAFE, won't block
 284          return (handle_{ haType__  = ClosedHandle,
 285                           haFO__    = nullFile__ },
 286                  "")
 287       _ -> do
 288          more <- unsafeInterleaveIO (lazyReadChar handle fo)
 289          return (chr char : more)
 290
 291 \end{code}
 292
 293
 294 %*********************************************************
 295 %*                                                      *
 296 \subsection{Simple output functions}
 297 %*                                                      *
 298 %*********************************************************
 299
 300 @hPutChar hdl ch@ writes the character @ch@ to the file
 301 or channel managed by @hdl@.  Characters may be buffered if
 302 buffering is enabled for @hdl@
 303
 304 \begin{code}
 305 hPutChar :: Handle -> Char -> IO ()
 306 hPutChar handle c =
 307     c `seq` do   -- must evaluate c before grabbing the handle lock
 308     wantWriteableHandle "hPutChar" handle $ \ handle_  -> do
 309     let fo = haFO__ handle_
 310     flushConnectedBuf fo
 311     rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
 312     if rc == 0
 313      then return ()
 314      else constructErrorAndFail "hPutChar"
 315
 316 hPutChars :: Handle -> [Char] -> IO ()
 317 hPutChars handle [] = return ()
 318 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 319 \end{code}
 320
 321 @hPutStr hdl s@ writes the string @s@ to the file or
 322 channel managed by @hdl@, buffering the output if needs be.
 323
 324
 325 \begin{code}
 326 hPutStr :: Handle -> String -> IO ()
 327 hPutStr handle str = do
 328     buffer_mode <- wantWriteableHandle_ "hPutStr" handle
 329                         (\ handle_ -> do getBuffer handle_)
 330     case buffer_mode of
 331        (NoBuffering, _, _) -> do
 332             hPutChars handle str        -- v. slow, but we don't care
 333        (LineBuffering, buf, bsz) -> do
 334             writeLines handle buf bsz str
 335        (BlockBuffering _, buf, bsz) -> do
 336             writeBlocks handle buf bsz str
 337         -- ToDo: async exceptions during writeLines & writeBlocks will cause
 338         -- the buffer to get lost in the void.  Using ByteArrays instead of
 339         -- malloced buffers is one way around this, but we really ought to
 340         -- be able to handle it with exception handlers/block/unblock etc.
 341
 342 getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int))
 343 getBuffer handle_ = do
 344    let bufs = haBuffers__ handle_
 345        fo   = haFO__ handle_
 346        mode = haBufferMode__ handle_
 347    sz <- getBufSize fo
 348    case mode of
 349         NoBuffering -> return (handle_, (mode, nullAddr, 0))
 350         _ -> case bufs of
 351                 [] -> do  buf <- allocMemory__ sz
 352                           return (handle_, (mode, buf, sz))
 353                 (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
 354
 355 freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
 356 freeBuffer handle_ buf sz = do
 357    fo_sz <- getBufSize (haFO__ handle_)
 358    if (sz /= fo_sz)
 359         then do { free buf; return handle_ }
 360         else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
 361
 362 swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__
 363 swapBuffers handle_ buf sz = do
 364    let fo = haFO__ handle_
 365    fo_buf <- getBuf fo
 366    setBuf fo buf sz
 367    return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
 368
 369 -- commitBuffer handle buf sz count flush
 370 --
 371 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 372 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 373 --
 374 -- Implementation:
 375 --
 376 --    for block/line buffering,
 377 --       1. If there isn't room in the handle buffer, flush the handle
 378 --          buffer.
 379 --
 380 --       2. If the handle buffer is empty,
 381 --               if flush,
 382 --                   then write buf directly to the device.
 383 --                   else swap the handle buffer with buf.
 384 --
 385 --       3. If the handle buffer is non-empty, copy buf into the
 386 --          handle buffer.  Then, if flush != 0, flush
 387 --          the buffer.
 388
 389 commitAndReleaseBuffer
 390         :: Handle                       -- handle to commit to
 391         -> Addr -> Int                  -- address and size (in bytes) of buffer
 392         -> Int                          -- number of bytes of data in buffer
 393         -> Bool                         -- flush the handle afterward?
 394         -> IO ()
 395 commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
 396       h_ <- takeMVar h
 397
 398         -- First deal with any possible exceptions by freeing the buffer.
 399         -- Async exceptions are blocked, but there are still some interruptible
 400         -- ops below.
 401
 402         -- note that commit doesn't *always* free the buffer, it might
 403         -- swap it for the current handle buffer instead.  This makes things
 404         -- a whole lot more complicated, because we can't just do
 405         -- "finally (... free buffer ...)" here.
 406       catchException (commit hdl h_)
 407                      (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
 408
 409   where
 410    commit hdl@(Handle h) handle_ =
 411      checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
 412       let fo = haFO__ handle_
 413       flushConnectedBuf fo              -- ????  -SDM
 414       getWriteableBuf fo                -- flush read buf if necessary
 415       fo_buf     <- getBuf fo
 416       fo_wptr    <- getBufWPtr fo
 417       fo_bufSize <- getBufSize fo
 418
 419       let ok    h_ = putMVar h h_ >> return ()
 420
 421       if (fo_bufSize - fo_wptr < count) -- not enough room in handle buffer?
 422
 423             then do rc <- mayBlock fo (flushFile fo)
 424                     if (rc < 0)
 425                         then constructErrorAndFail "commitBuffer"
 426                         else
 427                      if flush || sz /= fo_bufSize
 428                         then do rc <- write_buf fo buf count
 429                                 if (rc < 0)
 430                                         then constructErrorAndFail "commitBuffer"
 431                                         else do handle_ <- freeBuffer handle_ buf sz
 432                                                 ok handle_
 433
 434                         -- don't have to flush, and the new buffer is the
 435                         -- same size as the old one, so just swap them...
 436                         else do handle_ <- swapBuffers handle_ buf sz
 437                                 setBufWPtr fo count
 438                                 ok handle_
 439
 440             else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
 441                     setBufWPtr fo (fo_wptr + count)
 442                     if flush
 443                         then do rc <- mayBlock fo (flushFile fo)
 444                                 if (rc < 0)
 445                                         then constructErrorAndFail "commitBuffer"
 446                                         else do handle_ <- freeBuffer handle_ buf sz
 447                                                 ok handle_
 448                         else do handle_ <- freeBuffer handle_ buf sz
 449                                 ok handle_
 450
 451 commitBuffer
 452         :: Handle                       -- handle to commit to
 453         -> Addr -> Int                  -- address and size (in bytes) of buffer
 454         -> Int                          -- number of bytes of data in buffer
 455         -> Bool                         -- flush the handle afterward?
 456         -> IO ()
 457 commitBuffer handle buf sz count flush = do
 458     wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
 459       let fo = haFO__ handle_
 460       flushConnectedBuf fo              -- ????  -SDM
 461       getWriteableBuf fo                -- flush read buf if necessary
 462       fo_buf     <- getBuf fo
 463       fo_wptr    <- getBufWPtr fo
 464       fo_bufSize <- getBufSize fo
 465
 466       (if (fo_bufSize - fo_wptr < count)  -- not enough room in handle buffer?
 467             then mayBlock fo (flushFile fo)
 468             else return 0)
 469
 470       if (fo_bufSize < count)           -- committed buffer too large?
 471
 472             then do rc <- write_buf fo buf count
 473                     if rc < 0 then constructErrorAndFail "commitBuffer"
 474                               else return ()
 475
 476             else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
 477                     setBufWPtr fo (fo_wptr + count)
 478                     (if flush then mayBlock fo (flushFile fo) else return 0)
 479                     return ()
 480
 481 write_buf fo buf 0 = return 0
 482 write_buf fo buf count = do
 483   rc <- mayBlock fo (write_ fo buf count)
 484   if (rc > 0)
 485         then  write_buf fo buf (count - rc) -- partial write
 486         else  return rc
 487
 488 foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
 489 \end{code}
 490
 491 Going across the border between Haskell and C is relatively costly,
 492 so for block writes we pack the character strings on the Haskell-side
 493 before passing the external write routine a pointer to the buffer.
 494
 495 \begin{code}
 496 #ifdef __HUGS__
 497
 498 #ifdef __CONCURRENT_HASKELL__
 499 /* See comment in shoveString below for explanation */
 500 #warning delayed update of buffer disnae work with killThread
 501 #endif
 502
 503 writeLines :: Handle -> Addr -> Int -> String -> IO ()
 504 writeLines handle buf bufLen s =
 505   let
 506    shoveString :: Int -> [Char] -> IO ()
 507    shoveString n ls =
 508      case ls of
 509       [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
 510
 511       (x:xs) -> do
 512         primWriteCharOffAddr buf n x
 513           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
 514         let next_n = n + 1
 515         if next_n == bufLen || x == '\n'
 516          then do
 517            commitBuffer hdl buf len next_n True{-needs flush-}
 518            shoveString 0 xs
 519          else
 520            shoveString next_n xs
 521   in
 522   shoveString 0 s
 523
 524 #else /* ndef __HUGS__ */
 525
 526 writeLines :: Handle -> Addr -> Int -> String -> IO ()
 527 writeLines hdl buf len@(I# bufLen) s =
 528   let
 529    shoveString :: Int# -> [Char] -> IO ()
 530    shoveString n ls =
 531      case ls of
 532       [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
 533
 534       ((C# x):xs) -> do
 535         write_char buf n x
 536           -- Flushing on buffer exhaustion or newlines
 537           -- (even if it isn't the last one)
 538         let next_n = n +# 1#
 539         if next_n ==# bufLen || x `eqChar#` '\n'#
 540          then do
 541            commitBuffer hdl buf len (I# next_n) True{-needs flush-}
 542            shoveString 0# xs
 543          else
 544            shoveString next_n xs
 545   in
 546   shoveString 0# s
 547 #endif /* ndef __HUGS__ */
 548
 549 #ifdef __HUGS__
 550 writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
 551 writeBlocks hdl buf bufLen s =
 552   let
 553    shoveString :: Int -> [Char] -> IO ()
 554    shoveString n ls =
 555      case ls of
 556       [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-}
 557
 558       (x:xs) -> do
 559         primWriteCharOffAddr buf n x
 560         let next_n = n + 1
 561         if next_n == bufLen
 562          then do
 563            commitBuffer hdl buf len next_n True{-needs flush-}
 564            shoveString 0 xs
 565          else
 566            shoveString next_n xs
 567   in
 568   shoveString 0 s
 569
 570 #else /* ndef __HUGS__ */
 571
 572 writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
 573 writeBlocks hdl buf len@(I# bufLen) s =
 574   let
 575    shoveString :: Int# -> [Char] -> IO ()
 576    shoveString n ls =
 577      case ls of
 578       [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
 579
 580       ((C# x):xs) -> do
 581         write_char buf n x
 582         let next_n = n +# 1#
 583         if next_n ==# bufLen
 584          then do
 585            commitBuffer hdl buf len (I# next_n) True{-needs flush-}
 586            shoveString 0# xs
 587          else
 588            shoveString next_n xs
 589   in
 590   shoveString 0# s
 591
 592 write_char :: Addr -> Int# -> Char# -> IO ()
 593 write_char (A# buf#) n# c# =
 594    IO $ \ s# ->
 595    case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 596 #endif /* ndef __HUGS__ */
 597 \end{code}
 598
 599 Computation @hPrint hdl t@ writes the string representation of {\em t}
 600 given by the @shows@ function to the file or channel managed by {\em
 601 hdl}.
 602
 603 [ Seem to have disappeared from the 1.4 interface  - SOF 2/97 ]
 604
 605 \begin{code}
 606 hPrint :: Show a => Handle -> a -> IO ()
 607 hPrint hdl = hPutStrLn hdl . show
 608 \end{code}
 609
 610 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
 611 the handle \tr{hdl}, adding a newline at the end.
 612
 613 \begin{code}
 614 hPutStrLn :: Handle -> String -> IO ()
 615 hPutStrLn hndl str = do
 616  hPutStr  hndl str
 617  hPutChar hndl '\n'
 618 \end{code}