ghc/lib/std/IO.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[IO]{Module @IO@}
   6
   7 \begin{code}
   8 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
   9
  10 module IO (
  11     Handle, HandlePosn,
  12
  13     IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
  14     BufferMode(NoBuffering,LineBuffering,BlockBuffering),
  15     SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
  16
  17     stdin, stdout, stderr,
  18
  19     openFile, hClose,
  20     hFileSize, hIsEOF, isEOF,
  21     hSetBuffering, hGetBuffering, hFlush,
  22     hGetPosn, hSetPosn, hSeek,
  23     hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents,
  24     hPutChar, hPutStr, hPutStrLn, hPrint,
  25     hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable,
  26
  27     isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,
  28     isFullError, isEOFError,
  29     isIllegalOperation, isPermissionError, isUserError,
  30     ioeGetErrorString,
  31     ioeGetHandle, ioeGetFileName,
  32     try, bracket, bracket_
  33   ) where
  34
  35 import PrelST
  36 import PrelIOBase
  37 import PrelArr          ( MutableByteArray(..), newCharArray )
  38 import PrelHandle               -- much of the real stuff is in here
  39 import PrelPack         ( unpackNBytesST )
  40 import PrelBase
  41 import PrelRead         ( readParen, Read(..), reads, lex )
  42 import PrelMaybe
  43 import PrelEither
  44 import PrelAddr
  45 import PrelGHC
  46
  47 #ifndef __PARALLEL_HASKELL__
  48 import PrelForeign  ( ForeignObj, makeForeignObj, writeForeignObj )
  49 #endif
  50
  51 import Ix
  52 import Char             ( ord, chr )
  53 \end{code}
  54
  55 %*********************************************************
  56 %*                                                      *
  57 \subsection{Signatures}
  58 %*                                                      *
  59 %*********************************************************
  60
  61 \begin{code}
  62 --IOHandle:hClose                :: Handle -> IO ()
  63 --IOHandle:hFileSize             :: Handle -> IO Integer
  64 --IOHandle:hFlush                :: Handle -> IO ()
  65 --IOHandle:hGetBuffering         :: Handle -> IO BufferMode
  66 hGetChar              :: Handle -> IO Char
  67 hGetContents          :: Handle -> IO String
  68 --IOHandle:hGetPosn              :: Handle -> IO HandlePosn
  69 --IOHandle:hIsClosed             :: Handle -> IO Bool
  70 --IOHandle:hIsEOF                :: Handle -> IO Bool
  71 --IOHandle:hIsOpen               :: Handle -> IO Bool
  72 --IOHandle:hIsReadable           :: Handle -> IO Bool
  73 --IOHandle:hIsSeekable           :: Handle -> IO Bool
  74 --IOHandle:hIsWritable           :: Handle -> IO Bool
  75 hLookAhead            :: Handle -> IO Char
  76 hPrint                :: Show a => Handle -> a -> IO ()
  77 hPutChar              :: Handle -> Char -> IO ()
  78 hPutStr               :: Handle -> String -> IO ()
  79 hPutStrLn             :: Handle -> String -> IO ()
  80 hReady                :: Handle -> IO Bool
  81 hWaitForInput         :: Handle -> Int -> IO Bool
  82
  83 --IOHandle:hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
  84 --IOHandle:hSetBuffering         :: Handle -> BufferMode -> IO ()
  85 --IOHandle:hSetPosn              :: HandlePosn -> IO ()
  86 -- ioeGetFileName        :: IOError -> Maybe FilePath
  87 -- ioeGetErrorString     :: IOError -> Maybe String
  88 -- ioeGetHandle          :: IOError -> Maybe Handle
  89 -- isAlreadyExistsError  :: IOError -> Bool
  90 -- isAlreadyInUseError   :: IOError -> Bool
  91 --IOHandle:isEOF                 :: IO Bool
  92 -- isEOFError            :: IOError -> Bool
  93 -- isFullError           :: IOError -> Bool
  94 -- isIllegalOperation    :: IOError -> Bool
  95 -- isPermissionError     :: IOError -> Bool
  96 -- isUserError           :: IOError -> Bool
  97 --IOHandle:openFile              :: FilePath -> IOMode -> IO Handle
  98 --IOHandle:stdin, stdout, stderr :: Handle
  99 \end{code}
 100
 101 Standard instances for @Handle@:
 102
 103 \begin{code}
 104 instance Eq IOError where
 105   (IOError h1 e1 str1) == (IOError h2 e2 str2) =
 106     e1==e2 && str1==str2 && h1==h2
 107
 108 #ifndef __CONCURRENT_HASKELL__
 109
 110 instance Eq Handle where
 111  (Handle h1) == (Handle h2) = h1 == h2
 112
 113 #else
 114
 115 {-      OLD equality instance. The simpler one above
 116         seems more accurate!  This one is still used for concurrent haskell,
 117         since there's no equality instance over MVars.
 118 -}
 119
 120 instance Eq Handle where
 121  h1 == h2 =
 122   unsafePerformIO (do
 123     h1_ <- readHandle h1
 124     writeHandle h1 h1_
 125     h2_<- readHandle h2
 126     writeHandle h2 h2_
 127     return (
 128      case (h1_,h2_) of
 129       (ErrorHandle (IOError h1 _ _), ErrorHandle (IOError h2 _ _)) -> h1 == h2
 130       (ClosedHandle, ClosedHandle) -> True
 131       (SemiClosedHandle v1 _, SemiClosedHandle v2 _) -> v1 == v2
 132       (ReadHandle v1 _ _ ,      ReadHandle v2 _ _)   -> v1 == v2
 133       (WriteHandle v1 _ _ ,     WriteHandle v2 _ _)  -> v1 == v2
 134       (AppendHandle v1 _ _ ,    AppendHandle v2 _ _) -> v1 == v2
 135       (ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2
 136       _ -> False))
 137
 138 #endif
 139
 140 instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
 141
 142 --Type declared in IOHandle, instance here because it depends on Eq.Handle
 143 instance Eq HandlePosn where
 144     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 145
 146 -- Type declared in IOBase, instance here because it
 147 -- depends on PrelRead.(Read Maybe) instance.
 148 instance Read BufferMode where
 149     readsPrec p =
 150       readParen False
 151         (\r ->  let lr = lex r
 152                 in
 153                 [(NoBuffering, rest)       | ("NoBuffering", rest) <- lr] ++
 154                 [(LineBuffering,rest)      | ("LineBuffering",rest) <- lr] ++
 155                 [(BlockBuffering mb,rest2) | ("BlockBuffering",rest1) <- lr,
 156                                              (mb, rest2) <- reads rest1])
 157
 158 \end{code}
 159
 160 %*********************************************************
 161 %*                                                      *
 162 \subsection{Simple input operations}
 163 %*                                                      *
 164 %*********************************************************
 165
 166 Computation @hReady hdl@ indicates whether at least
 167 one item is available for input from handle {\em hdl}.
 168
 169 @hWaitForInput@ is the generalisation, wait for \tr{n} seconds
 170 before deciding whether the Handle has run dry or not.
 171
 172 \begin{code}
 173 --hReady :: Handle -> IO Bool
 174 hReady h = hWaitForInput h 0
 175
 176 --hWaitForInput :: Handle -> Int -> IO Bool
 177 hWaitForInput handle nsecs = do
 178     hdl   <- wantReadableHandle handle
 179     rc    <- _ccall_ inputReady (filePtr hdl) nsecs
 180     writeHandle handle (markHandle hdl)
 181     case rc of
 182       0 -> return False
 183       1 -> return True
 184       _ -> constructErrorAndFail "hWaitForInput"
 185 \end{code}
 186
 187 Computation $hGetChar hdl$ reads the next character from handle
 188 {\em hdl}, blocking until a character is available.
 189
 190 \begin{code}
 191 --hGetChar :: Handle -> IO Char
 192
 193 hGetChar handle = do
 194     hdl   <- wantReadableHandle handle
 195     intc  <- _ccall_ fileGetc (filePtr hdl)
 196     writeHandle handle (markHandle hdl)
 197     if intc /= ``EOF''
 198      then return (chr intc)
 199      else constructErrorAndFail "hGetChar"
 200
 201 hGetLine :: Handle -> IO String
 202 hGetLine h = do
 203  c <- hGetChar h
 204  if c == '\n'
 205   then return ""
 206   else do
 207     s <- hGetLine h
 208     return (c:s)
 209
 210 \end{code}
 211
 212 Computation $hLookahead hdl$ returns the next character from handle
 213 {\em hdl} without removing it from the input buffer, blocking until a
 214 character is available.
 215
 216 \begin{code}
 217 --hLookAhead :: Handle -> IO Char
 218
 219 hLookAhead handle = do
 220     hdl   <- wantReadableHandle handle
 221     intc  <- _ccall_ fileLookAhead (filePtr hdl)
 222     writeHandle handle (markHandle hdl)
 223     if intc /= ``EOF''
 224      then return (chr intc)
 225      else constructErrorAndFail "hLookAhead"
 226
 227 \end{code}
 228
 229
 230 %*********************************************************
 231 %*                                                      *
 232 \subsection{Getting the entire contents of a handle}
 233 %*                                                      *
 234 %*********************************************************
 235
 236 Computation $hGetContents hdl$ returns the list of characters
 237 corresponding to the unread portion of the channel or file managed by
 238 {\em hdl}, which is made semi-closed.
 239
 240 \begin{code}
 241 --hGetContents :: Handle -> IO String
 242
 243 hGetContents handle = do
 244     hdl_ <- wantReadableHandle handle
 245       {-
 246         To avoid introducing an extra layer of buffering here,
 247         we provide three lazy read methods, based on character,
 248         line, and block buffering.
 249       -}
 250     hdl_ <- getBufferMode hdl_
 251     case (bufferMode hdl_) of
 252      Just LineBuffering -> do
 253         buf_info <- allocBuf Nothing
 254         writeHandle handle (SemiClosedHandle (filePtr hdl_) buf_info)
 255         unsafeInterleaveIO (lazyReadLine handle)
 256      Just (BlockBuffering size) -> do
 257         buf_info <- allocBuf size
 258         writeHandle handle (SemiClosedHandle (filePtr hdl_) buf_info)
 259         unsafeInterleaveIO (lazyReadBlock handle)
 260      _ -> do -- Nothing is treated pessimistically as NoBuffering
 261         writeHandle handle (SemiClosedHandle (filePtr hdl_) (``NULL'', 0))
 262         unsafeInterleaveIO (lazyReadChar handle)
 263   where
 264     allocBuf :: Maybe Int -> IO (Addr, Int)
 265     allocBuf msize = do
 266         buf <- _ccall_ malloc size
 267         if buf /= ``NULL''
 268          then return (buf, size)
 269          else fail (IOError Nothing ResourceExhausted "not enough virtual memory")
 270       where
 271         size =
 272             case msize of
 273               Just x -> x
 274               Nothing -> ``BUFSIZ''
 275 \end{code}
 276
 277 Note that someone may yank our handle out from under us, and then re-use
 278 the same FILE * for something else.  Therefore, we have to re-examine the
 279 handle every time through.
 280
 281 \begin{code}
 282 lazyReadBlock :: Handle -> IO String
 283 lazyReadLine  :: Handle -> IO String
 284 lazyReadChar  :: Handle -> IO String
 285
 286 lazyReadBlock handle = do
 287     htype <- readHandle handle
 288     case htype of
 289       -- There cannae be an ErrorHandle here
 290       ClosedHandle -> do
 291           writeHandle handle htype
 292           return ""
 293       SemiClosedHandle fp (buf, size) -> do
 294           bytes <- _ccall_ readBlock buf fp size
 295           some  <- (if bytes <= 0
 296                      then return ""
 297                      else stToIO (unpackNBytesST buf bytes))
 298           if bytes < 0
 299            then do
 300               _ccall_ free buf
 301               _ccall_ closeFile fp
 302 #ifndef __PARALLEL_HASKELL__
 303               writeForeignObj fp ``NULL''
 304               writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
 305 #else
 306               writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
 307 #endif
 308               return some
 309            else do
 310               writeHandle handle htype
 311               more <- unsafeInterleaveIO (lazyReadBlock handle)
 312               return (some ++ more)
 313
 314 lazyReadLine handle = do
 315     htype <- readHandle handle
 316     case htype of
 317       -- There cannae be an ErrorHandle here
 318       ClosedHandle -> do
 319           writeHandle handle htype
 320           return ""
 321       SemiClosedHandle fp (buf, size) -> do
 322           bytes <- _ccall_ readLine buf fp size
 323           some  <- (if bytes <= 0
 324                      then return ""
 325                      else stToIO (unpackNBytesST buf bytes))
 326           if bytes < 0
 327            then do
 328               _ccall_ free buf
 329               _ccall_ closeFile fp
 330 #ifndef __PARALLEL_HASKELL__
 331               writeForeignObj fp ``NULL''
 332               writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
 333 #else
 334               writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
 335 #endif
 336               return some
 337            else do
 338               writeHandle handle htype
 339               more <- unsafeInterleaveIO (lazyReadLine handle)
 340               return (some ++ more)
 341
 342 lazyReadChar handle = do
 343     htype <- readHandle handle
 344     case htype of
 345       -- There cannae be an ErrorHandle here
 346       ClosedHandle -> do
 347           writeHandle handle htype
 348           return ""
 349       SemiClosedHandle fp buf_info -> do
 350           char <- _ccall_ readChar fp
 351           if char == ``EOF''
 352            then do
 353               _ccall_ closeFile fp
 354 #ifndef __PARALLEL_HASKELL__
 355               writeForeignObj fp ``NULL''
 356               writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
 357 #else
 358               writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
 359 #endif
 360               return ""
 361            else do
 362               writeHandle handle htype
 363               more <- unsafeInterleaveIO (lazyReadChar handle)
 364               return (chr char : more)
 365
 366 \end{code}
 367
 368
 369 %*********************************************************
 370 %*                                                      *
 371 \subsection{Simple output functions}
 372 %*                                                      *
 373 %*********************************************************
 374
 375 Computation $hPutChar hdl c$ writes the character {\em c} to the file
 376 or channel managed by {\em hdl}.  Characters may be buffered if
 377 buffering is enabled for {\em hdl}.
 378
 379 \begin{code}
 380 --hPutChar :: Handle -> Char -> IO ()
 381
 382 hPutChar handle c = do
 383     hdl   <- wantWriteableHandle handle
 384     rc    <- _ccall_ filePutc (filePtr hdl) (ord c)
 385     writeHandle handle (markHandle hdl)
 386     if rc == 0
 387      then return ()
 388      else constructErrorAndFail "hPutChar"
 389 \end{code}
 390
 391 Computation $hPutStr hdl s$ writes the string {\em s} to the file or
 392 channel managed by {\em hdl}.
 393
 394 \begin{code}
 395 --hPutStr :: Handle -> String -> IO ()
 396
 397 hPutStr handle str = do
 398     hdl <- wantWriteableHandle handle
 399           {-
 400            The code below is not correct for line-buffered terminal streams,
 401            as the output stream is not flushed when terminal input is requested
 402            again, just upon seeing a newline character. A temporary fix for the
 403            most common line-buffered output stream, stdout, is to assume the
 404            buffering it was given when created (no buffering). This is not
 405            as bad as it looks, since stdio buffering sits underneath this.
 406
 407            ToDo: fix me
 408           -}
 409     hdl     <- getBufferMode hdl
 410     success <-
 411          (case bufferMode hdl of
 412             Just LineBuffering ->
 413                 writeChars (filePtr hdl) str
 414                 --writeLines (filePtr hdl) str
 415             Just (BlockBuffering (Just size)) ->
 416                 writeBlocks (filePtr hdl) size str
 417             Just (BlockBuffering Nothing) ->
 418                 writeBlocks (filePtr hdl) (``BUFSIZ''-1) str
 419             _ -> -- Nothing is treated pessimistically as NoBuffering
 420                 writeChars (filePtr hdl) str
 421           )
 422     writeHandle handle (markHandle hdl)
 423     if success
 424      then return ()
 425      else constructErrorAndFail "hPutStr"
 426
 427 #ifndef __PARALLEL_HASKELL__
 428 writeLines :: ForeignObj -> String -> IO Bool
 429 #else
 430 writeLines :: Addr -> String -> IO Bool
 431 #endif
 432 writeLines = writeChunks (``BUFSIZ''-1) True
 433
 434 #ifndef __PARALLEL_HASKELL__
 435 writeBlocks :: ForeignObj -> Int -> String -> IO Bool
 436 #else
 437 writeBlocks :: Addr -> Int -> String -> IO Bool
 438 #endif
 439 writeBlocks fp size s = writeChunks size False fp s
 440
 441     {-
 442       The breaking up of output into lines along \n boundaries
 443       works fine as long as there are newlines to split by.
 444       Avoid the splitting up into lines alltogether (doesn't work
 445       for overly long lines like the stuff that showsPrec instances
 446       normally return). Instead, we split them up into fixed size
 447       chunks before blasting them off to the Real World.
 448
 449       Hacked to avoid multiple passes over the strings - unsightly, but
 450       a whole lot quicker. -- SOF 3/96
 451     -}
 452
 453 #ifndef __PARALLEL_HASKELL__
 454 writeChunks :: Int -> Bool -> ForeignObj -> String -> IO Bool
 455 #else
 456 writeChunks :: Int -> Bool -> Addr -> String -> IO Bool
 457 #endif
 458 writeChunks (I# bufLen) chopOnNewLine fp s =
 459   stToIO (newCharArray (0,I# bufLen)) >>= \ arr@(MutableByteArray _ arr#) ->
 460   let
 461    write_char :: MutableByteArray# RealWorld -> Int# -> Char# -> IO ()
 462    write_char arr# n x = IO $ \ s# ->
 463       case (writeCharArray# arr# n x s#) of { s1# ->
 464         IOok s1# () }
 465
 466    shoveString :: Int# -> [Char] -> IO Bool
 467    shoveString n ls =
 468      case ls of
 469       [] ->
 470         if n ==# 0# then
 471           return True
 472         else do
 473           rc <- _ccall_ writeFile arr fp (I# n)
 474           return (rc==0)
 475
 476       ((C# x):xs) -> do
 477         write_char arr# n x
 478
 479           {- Flushing lines - should we bother? Yes, for line-buffered output. -}
 480         if n ==# bufLen || (chopOnNewLine && (x `eqChar#` '\n'#))
 481          then do
 482            rc <-  _ccall_ writeFile arr fp (I# (n +# 1#))
 483            if rc == 0
 484             then shoveString 0# xs
 485             else return False
 486          else
 487            shoveString (n +# 1#) xs
 488   in
 489   shoveString 0# s
 490
 491 #ifndef __PARALLEL_HASKELL__
 492 writeChars :: ForeignObj -> String -> IO Bool
 493 #else
 494 writeChars :: Addr -> String -> IO Bool
 495 #endif
 496 writeChars fp "" = return True
 497 writeChars fp (c:cs) = do
 498   rc <- _ccall_ filePutc fp (ord c)
 499   if rc == 0
 500    then writeChars fp cs
 501    else return False
 502
 503 \end{code}
 504
 505 The @hPutBuf hdl len elt_sz buf@ action writes the buffer @buf@ to
 506 the file/channel managed by @hdl@
 507 the string {\em s} to the file or
 508 channel managed by {\em hdl}.
 509
 510 begin{code}
 511 hPutBuf :: Handle -> Int -> Int -> ByteArray Int -> IO ()
 512 hPutBuf handle len el_sz buf = do
 513     hdl <- wantWriteableHandle handle
 514           {-
 515            The code below is not correct for line-buffered terminal streams,
 516            as the output stream is not flushed when terminal input is requested
 517            again, just upon seeing a newline character. A temporary fix for the
 518            most common line-buffered output stream, stdout, is to assume the
 519            buffering it was given when created (no buffering). This is not
 520            as bad as it looks, since stdio buffering sits underneath this.
 521
 522            ToDo: fix me
 523           -}
 524     hdl   <- getBufferMode hdl
 525     success <-
 526              (case bufferMode hdl of
 527                Just LineBuffering ->
 528                   writeChars (filePtr hdl) str
 529                   --writeLines (filePtr hdl) str
 530                Just (BlockBuffering (Just size)) ->
 531                   writeBlocks (filePtr hdl) size str
 532                Just (BlockBuffering Nothing) ->
 533                   writeBlocks (filePtr hdl) ``BUFSIZ'' str
 534                _ -> -- Nothing is treated pessimistically as NoBuffering
 535                   writeChars (filePtr hdl) str)
 536     writeHandle handle (markHandle hdl)
 537     if success
 538      then return ()
 539      else constructErrorAndFail "hPutBuf"
 540
 541 end{code}
 542
 543 Computation $hPrint hdl t$ writes the string representation of {\em t}
 544 given by the $shows$ function to the file or channel managed by {\em
 545 hdl}.
 546
 547 SOF 2/97: Seem to have disappeared in 1.4 libs.
 548
 549 \begin{code}
 550 --hPrint :: Show a => Handle -> a -> IO ()
 551 hPrint hdl = hPutStr hdl . show
 552 \end{code}
 553
 554 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
 555 the handle \tr{hdl}, adding a newline at the end.
 556
 557 \begin{code}
 558 --hPutStrLn :: Handle -> String -> IO ()
 559 hPutStrLn hndl str = do
 560  hPutStr  hndl str
 561  hPutChar hndl '\n'
 562
 563 \end{code}
 564
 565
 566 %*********************************************************
 567 %*                                                      *
 568 \subsection{Try and bracket}
 569 %*                                                      *
 570 %*********************************************************
 571
 572 The construct $try comp$ exposes errors which occur within a
 573 computation, and which are not fully handled.  It always succeeds.
 574
 575 \begin{code}
 576 try            :: IO a -> IO (Either IOError a)
 577 try f          =  catch (do r <- f
 578                             return (Right r))
 579                         (return . Left)
 580
 581 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 582 bracket before after m = do
 583         x  <- before
 584         rs <- try (m x)
 585         after x
 586         case rs of
 587            Right r -> return r
 588            Left  e -> fail e
 589
 590 -- variant of the above where middle computation doesn't want x
 591 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 592 bracket_ before after m = do
 593          x  <- before
 594          rs <- try m
 595          after x
 596          case rs of
 597             Right r -> return r
 598             Left  e -> fail e
 599 \end{code}
 600