ghc/lib/std/IO.lhs

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