ghc/lib/std/PrelIO.lhs

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