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