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