ghc/lib/std/IO.lhs

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