ghc/lib/std/PrelIO.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 #undef DEBUG_DUMP
   4
   5 -- -----------------------------------------------------------------------------
   6 -- $Id: PrelIO.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
   7 --
   8 -- (c) The University of Glasgow, 1992-2001
   9 --
  10 -- Module PrelIO
  11
  12 -- This module defines all basic IO operations.
  13 -- These are needed for the IO operations exported by Prelude,
  14 -- but as it happens they also do everything required by library
  15 -- module IO.
  16
  17 module PrelIO where
  18
  19 #include "HsStd.h"
  20 #include "PrelHandle_hsc.h"
  21
  22 import PrelBase
  23
  24 import PrelPosix
  25 import PrelMarshalAlloc
  26 import PrelMarshalUtils
  27 import PrelStorable
  28 import PrelCError
  29 import PrelCString
  30 import PrelCTypes
  31 import PrelCTypesISO
  32
  33 import PrelIOBase
  34 import PrelHandle       -- much of the real stuff is in here
  35
  36 import PrelMaybe
  37 import PrelReal
  38 import PrelNum
  39 import PrelRead         ( Read(..), readIO )
  40 import PrelShow
  41 import PrelMaybe        ( Maybe(..) )
  42 import PrelPtr
  43 import PrelList
  44 import PrelException    ( ioError, catch, throw )
  45 import PrelConc
  46
  47 -- -----------------------------------------------------------------------------
  48 -- Standard IO
  49
  50 putChar         :: Char -> IO ()
  51 putChar c       =  hPutChar stdout c
  52
  53 putStr          :: String -> IO ()
  54 putStr s        =  hPutStr stdout s
  55
  56 putStrLn        :: String -> IO ()
  57 putStrLn s      =  do putStr s
  58                       putChar '\n'
  59
  60 print           :: Show a => a -> IO ()
  61 print x         =  putStrLn (show x)
  62
  63 getChar         :: IO Char
  64 getChar         =  hGetChar stdin
  65
  66 getLine         :: IO String
  67 getLine         =  hGetLine stdin
  68
  69 getContents     :: IO String
  70 getContents     =  hGetContents stdin
  71
  72 interact        ::  (String -> String) -> IO ()
  73 interact f      =   do s <- getContents
  74                        putStr (f s)
  75
  76 readFile        :: FilePath -> IO String
  77 readFile name   =  openFile name ReadMode >>= hGetContents
  78
  79 writeFile       :: FilePath -> String -> IO ()
  80 writeFile name str = do
  81     hdl <- openFile name WriteMode
  82     hPutStr hdl str
  83     hClose hdl
  84
  85 appendFile      :: FilePath -> String -> IO ()
  86 appendFile name str = do
  87     hdl <- openFile name AppendMode
  88     hPutStr hdl str
  89     hClose hdl
  90
  91 readLn          :: Read a => IO a
  92 readLn          =  do l <- getLine
  93                       r <- readIO l
  94                       return r
  95
  96 -- ---------------------------------------------------------------------------
  97 -- Simple input operations
  98
  99 -- Computation "hReady hdl" indicates whether at least
 100 -- one item is available for input from handle "hdl".
 101
 102 -- If hWaitForInput finds anything in the Handle's buffer, it
 103 -- immediately returns.  If not, it tries to read from the underlying
 104 -- OS handle. Notice that for buffered Handles connected to terminals
 105 -- this means waiting until a complete line is available.
 106
 107 hReady :: Handle -> IO Bool
 108 hReady h = hWaitForInput h 0
 109
 110 hWaitForInput :: Handle -> Int -> IO Bool
 111 hWaitForInput h msecs = do
 112   wantReadableHandle "hReady" h $ \ handle_ -> do
 113   let ref = haBuffer handle_
 114   buf <- readIORef ref
 115
 116   if not (bufferEmpty buf)
 117         then return True
 118         else do
 119
 120   r <- throwErrnoIfMinus1Retry "hReady"
 121           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
 122   return (r /= 0)
 123
 124 foreign import "inputReady"
 125   inputReady :: CInt -> CInt -> IO CInt
 126
 127 -- ---------------------------------------------------------------------------
 128 -- hGetChar
 129
 130 -- hGetChar reads the next character from a handle,
 131 -- blocking until a character is available.
 132
 133 hGetChar :: Handle -> IO Char
 134 hGetChar handle =
 135   wantReadableHandle "hGetChar" handle $ \handle_ -> do
 136
 137   let fd = haFD handle_
 138       ref = haBuffer handle_
 139
 140   buf <- readIORef ref
 141   if not (bufferEmpty buf)
 142         then hGetcBuffered fd ref buf
 143         else do
 144
 145   -- buffer is empty.
 146   case haBufferMode handle_ of
 147     LineBuffering    -> do
 148         new_buf <- fillReadBuffer fd True buf
 149         hGetcBuffered fd ref new_buf
 150     BlockBuffering _ -> do
 151         new_buf <- fillReadBuffer fd False buf
 152         hGetcBuffered fd ref new_buf
 153     NoBuffering -> do
 154         -- make use of the minimal buffer we already have
 155         let raw = bufBuf buf
 156         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
 157                 (read_off (fromIntegral fd) raw 0 1)
 158                 (threadWaitRead fd)
 159         if r == 0
 160            then ioe_EOF
 161            else do (c,_) <- readCharFromBuffer raw 0
 162                    return c
 163
 164 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
 165  = do (c,r) <- readCharFromBuffer b r
 166       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
 167                   | otherwise = buf{ bufRPtr=r }
 168       writeIORef ref new_buf
 169       return c
 170
 171 -- ---------------------------------------------------------------------------
 172 -- hGetLine
 173
 174 -- If EOF is reached before EOL is encountered, ignore the EOF and
 175 -- return the partial line. Next attempt at calling hGetLine on the
 176 -- handle will yield an EOF IO exception though.
 177
 178 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 179 -- the duration.
 180 hGetLine :: Handle -> IO String
 181 hGetLine h = do
 182   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
 183         case haBufferMode handle_ of
 184            NoBuffering      -> return Nothing
 185            LineBuffering    -> do
 186               l <- hGetLineBuffered handle_
 187               return (Just l)
 188            BlockBuffering _ -> do
 189               l <- hGetLineBuffered handle_
 190               return (Just l)
 191   case m of
 192         Nothing -> hGetLineUnBuffered h
 193         Just l  -> return l
 194
 195
 196 hGetLineBuffered handle_ = do
 197   let ref = haBuffer handle_
 198   buf <- readIORef ref
 199   hGetLineBufferedLoop handle_ ref buf []
 200
 201
 202 hGetLineBufferedLoop handle_ ref
 203         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
 204   let
 205         -- find the end-of-line character, if there is one
 206         loop raw r
 207            | r == w = return (False, w)
 208            | otherwise =  do
 209                 (c,r') <- readCharFromBuffer raw r
 210                 if c == '\n'
 211                    then return (True, r) -- NB. not r': don't include the '\n'
 212                    else loop raw r'
 213   in do
 214   (eol, off) <- loop raw r
 215
 216 #ifdef DEBUG_DUMP
 217   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
 218 #endif
 219
 220   xs <- unpack raw r off
 221   if eol
 222         then do if w == off + 1
 223                    then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 224                    else writeIORef ref buf{ bufRPtr = off + 1 }
 225                 return (concat (reverse (xs:xss)))
 226         else do
 227              maybe_buf <- maybeFillReadBuffer (haFD handle_) True
 228                                 buf{ bufWPtr=0, bufRPtr=0 }
 229              case maybe_buf of
 230                 -- Nothing indicates we caught an EOF, and we may have a
 231                 -- partial line to return.
 232                 Nothing -> let str = concat (reverse (xs:xss)) in
 233                            if not (null str)
 234                               then return str
 235                               else ioe_EOF
 236                 Just new_buf ->
 237                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 238
 239
 240 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 241 unpack buf r 0   = return ""
 242 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
 243    where
 244     unpack acc i s
 245      | i <## r  = (## s, acc ##)
 246      | otherwise =
 247           case readCharArray## buf i s of
 248             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
 249
 250
 251 hGetLineUnBuffered :: Handle -> IO String
 252 hGetLineUnBuffered h = do
 253   c <- hGetChar h
 254   if c == '\n' then
 255      return ""
 256    else do
 257     l <- getRest
 258     return (c:l)
 259  where
 260   getRest = do
 261     c <-
 262       catch
 263         (hGetChar h)
 264         (\ err -> do
 265           if isEOFError err then
 266              return '\n'
 267            else
 268              ioError err)
 269     if c == '\n' then
 270        return ""
 271      else do
 272        s <- getRest
 273        return (c:s)
 274
 275 -- -----------------------------------------------------------------------------
 276 -- hGetContents
 277
 278 -- hGetContents returns the list of characters corresponding to the
 279 -- unread portion of the channel or file managed by the handle, which
 280 -- is made semi-closed.
 281
 282 hGetContents :: Handle -> IO String
 283 hGetContents handle =
 284         -- can't use wantReadableHandle here, because we want to side effect
 285         -- the handle.
 286     withHandle "hGetContents" handle $ \ handle_ -> do
 287     case haType handle_ of
 288       ClosedHandle         -> ioe_closedHandle
 289       SemiClosedHandle     -> ioe_closedHandle
 290       AppendHandle         -> ioException not_readable_error
 291       WriteHandle          -> ioException not_readable_error
 292       _ -> do xs <- lazyRead handle
 293               return (handle_{ haType=SemiClosedHandle}, xs )
 294   where
 295    not_readable_error =
 296         IOError (Just handle) IllegalOperation "hGetContents"
 297                 "handle is not open for reading" Nothing
 298
 299 -- Note that someone may close the semi-closed handle (or change its
 300 -- buffering), so each these lazy read functions are pulled on, they
 301 -- have to check whether the handle has indeed been closed.
 302
 303 lazyRead :: Handle -> IO String
 304 lazyRead handle =
 305    unsafeInterleaveIO $
 306         withHandle_ "lazyRead" handle $ \ handle_ -> do
 307         case haType handle_ of
 308           ClosedHandle     -> return ""
 309           SemiClosedHandle -> lazyRead' handle handle_
 310           _ -> ioException
 311                   (IOError (Just handle) IllegalOperation "lazyRead"
 312                         "illegal handle type" Nothing)
 313
 314 lazyRead' h handle_ = do
 315   let ref = haBuffer handle_
 316       fd  = haFD handle_
 317
 318   -- even a NoBuffering handle can have a char in the buffer...
 319   -- (see hLookAhead)
 320   buf <- readIORef ref
 321   if not (bufferEmpty buf)
 322         then lazyReadBuffered h fd ref buf
 323         else do
 324
 325   case haBufferMode handle_ of
 326      NoBuffering      -> do
 327         -- make use of the minimal buffer we already have
 328         let raw = bufBuf buf
 329             fd  = haFD handle_
 330         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
 331                 (read_off (fromIntegral fd) raw 0 1)
 332                 (threadWaitRead fd)
 333         if r == 0
 334            then return ""
 335            else do (c,_) <- readCharFromBuffer raw 0
 336                    rest <- lazyRead h
 337                    return (c : rest)
 338
 339      LineBuffering    -> lazyReadBuffered h fd ref buf
 340      BlockBuffering _ -> lazyReadBuffered h fd ref buf
 341
 342 -- we never want to block during the read, so we call fillReadBuffer with
 343 -- is_line==True, which tells it to "just read what there is".
 344 lazyReadBuffered h fd ref buf = do
 345    maybe_new_buf <-
 346         if bufferEmpty buf
 347            then maybeFillReadBuffer fd True buf
 348            else return (Just buf)
 349    case maybe_new_buf of
 350         Nothing  -> return ""
 351         Just buf -> do
 352            more <- lazyRead h
 353            writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 354            unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 355
 356
 357 maybeFillReadBuffer fd is_line buf
 358   = catch
 359      (do buf <- fillReadBuffer fd is_line buf
 360          return (Just buf)
 361      )
 362      (\e -> if isEOFError e
 363                 then return Nothing
 364                 else throw e)
 365
 366
 367 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 368 unpackAcc buf r 0 acc  = return ""
 369 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
 370    where
 371     unpack acc i s
 372      | i <## r  = (## s, acc ##)
 373      | otherwise =
 374           case readCharArray## buf i s of
 375             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
 376
 377 -- ---------------------------------------------------------------------------
 378 -- hPutChar
 379
 380 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
 381 -- managed by `hdl'.  Characters may be buffered if buffering is
 382 -- enabled for `hdl'.
 383
 384 hPutChar :: Handle -> Char -> IO ()
 385 hPutChar handle c =
 386     c `seq` do   -- must evaluate c before grabbing the handle lock
 387     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 388     let fd = haFD handle_
 389     case haBufferMode handle_ of
 390         LineBuffering    -> hPutcBuffered handle_ True  c
 391         BlockBuffering _ -> hPutcBuffered handle_ False c
 392         NoBuffering      ->
 393                 withObject (castCharToCChar c) $ \buf ->
 394                 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
 395                    (c_write (fromIntegral fd) buf 1)
 396                    (threadWaitWrite fd)
 397
 398
 399 hPutcBuffered handle_ is_line c = do
 400   let ref = haBuffer handle_
 401   buf <- readIORef ref
 402   let w = bufWPtr buf
 403   w'  <- writeCharIntoBuffer (bufBuf buf) w c
 404   let new_buf = buf{ bufWPtr = w' }
 405   if bufferFull new_buf || is_line && c == '\n'
 406      then do
 407         flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
 408         writeIORef ref flushed_buf
 409      else do
 410         writeIORef ref new_buf
 411
 412
 413 hPutChars :: Handle -> [Char] -> IO ()
 414 hPutChars handle [] = return ()
 415 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 416
 417 -- ---------------------------------------------------------------------------
 418 -- hPutStr
 419
 420 -- `hPutStr hdl s' writes the string `s' to the file or
 421 -- hannel managed by `hdl', buffering the output if needs be.
 422
 423 -- We go to some trouble to avoid keeping the handle locked while we're
 424 -- evaluating the string argument to hPutStr, in case doing so triggers another
 425 -- I/O operation on the same handle which would lead to deadlock.  The classic
 426 -- case is
 427 --
 428 --              putStr (trace "hello" "world")
 429 --
 430 -- so the basic scheme is this:
 431 --
 432 --      * copy the string into a fresh buffer,
 433 --      * "commit" the buffer to the handle.
 434 --
 435 -- Committing may involve simply copying the contents of the new
 436 -- buffer into the handle's buffer, flushing one or both buffers, or
 437 -- maybe just swapping the buffers over (if the handle's buffer was
 438 -- empty).  See commitBuffer below.
 439
 440 hPutStr :: Handle -> String -> IO ()
 441 hPutStr handle str = do
 442     buffer_mode <- wantWritableHandle "hPutStr" handle
 443                         (\ handle_ -> do getSpareBuffer handle_)
 444     case buffer_mode of
 445        (NoBuffering, _) -> do
 446             hPutChars handle str        -- v. slow, but we don't care
 447        (LineBuffering, buf) -> do
 448             writeLines handle buf str
 449        (BlockBuffering _, buf) -> do
 450             writeBlocks handle buf str
 451
 452
 453 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
 454 getSpareBuffer handle_ = do
 455    let mode = haBufferMode handle_
 456    case mode of
 457      NoBuffering -> return (mode, error "no buffer!")
 458      _ -> do
 459           let spare_ref = haBuffers handle_
 460               ref = haBuffer handle_
 461           bufs <- readIORef spare_ref
 462           buf  <- readIORef ref
 463           case bufs of
 464             BufferListCons b rest -> do
 465                 writeIORef spare_ref rest
 466                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
 467             BufferListNil -> do
 468                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
 469                 return (mode, new_buf)
 470
 471
 472 writeLines :: Handle -> Buffer -> String -> IO ()
 473 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 474   let
 475    shoveString :: Int -> [Char] -> IO ()
 476         -- check n == len first, to ensure that shoveString is strict in n.
 477    shoveString n cs | n == len = do
 478         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 479         writeBlocks hdl new_buf cs
 480    shoveString n [] = do
 481         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 482         return ()
 483    shoveString n (c:cs) = do
 484         n' <- writeCharIntoBuffer raw n c
 485         shoveString n' cs
 486   in
 487   shoveString 0 s
 488
 489 writeBlocks :: Handle -> Buffer -> String -> IO ()
 490 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 491   let
 492    shoveString :: Int -> [Char] -> IO ()
 493         -- check n == len first, to ensure that shoveString is strict in n.
 494    shoveString n cs | n == len = do
 495         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 496         writeBlocks hdl new_buf cs
 497    shoveString n [] = do
 498         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 499         return ()
 500    shoveString n (c:cs) = do
 501         n' <- writeCharIntoBuffer raw n c
 502         shoveString n' cs
 503   in
 504   shoveString 0 s
 505
 506 -- -----------------------------------------------------------------------------
 507 -- commitBuffer handle buf sz count flush release
 508 --
 509 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 510 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 511 --
 512 -- Implementation:
 513 --
 514 --    for block/line buffering,
 515 --       1. If there isn't room in the handle buffer, flush the handle
 516 --          buffer.
 517 --
 518 --       2. If the handle buffer is empty,
 519 --               if flush,
 520 --                   then write buf directly to the device.
 521 --                   else swap the handle buffer with buf.
 522 --
 523 --       3. If the handle buffer is non-empty, copy buf into the
 524 --          handle buffer.  Then, if flush != 0, flush
 525 --          the buffer.
 526
 527 commitBuffer
 528         :: Handle                       -- handle to commit to
 529         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 530         -> Int                          -- number of bytes of data in buffer
 531         -> Bool                         -- flush the handle afterward?
 532         -> Bool                         -- release the buffer?
 533         -> IO Buffer
 534
 535 commitBuffer hdl raw sz count flush release = do
 536   wantWritableHandle "commitAndReleaseBuffer" hdl $
 537     \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
 538
 539 #ifdef DEBUG_DUMP
 540       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 541             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 542 #endif
 543
 544       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 545           <- readIORef ref
 546
 547       buf_ret <-
 548         -- enough room in handle buffer?
 549          if (not flush && (size - w > count))
 550                 -- The > is to be sure that we never exactly fill
 551                 -- up the buffer, which would require a flush.  So
 552                 -- if copying the new data into the buffer would
 553                 -- make the buffer full, we just flush the existing
 554                 -- buffer and the new data immediately, rather than
 555                 -- copying before flushing.
 556
 557                 -- not flushing, and there's enough room in the buffer:
 558                 -- just copy the data in and update bufWPtr.
 559             then do memcpy_off old_raw w raw (fromIntegral count)
 560                     writeIORef ref old_buf{ bufWPtr = w + count }
 561                     return (newEmptyBuffer raw WriteBuffer sz)
 562
 563                 -- else, we have to flush
 564             else do flushed_buf <- flushWriteBuffer fd old_buf
 565
 566                     let this_buf =
 567                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 568                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 569
 570                         -- if:  (a) we don't have to flush, and
 571                         --      (b) size(new buffer) == size(old buffer), and
 572                         --      (c) new buffer is not full,
 573                         -- we can just just swap them over...
 574                     if (not flush && sz == size && count /= sz)
 575                         then do
 576                           writeIORef ref this_buf
 577                           return flushed_buf
 578
 579                         -- otherwise, we have to flush the new data too,
 580                         -- and start with a fresh buffer
 581                         else do
 582                           flushWriteBuffer fd this_buf
 583                           writeIORef ref flushed_buf
 584                             -- if the sizes were different, then allocate
 585                             -- a new buffer of the correct size.
 586                           if sz == size
 587                              then return (newEmptyBuffer raw WriteBuffer sz)
 588                              else allocateBuffer size WriteBuffer
 589
 590       -- release the buffer if necessary
 591       if release && bufSize buf_ret == size
 592          then do
 593               spare_bufs <- readIORef spare_buf_ref
 594               writeIORef spare_buf_ref
 595                 (BufferListCons (bufBuf buf_ret) spare_bufs)
 596               return buf_ret
 597          else
 598               return buf_ret
 599
 600
 601 foreign import "memcpy_wrap" unsafe
 602    memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 603 #def inline \
 604 void *memcpy_wrap(char *dst, int dst_off, char *src, size_t sz) \
 605 { return memcpy(dst+dst_off, src, sz); }
 606
 607 -- ---------------------------------------------------------------------------
 608 -- hPutStrLn
 609
 610 -- Derived action `hPutStrLn hdl str' writes the string `str' to
 611 -- the handle `hdl', adding a newline at the end.
 612
 613 hPutStrLn :: Handle -> String -> IO ()
 614 hPutStrLn hndl str = do
 615  hPutStr  hndl str
 616  hPutChar hndl '\n'
 617
 618 -- ---------------------------------------------------------------------------
 619 -- hPrint
 620
 621 -- Computation `hPrint hdl t' writes the string representation of `t'
 622 -- given by the `shows' function to the file or channel managed by `hdl'.
 623
 624 hPrint :: Show a => Handle -> a -> IO ()
 625 hPrint hdl = hPutStrLn hdl . show