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