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 PrelByteArr      ( 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 import Monad(when)
 703
 704 unimp :: String -> a
 705 unimp s = error ("IO library: function not implemented: " ++ s)
 706
 707 type FILE_STAR = Addr
 708 type Ptr       = Addr
 709 nULL           = nullAddr
 710
 711 data Handle
 712    = Handle { name     :: FilePath,
 713               file     :: FILE_STAR,         -- C handle
 714               mut      :: IORef Handle_Mut,  -- open/closed/semiclosed
 715               mode     :: IOMode,
 716               seekable :: Bool
 717             }
 718
 719 data Handle_Mut
 720    = Handle_Mut { state :: HState
 721                 }
 722      deriving Show
 723
 724 set_state :: Handle -> HState -> IO ()
 725 set_state hdl new_state
 726    = writeIORef (mut hdl) (Handle_Mut { state = new_state })
 727 get_state :: Handle -> IO HState
 728 get_state hdl
 729    = readIORef (mut hdl) >>= \m -> return (state m)
 730
 731 mkErr :: Handle -> String -> IO a
 732 mkErr h msg
 733    = do mut <- readIORef (mut h)
 734         when (state mut /= HClosed)
 735              (nh_close (file h) >> set_state h HClosed)
 736         dummy <- nh_errno
 737         ioError (IOError msg)
 738
 739 stdin
 740    = Handle {
 741         name = "stdin",
 742         file = primRunST nh_stdin,
 743         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 744         mode = ReadMode
 745      }
 746
 747 stdout
 748    = Handle {
 749         name = "stdout",
 750         file = primRunST nh_stdout,
 751         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 752         mode = WriteMode
 753      }
 754
 755 stderr
 756    = Handle {
 757         name = "stderr",
 758         file = primRunST nh_stderr,
 759         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 760         mode = WriteMode
 761      }
 762
 763
 764 instance Eq Handle where
 765    h1 == h2   = file h1 == file h2
 766
 767 instance Show Handle where
 768    showsPrec _ h = showString ("`" ++ name h ++ "'")
 769
 770 data HandlePosn
 771    = HandlePosn
 772      deriving (Eq, Show)
 773
 774
 775 data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
 776                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 777
 778 data BufferMode  =  NoBuffering | LineBuffering
 779                  |  BlockBuffering (Maybe Int)
 780                     deriving (Eq, Ord, Read, Show)
 781
 782 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 783                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 784
 785 data HState = HOpen | HSemiClosed | HClosed
 786               deriving (Show, Eq)
 787
 788
 789 -- A global variable holding a list of all open handles.
 790 -- Each handle is present as many times as it has been opened.
 791 -- Any given file is allowed to have _either_ one writeable handle
 792 -- or many readable handles in this list.  The list is used to
 793 -- enforce single-writer multiple reader semantics.  It also
 794 -- provides a list of handles for System.exitWith to flush and
 795 -- close.  In order not to have to put all this stuff in the
 796 -- Prelude, System.exitWith merely runs prelExitWithAction,
 797 -- which is originally Nothing, but which we set to Just ...
 798 -- once handles appear in the list.
 799
 800 allHandles :: IORef [Handle]
 801 allHandles  = primRunST (newIORef [])
 802
 803 elemWriterHandles :: FilePath -> IO Bool
 804 elemAllHandles    :: FilePath -> IO Bool
 805 addHandle         :: Handle -> IO ()
 806 delHandle         :: Handle -> IO ()
 807 cleanupHandles    :: IO ()
 808
 809 cleanupHandles
 810    = do hdls <- readIORef allHandles
 811         mapM_ cleanupHandle hdls
 812      where
 813         cleanupHandle h
 814            | mode h == ReadMode
 815            = nh_close (file h)
 816              >> nh_errno >>= \_ -> return ()
 817            | otherwise
 818            = nh_flush (file h) >> nh_close (file h)
 819              >> nh_errno >>= \_ -> return ()
 820
 821 elemWriterHandles fname
 822    = do hdls <- readIORef allHandles
 823         let hdls_w = filter ((/= ReadMode).mode) hdls
 824         return (fname `elem` (map name hdls_w))
 825
 826 elemAllHandles fname
 827    = do hdls <- readIORef allHandles
 828         return (fname `elem` (map name hdls))
 829
 830 addHandle hdl
 831    = do cleanup_action <- readIORef prelCleanupAfterRunAction
 832         case cleanup_action of
 833            Nothing
 834               -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles)
 835            Just xx
 836               -> return ()
 837         hdls <- readIORef allHandles
 838         writeIORef allHandles (hdl : hdls)
 839
 840 delHandle hdl
 841    = do hdls <- readIORef allHandles
 842         let hdls' = takeWhile (/= hdl) hdls
 843                     ++ drop 1 (dropWhile (/= hdl) hdls)
 844         writeIORef allHandles hdls'
 845
 846
 847
 848 openFile :: FilePath -> IOMode -> IO Handle
 849 openFile f mode
 850
 851    | null f
 852    =  (ioError.IOError) "openFile: empty file name"
 853
 854    | mode == ReadMode
 855    = do not_ok <- elemWriterHandles f
 856         if    not_ok
 857          then (ioError.IOError)
 858                  ("openFile: `" ++ f ++ "' in " ++ show mode
 859                   ++ ": is already open for writing")
 860          else openFile_main f mode
 861
 862    | mode /= ReadMode
 863    = do not_ok <- elemAllHandles f
 864         if    not_ok
 865          then (ioError.IOError)
 866                  ("openFile: `" ++ f ++ "' in " ++ show mode
 867                   ++ ": is already open for reading or writing")
 868          else openFile_main f mode
 869
 870    | otherwise
 871    = openFile_main f mode
 872
 873 openFile_main f mode
 874    = copy_String_to_cstring f >>= \nameptr ->
 875      nh_open nameptr (mode2num mode) >>= \fh ->
 876      nh_free nameptr >>
 877      if   fh == nULL
 878      then (ioError.IOError)
 879              ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
 880      else do r   <- newIORef (Handle_Mut { state = HOpen })
 881              let hdl = Handle { name = f, file = fh,
 882                                 mut  = r, mode = mode }
 883              addHandle hdl
 884              return hdl
 885      where
 886         mode2num :: IOMode -> Int
 887         mode2num ReadMode   = 0
 888         mode2num WriteMode  = 1
 889         mode2num AppendMode = 2
 890         mode2num ReadWriteMode
 891            = error
 892                 ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")
 893
 894 hClose :: Handle -> IO ()
 895 hClose h
 896    = do mut <- readIORef (mut h)
 897         putStrLn ( "hClose: state is " ++ show mut)
 898         if    state mut == HClosed
 899          then mkErr h
 900                  ("hClose on closed handle " ++ show h)
 901          else
 902          do set_state h HClosed
 903             delHandle h
 904             nh_close (file h)
 905             err <- nh_errno
 906             if    err == 0
 907              then return ()
 908              else mkErr h
 909                      ("hClose: error closing " ++ name h)
 910
 911 hGetContents :: Handle -> IO String
 912 hGetContents h
 913    | mode h /= ReadMode
 914    = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
 915    | otherwise
 916    = do mut <- readIORef (mut h)
 917         if    state mut /= HOpen
 918          then mkErr h
 919                  ("hGetContents on closed/semiclosed handle " ++ show h)
 920          else
 921          do set_state h HSemiClosed
 922             read_all (file h)
 923             where
 924                read_all f
 925                   = nh_read f >>= \ci ->
 926                     if   ci == -1
 927                     then return []
 928                     else read_all f >>= \rest ->
 929                          return ((primIntToChar ci):rest)
 930
 931 hPutStr :: Handle -> String -> IO ()
 932 hPutStr h s
 933    | mode h == ReadMode
 934    = mkErr h ("hPutStr on ReadMode handle " ++ show h)
 935    | otherwise
 936    = do mut <- readIORef (mut h)
 937         if    state mut /= HOpen
 938          then mkErr h
 939                  ("hPutStr on closed/semiclosed handle " ++ show h)
 940          else write_all (file h) s
 941               where
 942                  write_all f []
 943                     = return ()
 944                  write_all f (c:cs)
 945                     = nh_write f c >> write_all f cs
 946
 947 hFileSize :: Handle -> IO Integer
 948 hFileSize h
 949    = do sz <- nh_filesize (file h)
 950         er <- nh_errno
 951         if    er == 0
 952          then return (fromIntegral sz)
 953          else mkErr h ("hFileSize on " ++ show h)
 954
 955 hIsEOF :: Handle -> IO Bool
 956 hIsEOF h
 957    = do iseof <- nh_iseof (file h)
 958         er    <- nh_errno
 959         if    er == 0
 960          then return (iseof /= 0)
 961          else mkErr h ("hIsEOF on " ++ show h)
 962
 963 isEOF :: IO Bool
 964 isEOF = hIsEOF stdin
 965
 966 hSetBuffering         :: Handle  -> BufferMode -> IO ()
 967 hSetBuffering          = unimp "IO.hSetBuffering"
 968 hGetBuffering         :: Handle  -> IO BufferMode
 969 hGetBuffering          = unimp "IO.hGetBuffering"
 970
 971 hFlush :: Handle -> IO ()
 972 hFlush h
 973    = do mut <- readIORef (mut h)
 974         if    state mut /= HOpen
 975          then mkErr h
 976                  ("hFlush on closed/semiclosed file " ++ name h)
 977          else nh_flush (file h)
 978
 979 hGetPosn              :: Handle -> IO HandlePosn
 980 hGetPosn               = unimp "IO.hGetPosn"
 981 hSetPosn              :: HandlePosn -> IO ()
 982 hSetPosn               = unimp "IO.hSetPosn"
 983 hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
 984 hSeek                  = unimp "IO.hSeek"
 985 hWaitForInput         :: Handle -> Int -> IO Bool
 986 hWaitForInput          = unimp "hWaitForInput"
 987 hReady                :: Handle -> IO Bool
 988 hReady h               = unimp "hReady" -- hWaitForInput h 0
 989
 990 hGetChar    :: Handle -> IO Char
 991 hGetChar h
 992    = nh_read (file h) >>= \ci ->
 993      return (primIntToChar ci)
 994
 995 hGetLine              :: Handle -> IO String
 996 hGetLine h             = do c <- hGetChar h
 997                             if c=='\n' then return ""
 998                               else do cs <- hGetLine h
 999                                       return (c:cs)
1000
1001 hLookAhead            :: Handle -> IO Char
1002 hLookAhead             = unimp "IO.hLookAhead"
1003
1004
1005 hPutChar              :: Handle -> Char -> IO ()
1006 hPutChar h c           = hPutStr h [c]
1007
1008 hPutStrLn             :: Handle -> String -> IO ()
1009 hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
1010
1011 hPrint                :: Show a => Handle -> a -> IO ()
1012 hPrint h               = hPutStrLn h . show
1013
1014 hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
1015 hIsOpen h              = do { s <- get_state h; return (s == HOpen) }
1016 hIsClosed h            = do { s <- get_state h; return (s == HClosed) }
1017 hIsReadable h          = return (mode h == ReadMode)
1018 hIsWritable h          = return (mode h `elem` [WriteMode, AppendMode])
1019
1020 hIsSeekable           :: Handle -> IO Bool
1021 hIsSeekable            = unimp "IO.hIsSeekable"
1022
1023 isIllegalOperation,
1024           isAlreadyExistsError,
1025           isDoesNotExistError,
1026           isAlreadyInUseError,
1027           isFullError,
1028           isEOFError,
1029           isPermissionError,
1030           isUserError        :: IOError -> Bool
1031
1032 isIllegalOperation    = unimp "IO.isIllegalOperation"
1033 isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
1034 isDoesNotExistError   = unimp "IO.isDoesNotExistError"
1035 isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
1036 isFullError           = unimp "IO.isFullError"
1037 isEOFError            = unimp "IO.isEOFError"
1038 isPermissionError     = unimp "IO.isPermissionError"
1039 isUserError           = unimp "IO.isUserError"
1040
1041
1042 ioeGetErrorString :: IOError -> String
1043 ioeGetErrorString = unimp "IO.ioeGetErrorString"
1044 ioeGetHandle      :: IOError -> Maybe Handle
1045 ioeGetHandle      = unimp "IO.ioeGetHandle"
1046 ioeGetFileName    :: IOError -> Maybe FilePath
1047 ioeGetFileName    = unimp "IO.ioeGetFileName"
1048
1049 try       :: IO a -> IO (Either IOError a)
1050 try p      = catch (p >>= (return . Right)) (return . Left)
1051
1052 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
1053 bracket before after m = do
1054         x  <- before
1055         rs <- try (m x)
1056         after x
1057         case rs of
1058            Right r -> return r
1059            Left  e -> ioError e
1060
1061 -- variant of the above where middle computation doesn't want x
1062 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
1063 bracket_ before after m = do
1064          x  <- before
1065          rs <- try m
1066          after x
1067          case rs of
1068             Right r -> return r
1069             Left  e -> ioError e
1070
1071 -- TODO: Hugs/slurpFile
1072 slurpFile = unimp "IO.slurpFile"
1073 \end{code}
1074
1075 #endif /* #ifndef __HUGS__ */