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