ghc/lib/std/IO.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[IO]{Module @IO@}
   5
   6 Implementation of the standard Haskell IO interface, see
   7 @http://haskell.org/onlinelibrary/io.html@ for the official
   8 definition.
   9
  10 \begin{code}
  11 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
  12
  13 module IO (
  14     Handle,             -- abstract, instance of: Eq, Show.
  15     HandlePosn(..),     -- abstract, instance of: Eq, Show.
  16
  17     IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
  18     BufferMode(NoBuffering,LineBuffering,BlockBuffering),
  19     SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
  20
  21     stdin, stdout, stderr,   -- :: Handle
  22
  23     openFile,                  -- :: FilePath -> IOMode -> IO Handle
  24     hClose,                    -- :: Handle -> IO ()
  25     hFileSize,                 -- :: Handle -> IO Integer
  26     hIsEOF,                    -- :: Handle -> IO Bool
  27     isEOF,                     -- :: IO Bool
  28
  29     hSetBuffering,             -- :: Handle -> BufferMode -> IO ()
  30     hGetBuffering,             -- :: Handle -> IO BufferMode
  31     hFlush,                    -- :: Handle -> IO ()
  32     hGetPosn,                  -- :: Handle -> IO HandlePosn
  33     hSetPosn,                  -- :: Handle -> HandlePosn -> IO ()
  34     hSeek,                     -- :: Handle -> SeekMode -> Integer -> IO ()
  35     hWaitForInput,             -- :: Handle -> Int -> IO Bool
  36     hReady,                    -- :: Handle -> IO Bool
  37     hGetChar,                  -- :: Handle -> IO Char
  38     hGetLine,                  -- :: Handle -> IO [Char]
  39     hLookAhead,                -- :: Handle -> IO Char
  40     hGetContents,              -- :: Handle -> IO [Char]
  41     hPutChar,                  -- :: Handle -> Char -> IO ()
  42     hPutStr,                   -- :: Handle -> [Char] -> IO ()
  43     hPutStrLn,                 -- :: Handle -> [Char] -> IO ()
  44     hPrint,                    -- :: Show a => Handle -> a -> IO ()
  45     hIsOpen, hIsClosed,        -- :: Handle -> IO Bool
  46     hIsReadable, hIsWritable,  -- :: Handle -> IO Bool
  47     hIsSeekable,               -- :: Handle -> IO Bool
  48
  49     isAlreadyExistsError, isDoesNotExistError,  -- :: IOError -> Bool
  50     isAlreadyInUseError, isFullError,
  51     isEOFError, isIllegalOperation,
  52     isPermissionError, isUserError,
  53
  54     ioeGetErrorString,         -- :: IOError -> String
  55     ioeGetHandle,              -- :: IOError -> Maybe Handle
  56     ioeGetFileName,            -- :: IOError -> Maybe FilePath
  57
  58     try,                       -- :: IO a -> IO (Either IOError a)
  59     bracket,                   -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
  60     bracket_,                  -- :: IO a -> (a -> IO b) -> IO c -> IO c
  61
  62     -- Non-standard extension (but will hopefully become standard with 1.5) is
  63     -- to export the Prelude io functions via IO (in addition to exporting them
  64     -- from the prelude...for now.)
  65     IO,
  66     FilePath,                  -- :: String
  67     IOError,
  68     ioError,                   -- :: IOError -> IO a
  69     userError,                 -- :: String  -> IOError
  70     catch,                     -- :: IO a    -> (IOError -> IO a) -> IO a
  71     interact,                  -- :: (String -> String) -> IO ()
  72
  73     putChar,                   -- :: Char   -> IO ()
  74     putStr,                    -- :: String -> IO ()
  75     putStrLn,                  -- :: String -> IO ()
  76     print,                     -- :: Show a => a -> IO ()
  77     getChar,                   -- :: IO Char
  78     getLine,                   -- :: IO String
  79     getContents,               -- :: IO String
  80     readFile,                  -- :: FilePath -> IO String
  81     writeFile,                 -- :: FilePath -> String -> IO ()
  82     appendFile,                -- :: FilePath -> String -> IO ()
  83     readIO,                    -- :: Read a => String -> IO a
  84     readLn,                    -- :: Read a => IO a
  85
  86 #ifndef __HUGS__
  87     -- extensions
  88     hPutBuf,
  89     hPutBufBA,
  90 #endif
  91     slurpFile
  92
  93   ) where
  94
  95 #ifdef __HUGS__
  96 import Ix(Ix)
  97 #else
  98 --import PrelST
  99 import PrelBase
 100
 101 import PrelIOBase
 102 import PrelHandle               -- much of the real stuff is in here
 103
 104 import PrelRead         ( readParen, Read(..), reads, lex,
 105                           readIO
 106                         )
 107 import PrelShow
 108 import PrelMaybe        ( Either(..), Maybe(..) )
 109 import PrelAddr         ( Addr(..), nullAddr )
 110 import PrelArr          ( ByteArray )
 111 import PrelPack         ( unpackNBytesAccST )
 112 import PrelException    ( ioError, catch )
 113
 114 #ifndef __PARALLEL_HASKELL__
 115 import PrelForeign  ( ForeignObj )
 116 #endif
 117
 118 import Char             ( ord, chr )
 119
 120 #endif /* ndef __HUGS__ */
 121 \end{code}
 122
 123 #ifndef __HUGS__
 124 %*********************************************************
 125 %*                                                      *
 126 \subsection{Simple input operations}
 127 %*                                                      *
 128 %*********************************************************
 129
 130 Computation @hReady hdl@ indicates whether at least
 131 one item is available for input from handle {\em hdl}.
 132
 133 @hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
 134 before deciding whether the Handle has run dry or not.
 135
 136 If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
 137 If not, it tries to read from the underlying OS handle. Notice that
 138 for buffered Handles connected to terminals this means waiting until a complete
 139 line is available.
 140
 141 \begin{code}
 142 hReady :: Handle -> IO Bool
 143 hReady h = hWaitForInput h 0
 144
 145 hWaitForInput :: Handle -> Int -> IO Bool
 146 hWaitForInput handle msecs =
 147     wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
 148     rc       <- inputReady (haFO__ handle_) (msecs::Int)     -- ConcHask: SAFE, won't block
 149     case (rc::Int) of
 150       0 -> return False
 151       1 -> return True
 152       _ -> constructErrorAndFail "hWaitForInput"
 153 \end{code}
 154
 155 @hGetChar hdl@ reads the next character from handle @hdl@,
 156 blocking until a character is available.
 157
 158 \begin{code}
 159 hGetChar :: Handle -> IO Char
 160 hGetChar handle =
 161     wantReadableHandle "hGetChar" handle $ \ handle_ -> do
 162     let fo = haFO__ handle_
 163     intc     <- mayBlock fo (fileGetc fo)  -- ConcHask: UNSAFE, may block
 164     if intc /= ((-1)::Int)
 165      then return (chr intc)
 166      else constructErrorAndFail "hGetChar"
 167
 168 {-
 169   If EOF is reached before EOL is encountered, ignore the
 170   EOF and return the partial line. Next attempt at calling
 171   hGetLine on the handle will yield an EOF IO exception though.
 172 -}
 173 hGetLine :: Handle -> IO String
 174 hGetLine h = do
 175   c <- hGetChar h
 176   if c == '\n' then
 177      return ""
 178    else do
 179     l <- getRest
 180     return (c:l)
 181  where
 182   getRest = do
 183     c <-
 184       catch
 185         (hGetChar h)
 186         (\ err -> do
 187           if isEOFError err then
 188              return '\n'
 189            else
 190              ioError err)
 191     if c == '\n' then
 192        return ""
 193      else do
 194        s <- getRest
 195        return (c:s)
 196
 197 \end{code}
 198
 199 @hLookahead hdl@ returns the next character from handle @hdl@
 200 without removing it from the input buffer, blocking until a
 201 character is available.
 202
 203 \begin{code}
 204 hLookAhead :: Handle -> IO Char
 205 hLookAhead handle =
 206     wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
 207     let fo = haFO__ handle_
 208     intc    <- mayBlock fo (fileLookAhead fo)  -- ConcHask: UNSAFE, may block
 209     if intc /= (-1)
 210      then return (chr intc)
 211      else constructErrorAndFail "hLookAhead"
 212
 213 \end{code}
 214
 215
 216 %*********************************************************
 217 %*                                                      *
 218 \subsection{Getting the entire contents of a handle}
 219 %*                                                      *
 220 %*********************************************************
 221
 222 @hGetContents hdl@ returns the list of characters corresponding
 223 to the unread portion of the channel or file managed by @hdl@,
 224 which is made semi-closed.
 225
 226 \begin{code}
 227 hGetContents :: Handle -> IO String
 228 hGetContents handle =
 229         -- can't use wantReadableHandle here, because we want to side effect
 230         -- the handle.
 231     withHandle handle $ \ handle_ -> do
 232     case haType__ handle_ of
 233       ErrorHandle theError -> ioError theError
 234       ClosedHandle         -> ioe_closedHandle "hGetContents" handle
 235       SemiClosedHandle     -> ioe_closedHandle "hGetContents" handle
 236       AppendHandle         -> ioError not_readable_error
 237       WriteHandle          -> ioError not_readable_error
 238       _ -> do
 239           {-
 240             To avoid introducing an extra layer of buffering here,
 241             we provide three lazy read methods, based on character,
 242             line, and block buffering.
 243           -}
 244         let handle_' = handle_{ haType__ = SemiClosedHandle }
 245         case (haBufferMode__ handle_) of
 246          LineBuffering    -> do
 247             str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
 248             return (handle_', str)
 249          BlockBuffering _ -> do
 250             str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
 251             return (handle_', str)
 252          NoBuffering      -> do
 253             str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
 254             return (handle_', str)
 255   where
 256    not_readable_error =
 257            IOError (Just handle) IllegalOperation "hGetContents"
 258                    ("handle is not open for reading")
 259 \end{code}
 260
 261 Note that someone may close the semi-closed handle (or change its buffering),
 262 so each these lazy read functions are pulled on, they have to check whether
 263 the handle has indeed been closed.
 264
 265 \begin{code}
 266 #ifndef __PARALLEL_HASKELL__
 267 lazyReadBlock :: Handle -> ForeignObj -> IO String
 268 lazyReadLine  :: Handle -> ForeignObj -> IO String
 269 lazyReadChar  :: Handle -> ForeignObj -> IO String
 270 #else
 271 lazyReadBlock :: Handle -> Addr -> IO String
 272 lazyReadLine  :: Handle -> Addr -> IO String
 273 lazyReadChar  :: Handle -> Addr -> IO String
 274 #endif
 275
 276 lazyReadBlock handle fo = do
 277    buf   <- getBufStart fo 0
 278    bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
 279    case (bytes::Int) of
 280      -3 -> -- buffering has been turned off, use lazyReadChar instead
 281            lazyReadChar handle fo
 282      -2 -> return ""
 283      -1 -> -- an error occurred, close the handle
 284           withHandle handle $ \ handle_ -> do
 285           closeFile (haFO__ handle_) 0{-don't bother flushing-}  -- ConcHask: SAFE, won't block.
 286           return (handle_ { haType__    = ClosedHandle,
 287                             haFO__      = nullFile__ },
 288                   "")
 289      _ -> do
 290       more <- unsafeInterleaveIO (lazyReadBlock handle fo)
 291       stToIO (unpackNBytesAccST buf bytes more)
 292
 293 lazyReadLine handle fo = do
 294      bytes <- mayBlock fo (readLine fo)   -- ConcHask: UNSAFE, may block.
 295      case (bytes::Int) of
 296        -3 -> -- buffering has been turned off, use lazyReadChar instead
 297              lazyReadChar handle fo
 298        -2 -> return "" -- handle closed by someone else, stop reading.
 299        -1 -> -- an error occurred, close the handle
 300              withHandle handle $ \ handle_ -> do
 301              closeFile (haFO__ handle_) 0{- don't bother flushing-}  -- ConcHask: SAFE, won't block
 302              return (handle_ { haType__    = ClosedHandle,
 303                                haFO__      = nullFile__ },
 304                      "")
 305        _ -> do
 306           more <- unsafeInterleaveIO (lazyReadLine handle fo)
 307           buf  <- getBufStart fo bytes  -- ConcHask: won't block
 308           stToIO (unpackNBytesAccST buf bytes more)
 309
 310 lazyReadChar handle fo = do
 311     char <- mayBlock fo (readChar fo)   -- ConcHask: UNSAFE, may block.
 312     case (char::Int) of
 313       -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
 314             lazyReadBlock handle fo
 315
 316       -3 -> -- buffering is now line-buffered, use lazyReadLine instead
 317             lazyReadLine handle fo
 318       -2 -> return ""
 319       -1 -> -- error, silently close handle.
 320          withHandle handle $ \ handle_ -> do
 321          closeFile (haFO__ handle_) 0{-don't bother flusing-}  -- ConcHask: SAFE, won't block
 322          return (handle_{ haType__  = ClosedHandle,
 323                           haFO__    = nullFile__ },
 324                  "")
 325       _ -> do
 326          more <- unsafeInterleaveIO (lazyReadChar handle fo)
 327          return (chr char : more)
 328
 329 \end{code}
 330
 331
 332 %*********************************************************
 333 %*                                                      *
 334 \subsection{Simple output functions}
 335 %*                                                      *
 336 %*********************************************************
 337
 338 @hPutChar hdl ch@ writes the character @ch@ to the file
 339 or channel managed by @hdl@.  Characters may be buffered if
 340 buffering is enabled for @hdl@
 341
 342 \begin{code}
 343 hPutChar :: Handle -> Char -> IO ()
 344 hPutChar handle c =
 345     wantWriteableHandle "hPutChar" handle $ \ handle_  -> do
 346     let fo = haFO__ handle_
 347     flushConnectedBuf fo
 348     rc       <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
 349     if rc == 0
 350      then return ()
 351      else constructErrorAndFail "hPutChar"
 352
 353 \end{code}
 354
 355 @hPutStr hdl s@ writes the string @s@ to the file or
 356 channel managed by @hdl@, buffering the output if needs be.
 357
 358 \begin{code}
 359 hPutStr :: Handle -> String -> IO ()
 360 hPutStr handle str =
 361     wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
 362     let fo = haFO__ handle_
 363     flushConnectedBuf fo
 364     case haBufferMode__ handle_ of
 365        LineBuffering -> do
 366             buf <- getWriteableBuf fo
 367             pos <- getBufWPtr fo
 368             bsz <- getBufSize fo
 369             writeLines fo buf bsz pos str
 370        BlockBuffering _ -> do
 371             buf <- getWriteableBuf fo
 372             pos <- getBufWPtr fo
 373             bsz <- getBufSize fo
 374             writeBlocks fo buf bsz pos str
 375        NoBuffering -> do
 376             writeChars fo str
 377 \end{code}
 378
 379 Going across the border between Haskell and C is relatively costly,
 380 so for block writes we pack the character strings on the Haskell-side
 381 before passing the external write routine a pointer to the buffer.
 382
 383 \begin{code}
 384 #ifdef __HUGS__
 385
 386 #ifdef __CONCURRENT_HASKELL__
 387 /* See comment in shoveString below for explanation */
 388 #warning delayed update of buffer disnae work with killThread
 389 #endif
 390
 391 #ifndef __PARALLEL_HASKELL__
 392 writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 393 #else
 394 writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
 395 #endif
 396 writeLines obj buf bufLen initPos s =
 397   let
 398    shoveString :: Int -> [Char] -> IO ()
 399    shoveString n ls =
 400      case ls of
 401       [] ->
 402           {-
 403             At the end of a buffer write, update the buffer position
 404             in the underlying file object, so that if the handle
 405             is subsequently dropped by the program, the whole
 406             buffer will be properly flushed.
 407
 408             There's one case where this delayed up-date of the buffer
 409             position can go wrong: if a thread is killed, it might be
 410             in the middle of filling up a buffer, with the result that
 411             the partial buffer update is lost upon finalisation. Not
 412             that killing of threads is supported at the moment.
 413
 414           -}
 415           setBufWPtr obj n
 416
 417       (x:xs) -> do
 418         primWriteCharOffAddr buf n x
 419           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
 420         if n == bufLen || x == '\n'
 421          then do
 422            rc <-  mayBlock obj (writeFileObject obj (n + 1))  -- ConcHask: UNSAFE, may block.
 423            if rc == 0
 424             then shoveString 0 xs
 425             else constructErrorAndFail "writeLines"
 426          else
 427            shoveString (n + 1) xs
 428   in
 429   shoveString initPos s
 430 #else /* ndef __HUGS__ */
 431 #ifndef __PARALLEL_HASKELL__
 432 writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 433 #else
 434 writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
 435 #endif
 436 writeLines obj buf (I# bufLen) (I# initPos#) s =
 437   let
 438    write_char :: Addr -> Int# -> Char# -> IO ()
 439    write_char (A# buf#) n# c# =
 440       IO $ \ s# ->
 441       case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 442
 443    shoveString :: Int# -> [Char] -> IO ()
 444    shoveString n ls =
 445      case ls of
 446       [] ->
 447           {-
 448             At the end of a buffer write, update the buffer position
 449             in the underlying file object, so that if the handle
 450             is subsequently dropped by the program, the whole
 451             buffer will be properly flushed.
 452
 453             There's one case where this delayed up-date of the buffer
 454             position can go wrong: if a thread is killed, it might be
 455             in the middle of filling up a buffer, with the result that
 456             the partial buffer update is lost upon finalisation. Not
 457             that killing of threads is supported at the moment.
 458
 459           -}
 460           setBufWPtr obj (I# n)
 461
 462       ((C# x):xs) -> do
 463         write_char buf n x
 464           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
 465         if n ==# bufLen || x `eqChar#` '\n'#
 466          then do
 467            rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))  -- ConcHask: UNSAFE, may block.
 468            if rc == 0
 469             then shoveString 0# xs
 470             else constructErrorAndFail "writeLines"
 471          else
 472            shoveString (n +# 1#) xs
 473   in
 474   shoveString initPos# s
 475 #endif /* ndef __HUGS__ */
 476
 477 #ifdef __HUGS__
 478 #ifndef __PARALLEL_HASKELL__
 479 writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 480 #else
 481 writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
 482 #endif
 483 writeBlocks obj buf bufLen initPos s =
 484   let
 485    shoveString :: Int -> [Char] -> IO ()
 486    shoveString n ls =
 487      case ls of
 488       [] ->
 489           {-
 490             At the end of a buffer write, update the buffer position
 491             in the underlying file object, so that if the handle
 492             is subsequently dropped by the program, the whole
 493             buffer will be properly flushed.
 494
 495             There's one case where this delayed up-date of the buffer
 496             position can go wrong: if a thread is killed, it might be
 497             in the middle of filling up a buffer, with the result that
 498             the partial buffer update is lost upon finalisation. However,
 499             by the time killThread is supported, Haskell finalisers are also
 500             likely to be in, which means the 'IOFileObject' hack can go
 501             alltogether.
 502
 503           -}
 504           setBufWPtr obj n
 505
 506       (x:xs) -> do
 507         primWriteCharOffAddr buf n x
 508         if n == bufLen
 509          then do
 510            rc <-  mayBlock obj (writeFileObject obj (n + 1))   -- ConcHask: UNSAFE, may block.
 511            if rc == 0
 512             then shoveString 0 xs
 513             else constructErrorAndFail "writeChunks"
 514          else
 515            shoveString (n + 1) xs
 516   in
 517   shoveString initPos s
 518 #else /* ndef __HUGS__ */
 519 #ifndef __PARALLEL_HASKELL__
 520 writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 521 #else
 522 writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
 523 #endif
 524 writeBlocks obj buf (I# bufLen) (I# initPos#) s =
 525   let
 526    write_char :: Addr -> Int# -> Char# -> IO ()
 527    write_char (A# buf#) n# c# =
 528       IO $ \ s# ->
 529       case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 530
 531    shoveString :: Int# -> [Char] -> IO ()
 532    shoveString n ls =
 533      case ls of
 534       [] ->
 535           {-
 536             At the end of a buffer write, update the buffer position
 537             in the underlying file object, so that if the handle
 538             is subsequently dropped by the program, the whole
 539             buffer will be properly flushed.
 540
 541             There's one case where this delayed up-date of the buffer
 542             position can go wrong: if a thread is killed, it might be
 543             in the middle of filling up a buffer, with the result that
 544             the partial buffer update is lost upon finalisation. However,
 545             by the time killThread is supported, Haskell finalisers are also
 546             likely to be in, which means the 'IOFileObject' hack can go
 547             alltogether.
 548
 549           -}
 550           setBufWPtr obj (I# n)
 551
 552       ((C# x):xs) -> do
 553         write_char buf n x
 554         if n ==# bufLen
 555          then do
 556            rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))   -- ConcHask: UNSAFE, may block.
 557            if rc == 0
 558             then shoveString 0# xs
 559             else constructErrorAndFail "writeChunks"
 560          else
 561            shoveString (n +# 1#) xs
 562   in
 563   shoveString initPos# s
 564 #endif /* ndef __HUGS__ */
 565
 566 #ifndef __PARALLEL_HASKELL__
 567 writeChars :: ForeignObj -> String -> IO ()
 568 #else
 569 writeChars :: Addr -> String -> IO ()
 570 #endif
 571 writeChars _fo ""    = return ()
 572 writeChars fo (c:cs) = do
 573   rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
 574   if rc == 0
 575    then writeChars fo cs
 576    else constructErrorAndFail "writeChars"
 577
 578 \end{code}
 579
 580 Computation @hPrint hdl t@ writes the string representation of {\em t}
 581 given by the @shows@ function to the file or channel managed by {\em
 582 hdl}.
 583
 584 [ Seem to have disappeared from the 1.4 interface  - SOF 2/97 ]
 585
 586 \begin{code}
 587 hPrint :: Show a => Handle -> a -> IO ()
 588 hPrint hdl = hPutStrLn hdl . show
 589 \end{code}
 590
 591 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
 592 the handle \tr{hdl}, adding a newline at the end.
 593
 594 \begin{code}
 595 hPutStrLn :: Handle -> String -> IO ()
 596 hPutStrLn hndl str = do
 597  hPutStr  hndl str
 598  hPutChar hndl '\n'
 599
 600 \end{code}
 601
 602
 603 %*********************************************************
 604 %*                                                      *
 605 \subsection{Try and bracket}
 606 %*                                                      *
 607 %*********************************************************
 608
 609 The construct @try comp@ exposes errors which occur within a
 610 computation, and which are not fully handled.  It always succeeds.
 611
 612 \begin{code}
 613 try            :: IO a -> IO (Either IOError a)
 614 try f          =  catch (do r <- f
 615                             return (Right r))
 616                         (return . Left)
 617
 618 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 619 bracket before after m = do
 620         x  <- before
 621         rs <- try (m x)
 622         after x
 623         case rs of
 624            Right r -> return r
 625            Left  e -> ioError e
 626
 627 -- variant of the above where middle computation doesn't want x
 628 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 629 bracket_ before after m = do
 630          x  <- before
 631          rs <- try m
 632          after x
 633          case rs of
 634             Right r -> return r
 635             Left  e -> ioError e
 636 \end{code}
 637
 638 %*********************************************************
 639 %*                                                       *
 640 \subsection{Standard IO}
 641 %*                                                       *
 642 %*********************************************************
 643
 644 The Prelude has from Day 1 provided a collection of common
 645 IO functions. We define these here, but let the Prelude
 646 export them.
 647
 648 \begin{code}
 649 putChar         :: Char -> IO ()
 650 putChar c       =  hPutChar stdout c
 651
 652 putStr          :: String -> IO ()
 653 putStr s        =  hPutStr stdout s
 654
 655 putStrLn        :: String -> IO ()
 656 putStrLn s      =  do putStr s
 657                       putChar '\n'
 658
 659 print           :: Show a => a -> IO ()
 660 print x         =  putStrLn (show x)
 661
 662 getChar         :: IO Char
 663 getChar         =  hGetChar stdin
 664
 665 getLine         :: IO String
 666 getLine         =  hGetLine stdin
 667
 668 getContents     :: IO String
 669 getContents     =  hGetContents stdin
 670
 671 interact        ::  (String -> String) -> IO ()
 672 interact f      =   do s <- getContents
 673                        putStr (f s)
 674
 675 readFile        :: FilePath -> IO String
 676 readFile name   =  openFile name ReadMode >>= hGetContents
 677
 678 writeFile       :: FilePath -> String -> IO ()
 679 writeFile name str = do
 680     hdl <- openFile name WriteMode
 681     hPutStr hdl str
 682     hClose hdl
 683
 684 appendFile      :: FilePath -> String -> IO ()
 685 appendFile name str = do
 686     hdl <- openFile name AppendMode
 687     hPutStr hdl str
 688     hClose hdl
 689
 690 readLn          :: Read a => IO a
 691 readLn          =  do l <- getLine
 692                       r <- readIO l
 693                       return r
 694
 695
 696 \end{code}
 697
 698 #else /* __HUGS__ */
 699
 700 \begin{code}
 701 import Ix(Ix)
 702
 703 unimp :: String -> a
 704 unimp s = error ("IO library: function not implemented: " ++ s)
 705
 706 type FILE_STAR = Addr
 707 type Ptr       = Addr
 708 nULL           = nullAddr
 709
 710 data Handle
 711    = Handle { name     :: FilePath,
 712               file     :: FILE_STAR,         -- C handle
 713               mut      :: IORef Handle_Mut,  -- open/closed/semiclosed
 714               mode     :: IOMode,
 715               seekable :: Bool
 716             }
 717
 718 data Handle_Mut
 719    = Handle_Mut { state :: HState
 720                 }
 721
 722 set_state :: Handle -> HState -> IO ()
 723 set_state hdl new_state
 724    = writeIORef (mut hdl) (Handle_Mut { state = new_state })
 725 get_state :: Handle -> IO HState
 726 get_state hdl
 727    = readIORef (mut hdl) >>= \m -> return (state m)
 728
 729 mkErr :: Handle -> String -> IO a
 730 mkErr h msg
 731    = do nh_close (file h)
 732         dummy <- nh_errno
 733         ioError (IOError msg)
 734
 735 stdin
 736    = Handle {
 737         name = "stdin",
 738         file = primRunST nh_stdin,
 739         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 740         mode = ReadMode
 741      }
 742
 743 stdout
 744    = Handle {
 745         name = "stdout",
 746         file = primRunST nh_stdout,
 747         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 748         mode = WriteMode
 749      }
 750
 751 stderr
 752    = Handle {
 753         name = "stderr",
 754         file = primRunST nh_stderr,
 755         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 756         mode = WriteMode
 757      }
 758
 759
 760 instance Eq Handle where
 761    h1 == h2   = file h1 == file h2
 762
 763 instance Show Handle where
 764    showsPrec _ h = showString ("<<" ++ name h ++ ">>")
 765
 766 data HandlePosn
 767    = HandlePosn
 768      deriving (Eq, Show)
 769
 770
 771 data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
 772                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 773
 774 data BufferMode  =  NoBuffering | LineBuffering
 775                  |  BlockBuffering
 776                     deriving (Eq, Ord, Read, Show)
 777
 778 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 779                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 780
 781 data HState = HOpen | HSemiClosed | HClosed
 782               deriving Eq
 783
 784 openFile :: FilePath -> IOMode -> IO Handle
 785 openFile f mode
 786    = copy_String_to_cstring f >>= \nameptr ->
 787      nh_open nameptr (mode2num mode) >>= \fh ->
 788      nh_free nameptr >>
 789      if   fh == nULL
 790      then (ioError.IOError)
 791              ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
 792      else do r <- newIORef (Handle_Mut { state = HOpen })
 793              return (Handle {
 794                         name = f,
 795                         file = fh,
 796                         mut  = r,
 797                         mode = mode
 798                      })
 799      where
 800         mode2num :: IOMode -> Int
 801         mode2num ReadMode   = 0
 802         mode2num WriteMode  = 1
 803         mode2num AppendMode = 2
 804         mode2num ReadWriteMode
 805            = error
 806                 ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")
 807
 808 hClose :: Handle -> IO ()
 809 hClose h
 810    = do mut <- readIORef (mut h)
 811         if    state mut == HClosed
 812          then mkErr h
 813                  ("hClose on closed handle " ++ show h)
 814          else
 815          do set_state h HClosed
 816             nh_close (file h)
 817             err <- nh_errno
 818             if    err == 0
 819              then return ()
 820              else mkErr h
 821                      ("hClose: error closing " ++ name h)
 822
 823 hGetContents :: Handle -> IO String
 824 hGetContents h
 825    | mode h /= ReadMode
 826    = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
 827    | otherwise
 828    = do mut <- readIORef (mut h)
 829         if    state mut /= HOpen
 830          then mkErr h
 831                  ("hGetContents on closed/semiclosed handle " ++ show h)
 832          else
 833          do set_state h HSemiClosed
 834             read_all (file h)
 835             where
 836                read_all f
 837                   = nh_read f >>= \ci ->
 838                     if   ci == -1
 839                     then return []
 840                     else read_all f >>= \rest ->
 841                          return ((primIntToChar ci):rest)
 842
 843 hPutStr :: Handle -> String -> IO ()
 844 hPutStr h s
 845    | mode h == ReadMode
 846    = mkErr h ("hPutStr on ReadMode handle " ++ show h)
 847    | otherwise
 848    = do mut <- readIORef (mut h)
 849         if    state mut /= HOpen
 850          then mkErr h
 851                  ("hPutStr on closed/semiclosed handle " ++ show h)
 852          else write_all (file h) s
 853               where
 854                  write_all f []
 855                     = return ()
 856                  write_all f (c:cs)
 857                     = nh_write f c >> write_all f cs
 858
 859 hFileSize :: Handle -> IO Integer
 860 hFileSize h
 861    = do sz <- nh_filesize (file h)
 862         er <- nh_errno
 863         if    er == 0
 864          then return (fromIntegral sz)
 865          else mkErr h ("hFileSize on " ++ show h)
 866
 867 hIsEOF :: Handle -> IO Bool
 868 hIsEOF h
 869    = do iseof <- nh_iseof (file h)
 870         er    <- nh_errno
 871         if    er == 0
 872          then return (iseof /= 0)
 873          else mkErr h ("hIsEOF on " ++ show h)
 874
 875 isEOF :: IO Bool
 876 isEOF = hIsEOF stdin
 877
 878 hSetBuffering         :: Handle  -> BufferMode -> IO ()
 879 hSetBuffering          = unimp "IO.hSetBuffering"
 880 hGetBuffering         :: Handle  -> IO BufferMode
 881 hGetBuffering          = unimp "IO.hGetBuffering"
 882
 883 hFlush :: Handle -> IO ()
 884 hFlush h
 885    = do mut <- readIORef (mut h)
 886         if    state mut /= HOpen
 887          then mkErr h
 888                  ("hFlush on closed/semiclosed file " ++ name h)
 889          else nh_flush (file h)
 890
 891 hGetPosn              :: Handle -> IO HandlePosn
 892 hGetPosn               = unimp "IO.hGetPosn"
 893 hSetPosn              :: HandlePosn -> IO ()
 894 hSetPosn               = unimp "IO.hSetPosn"
 895 hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
 896 hSeek                  = unimp "IO.hSeek"
 897 hWaitForInput         :: Handle -> Int -> IO Bool
 898 hWaitForInput          = unimp "hWaitForInput"
 899 hReady                :: Handle -> IO Bool
 900 hReady h               = unimp "hReady" -- hWaitForInput h 0
 901
 902 hGetChar    :: Handle -> IO Char
 903 hGetChar h
 904    = nh_read (file h) >>= \ci ->
 905      return (primIntToChar ci)
 906
 907 hGetLine              :: Handle -> IO String
 908 hGetLine h             = do c <- hGetChar h
 909                             if c=='\n' then return ""
 910                               else do cs <- hGetLine h
 911                                       return (c:cs)
 912
 913 hLookAhead            :: Handle -> IO Char
 914 hLookAhead             = unimp "IO.hLookAhead"
 915
 916
 917 hPutChar              :: Handle -> Char -> IO ()
 918 hPutChar h c           = hPutStr h [c]
 919
 920 hPutStrLn             :: Handle -> String -> IO ()
 921 hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
 922
 923 hPrint                :: Show a => Handle -> a -> IO ()
 924 hPrint h               = hPutStrLn h . show
 925
 926 hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
 927 hIsOpen h              = do { s <- get_state h; return (s == HOpen) }
 928 hIsClosed h            = do { s <- get_state h; return (s == HClosed) }
 929 hIsReadable h          = return (mode h == ReadMode)
 930 hIsWritable h          = return (mode h `elem` [WriteMode, AppendMode])
 931
 932 hIsSeekable           :: Handle -> IO Bool
 933 hIsSeekable            = unimp "IO.hIsSeekable"
 934
 935 isIllegalOperation,
 936           isAlreadyExistsError,
 937           isDoesNotExistError,
 938           isAlreadyInUseError,
 939           isFullError,
 940           isEOFError,
 941           isPermissionError,
 942           isUserError        :: IOError -> Bool
 943
 944 isIllegalOperation    = unimp "IO.isIllegalOperation"
 945 isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
 946 isDoesNotExistError   = unimp "IO.isDoesNotExistError"
 947 isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
 948 isFullError           = unimp "IO.isFullError"
 949 isEOFError            = unimp "IO.isEOFError"
 950 isPermissionError     = unimp "IO.isPermissionError"
 951 isUserError           = unimp "IO.isUserError"
 952
 953
 954 ioeGetErrorString :: IOError -> String
 955 ioeGetErrorString = unimp "IO.ioeGetErrorString"
 956 ioeGetHandle      :: IOError -> Maybe Handle
 957 ioeGetHandle      = unimp "IO.ioeGetHandle"
 958 ioeGetFileName    :: IOError -> Maybe FilePath
 959 ioeGetFileName    = unimp "IO.ioeGetFileName"
 960
 961 try       :: IO a -> IO (Either IOError a)
 962 try p      = catch (p >>= (return . Right)) (return . Left)
 963
 964 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 965 bracket before after m = do
 966         x  <- before
 967         rs <- try (m x)
 968         after x
 969         case rs of
 970            Right r -> return r
 971            Left  e -> ioError e
 972
 973 -- variant of the above where middle computation doesn't want x
 974 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 975 bracket_ before after m = do
 976          x  <- before
 977          rs <- try m
 978          after x
 979          case rs of
 980             Right r -> return r
 981             Left  e -> ioError e
 982 -- TODO: Hugs/slurpFile
 983 slurpFile = unimp "IO.slurpFile"
 984 \end{code}
 985
 986 #endif /* #ifndef __HUGS__ */