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