ghc/lib/std/PrelIO.lhs

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