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