ghc/lib/std/IO.lhs

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