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         if n == 0 then
 432           setBufWPtr obj 0{-new pos-}
 433         else do
 434           {-
 435             At the end of a buffer write, update the buffer position
 436             in the underlying file object, so that if the handle
 437             is subsequently dropped by the program, the whole
 438             buffer will be properly flushed.
 439
 440             There's one case where this delayed up-date of the buffer
 441             position can go wrong: if a thread is killed, it might be
 442             in the middle of filling up a buffer, with the result that
 443             the partial buffer update is lost upon finalisation. Not
 444             that killing of threads is supported at the moment.
 445
 446           -}
 447           setBufWPtr obj n
 448
 449       (x:xs) -> do
 450         primWriteCharOffAddr buf n x
 451           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
 452         if n == bufLen || x == '\n'
 453          then do
 454            rc <-  mayBlock obj (writeFileObject obj (n + 1))  -- ConcHask: UNSAFE, may block.
 455            if rc == 0
 456             then shoveString 0 xs
 457             else constructErrorAndFail "writeLines"
 458          else
 459            shoveString (n + 1) xs
 460   in
 461   shoveString initPos s
 462 #else /* ndef __HUGS__ */
 463 #ifndef __PARALLEL_HASKELL__
 464 writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 465 #else
 466 writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
 467 #endif
 468 writeLines obj buf (I# bufLen) (I# initPos#) s =
 469   let
 470    write_char :: Addr -> Int# -> Char# -> IO ()
 471    write_char (A# buf#) n# c# =
 472       IO $ \ s# ->
 473       case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 474
 475    shoveString :: Int# -> [Char] -> IO ()
 476    shoveString n ls =
 477      case ls of
 478       [] ->
 479         if n ==# 0# then
 480           setBufWPtr obj 0
 481         else do
 482           {-
 483             At the end of a buffer write, update the buffer position
 484             in the underlying file object, so that if the handle
 485             is subsequently dropped by the program, the whole
 486             buffer will be properly flushed.
 487
 488             There's one case where this delayed up-date of the buffer
 489             position can go wrong: if a thread is killed, it might be
 490             in the middle of filling up a buffer, with the result that
 491             the partial buffer update is lost upon finalisation. Not
 492             that killing of threads is supported at the moment.
 493
 494           -}
 495           setBufWPtr obj (I# n)
 496
 497       ((C# x):xs) -> do
 498         write_char buf n x
 499           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
 500         if n ==# bufLen || x `eqChar#` '\n'#
 501          then do
 502            rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))  -- ConcHask: UNSAFE, may block.
 503            if rc == 0
 504             then shoveString 0# xs
 505             else constructErrorAndFail "writeLines"
 506          else
 507            shoveString (n +# 1#) xs
 508   in
 509   shoveString initPos# s
 510 #endif /* ndef __HUGS__ */
 511
 512 #ifdef __HUGS__
 513 #ifndef __PARALLEL_HASKELL__
 514 writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 515 #else
 516 writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
 517 #endif
 518 writeBlocks obj buf bufLen initPos s =
 519   let
 520    shoveString :: Int -> [Char] -> IO ()
 521    shoveString n ls =
 522      case ls of
 523       [] ->
 524         if n == 0 then
 525           setBufWPtr obj (0::Int)
 526         else do
 527           {-
 528             At the end of a buffer write, update the buffer position
 529             in the underlying file object, so that if the handle
 530             is subsequently dropped by the program, the whole
 531             buffer will be properly flushed.
 532
 533             There's one case where this delayed up-date of the buffer
 534             position can go wrong: if a thread is killed, it might be
 535             in the middle of filling up a buffer, with the result that
 536             the partial buffer update is lost upon finalisation. However,
 537             by the time killThread is supported, Haskell finalisers are also
 538             likely to be in, which means the 'IOFileObject' hack can go
 539             alltogether.
 540
 541           -}
 542           setBufWPtr obj n
 543
 544       (x:xs) -> do
 545         primWriteCharOffAddr buf n x
 546         if n == bufLen
 547          then do
 548            rc <-  mayBlock obj (writeFileObject obj (n + 1))   -- ConcHask: UNSAFE, may block.
 549            if rc == 0
 550             then shoveString 0 xs
 551             else constructErrorAndFail "writeChunks"
 552          else
 553            shoveString (n + 1) xs
 554   in
 555   shoveString initPos s
 556 #else /* ndef __HUGS__ */
 557 #ifndef __PARALLEL_HASKELL__
 558 writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
 559 #else
 560 writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
 561 #endif
 562 writeBlocks obj buf (I# bufLen) (I# initPos#) s =
 563   let
 564    write_char :: Addr -> Int# -> Char# -> IO ()
 565    write_char (A# buf#) n# c# =
 566       IO $ \ s# ->
 567       case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 568
 569    shoveString :: Int# -> [Char] -> IO ()
 570    shoveString n ls =
 571      case ls of
 572       [] ->
 573         if n ==# 0# then
 574           setBufWPtr obj (0::Int)
 575         else do
 576           {-
 577             At the end of a buffer write, update the buffer position
 578             in the underlying file object, so that if the handle
 579             is subsequently dropped by the program, the whole
 580             buffer will be properly flushed.
 581
 582             There's one case where this delayed up-date of the buffer
 583             position can go wrong: if a thread is killed, it might be
 584             in the middle of filling up a buffer, with the result that
 585             the partial buffer update is lost upon finalisation. However,
 586             by the time killThread is supported, Haskell finalisers are also
 587             likely to be in, which means the 'IOFileObject' hack can go
 588             alltogether.
 589
 590           -}
 591           setBufWPtr obj (I# n)
 592
 593       ((C# x):xs) -> do
 594         write_char buf n x
 595         if n ==# bufLen
 596          then do
 597            rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))   -- ConcHask: UNSAFE, may block.
 598            if rc == 0
 599             then shoveString 0# xs
 600             else constructErrorAndFail "writeChunks"
 601          else
 602            shoveString (n +# 1#) xs
 603   in
 604   shoveString initPos# s
 605 #endif /* ndef __HUGS__ */
 606
 607 #ifndef __PARALLEL_HASKELL__
 608 writeChars :: ForeignObj -> String -> IO ()
 609 #else
 610 writeChars :: Addr -> String -> IO ()
 611 #endif
 612 writeChars _fo ""    = return ()
 613 writeChars fo (c:cs) = do
 614   rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
 615   if rc == 0
 616    then writeChars fo cs
 617    else constructErrorAndFail "writeChars"
 618
 619 \end{code}
 620
 621 Computation @hPrint hdl t@ writes the string representation of {\em t}
 622 given by the @shows@ function to the file or channel managed by {\em
 623 hdl}.
 624
 625 [ Seem to have disappeared from the 1.4 interface  - SOF 2/97 ]
 626
 627 \begin{code}
 628 hPrint :: Show a => Handle -> a -> IO ()
 629 hPrint hdl = hPutStrLn hdl . show
 630 \end{code}
 631
 632 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
 633 the handle \tr{hdl}, adding a newline at the end.
 634
 635 \begin{code}
 636 hPutStrLn :: Handle -> String -> IO ()
 637 hPutStrLn hndl str = do
 638  hPutStr  hndl str
 639  hPutChar hndl '\n'
 640
 641 \end{code}
 642
 643
 644 %*********************************************************
 645 %*                                                      *
 646 \subsection{Try and bracket}
 647 %*                                                      *
 648 %*********************************************************
 649
 650 The construct @try comp@ exposes errors which occur within a
 651 computation, and which are not fully handled.  It always succeeds.
 652
 653 \begin{code}
 654 try            :: IO a -> IO (Either IOError a)
 655 try f          =  catch (do r <- f
 656                             return (Right r))
 657                         (return . Left)
 658
 659 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 660 bracket before after m = do
 661         x  <- before
 662         rs <- try (m x)
 663         after x
 664         case rs of
 665            Right r -> return r
 666            Left  e -> ioError e
 667
 668 -- variant of the above where middle computation doesn't want x
 669 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 670 bracket_ before after m = do
 671          x  <- before
 672          rs <- try m
 673          after x
 674          case rs of
 675             Right r -> return r
 676             Left  e -> ioError e
 677 \end{code}
 678
 679 %*********************************************************
 680 %*                                                       *
 681 \subsection{Standard IO}
 682 %*                                                       *
 683 %*********************************************************
 684
 685 The Prelude has from Day 1 provided a collection of common
 686 IO functions. We define these here, but let the Prelude
 687 export them.
 688
 689 \begin{code}
 690 putChar         :: Char -> IO ()
 691 putChar c       =  hPutChar stdout c
 692
 693 putStr          :: String -> IO ()
 694 putStr s        =  hPutStr stdout s
 695
 696 putStrLn        :: String -> IO ()
 697 putStrLn s      =  do putStr s
 698                       putChar '\n'
 699
 700 print           :: Show a => a -> IO ()
 701 print x         =  putStrLn (show x)
 702
 703 getChar         :: IO Char
 704 getChar         =  hGetChar stdin
 705
 706 getLine         :: IO String
 707 getLine         =  hGetLine stdin
 708
 709 getContents     :: IO String
 710 getContents     =  hGetContents stdin
 711
 712 interact        ::  (String -> String) -> IO ()
 713 interact f      =   do s <- getContents
 714                        putStr (f s)
 715
 716 readFile        :: FilePath -> IO String
 717 readFile name   =  openFile name ReadMode >>= hGetContents
 718
 719 writeFile       :: FilePath -> String -> IO ()
 720 writeFile name str = do
 721     hdl <- openFile name WriteMode
 722     hPutStr hdl str
 723     hClose hdl
 724
 725 appendFile      :: FilePath -> String -> IO ()
 726 appendFile name str = do
 727     hdl <- openFile name AppendMode
 728     hPutStr hdl str
 729     hClose hdl
 730
 731 readLn          :: Read a => IO a
 732 readLn          =  do l <- getLine
 733                       r <- readIO l
 734                       return r
 735
 736
 737 \end{code}
 738
 739 #else /* __HUGS__ */
 740
 741 \begin{code}
 742 import Ix(Ix)
 743
 744 unimp :: String -> a
 745 unimp s = error ("IO library: function not implemented: " ++ s)
 746
 747 type FILE_STAR = Addr
 748 type Ptr       = Addr
 749 nULL           = nullAddr
 750
 751 data Handle
 752    = Handle { name     :: FilePath,
 753               file     :: FILE_STAR,         -- C handle
 754               mut      :: IORef Handle_Mut,  -- open/closed/semiclosed
 755               mode     :: IOMode,
 756               seekable :: Bool
 757             }
 758
 759 data Handle_Mut
 760    = Handle_Mut { state :: HState
 761                 }
 762
 763 set_state :: Handle -> HState -> IO ()
 764 set_state hdl new_state
 765    = writeIORef (mut hdl) (Handle_Mut { state = new_state })
 766 get_state :: Handle -> IO HState
 767 get_state hdl
 768    = readIORef (mut hdl) >>= \m -> return (state m)
 769
 770 mkErr :: Handle -> String -> IO a
 771 mkErr h msg
 772    = do nh_close (file h)
 773         dummy <- nh_errno
 774         ioError (IOError msg)
 775
 776 stdin
 777    = Handle {
 778         name = "stdin",
 779         file = primRunST nh_stdin,
 780         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 781         mode = ReadMode
 782      }
 783
 784 stdout
 785    = Handle {
 786         name = "stdout",
 787         file = primRunST nh_stdout,
 788         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 789         mode = WriteMode
 790      }
 791
 792 stderr
 793    = Handle {
 794         name = "stderr",
 795         file = primRunST nh_stderr,
 796         mut  = primRunST (newIORef (Handle_Mut { state = HOpen })),
 797         mode = WriteMode
 798      }
 799
 800
 801 instance Eq Handle where
 802    h1 == h2   = file h1 == file h2
 803
 804 instance Show Handle where
 805    showsPrec _ h = showString ("<<" ++ name h ++ ">>")
 806
 807 data HandlePosn
 808    = HandlePosn
 809      deriving (Eq, Show)
 810
 811
 812 data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
 813                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 814
 815 data BufferMode  =  NoBuffering | LineBuffering
 816                  |  BlockBuffering
 817                     deriving (Eq, Ord, Read, Show)
 818
 819 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 820                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 821
 822 data HState = HOpen | HSemiClosed | HClosed
 823               deriving Eq
 824
 825 openFile :: FilePath -> IOMode -> IO Handle
 826 openFile f mode
 827    = copy_String_to_cstring f >>= \nameptr ->
 828      nh_open nameptr (mode2num mode) >>= \fh ->
 829      nh_free nameptr >>
 830      if   fh == nULL
 831      then (ioError.IOError)
 832              ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
 833      else do r <- newIORef (Handle_Mut { state = HOpen })
 834              return (Handle {
 835                         name = f,
 836                         file = fh,
 837                         mut  = r,
 838                         mode = mode
 839                      })
 840      where
 841         mode2num :: IOMode -> Int
 842         mode2num ReadMode   = 0
 843         mode2num WriteMode  = 1
 844         mode2num AppendMode = 2
 845         mode2num ReadWriteMode
 846            = error
 847                 ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")
 848
 849 hClose :: Handle -> IO ()
 850 hClose h
 851    = do mut <- readIORef (mut h)
 852         if    state mut == HClosed
 853          then mkErr h
 854                  ("hClose on closed handle " ++ show h)
 855          else
 856          do set_state h HClosed
 857             nh_close (file h)
 858             err <- nh_errno
 859             if    err == 0
 860              then return ()
 861              else mkErr h
 862                      ("hClose: error closing " ++ name h)
 863
 864 hGetContents :: Handle -> IO String
 865 hGetContents h
 866    | mode h /= ReadMode
 867    = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
 868    | otherwise
 869    = do mut <- readIORef (mut h)
 870         if    state mut /= HOpen
 871          then mkErr h
 872                  ("hGetContents on closed/semiclosed handle " ++ show h)
 873          else
 874          do set_state h HSemiClosed
 875             read_all (file h)
 876             where
 877                read_all f
 878                   = nh_read f >>= \ci ->
 879                     if   ci == -1
 880                     then return []
 881                     else read_all f >>= \rest ->
 882                          return ((primIntToChar ci):rest)
 883
 884 hPutStr :: Handle -> String -> IO ()
 885 hPutStr h s
 886    | mode h == ReadMode
 887    = mkErr h ("hPutStr on ReadMode handle " ++ show h)
 888    | otherwise
 889    = do mut <- readIORef (mut h)
 890         if    state mut /= HOpen
 891          then mkErr h
 892                  ("hPutStr on closed/semiclosed handle " ++ show h)
 893          else write_all (file h) s
 894               where
 895                  write_all f []
 896                     = return ()
 897                  write_all f (c:cs)
 898                     = nh_write f c >> write_all f cs
 899
 900 hFileSize :: Handle -> IO Integer
 901 hFileSize h
 902    = do sz <- nh_filesize (file h)
 903         er <- nh_errno
 904         if    er == 0
 905          then return (fromIntegral sz)
 906          else mkErr h ("hFileSize on " ++ show h)
 907
 908 hIsEOF :: Handle -> IO Bool
 909 hIsEOF h
 910    = do iseof <- nh_iseof (file h)
 911         er    <- nh_errno
 912         if    er == 0
 913          then return (iseof /= 0)
 914          else mkErr h ("hIsEOF on " ++ show h)
 915
 916 isEOF :: IO Bool
 917 isEOF = hIsEOF stdin
 918
 919 hSetBuffering         :: Handle  -> BufferMode -> IO ()
 920 hSetBuffering          = unimp "IO.hSetBuffering"
 921 hGetBuffering         :: Handle  -> IO BufferMode
 922 hGetBuffering          = unimp "IO.hGetBuffering"
 923
 924 hFlush :: Handle -> IO ()
 925 hFlush h
 926    = do mut <- readIORef (mut h)
 927         if    state mut /= HOpen
 928          then mkErr h
 929                  ("hFlush on closed/semiclosed file " ++ name h)
 930          else nh_flush (file h)
 931
 932 hGetPosn              :: Handle -> IO HandlePosn
 933 hGetPosn               = unimp "IO.hGetPosn"
 934 hSetPosn              :: HandlePosn -> IO ()
 935 hSetPosn               = unimp "IO.hSetPosn"
 936 hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
 937 hSeek                  = unimp "IO.hSeek"
 938 hWaitForInput         :: Handle -> Int -> IO Bool
 939 hWaitForInput          = unimp "hWaitForInput"
 940 hReady                :: Handle -> IO Bool
 941 hReady h               = unimp "hReady" -- hWaitForInput h 0
 942
 943 hGetChar    :: Handle -> IO Char
 944 hGetChar h
 945    = nh_read (file h) >>= \ci ->
 946      return (primIntToChar ci)
 947
 948 hGetLine              :: Handle -> IO String
 949 hGetLine h             = do c <- hGetChar h
 950                             if c=='\n' then return ""
 951                               else do cs <- hGetLine h
 952                                       return (c:cs)
 953
 954 hLookAhead            :: Handle -> IO Char
 955 hLookAhead             = unimp "IO.hLookAhead"
 956
 957
 958 hPutChar              :: Handle -> Char -> IO ()
 959 hPutChar h c           = hPutStr h [c]
 960
 961 hPutStrLn             :: Handle -> String -> IO ()
 962 hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
 963
 964 hPrint                :: Show a => Handle -> a -> IO ()
 965 hPrint h               = hPutStrLn h . show
 966
 967 hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
 968 hIsOpen h              = do { s <- get_state h; return (s == HOpen) }
 969 hIsClosed h            = do { s <- get_state h; return (s == HClosed) }
 970 hIsReadable h          = return (mode h == ReadMode)
 971 hIsWritable h          = return (mode h `elem` [WriteMode, AppendMode])
 972
 973 hIsSeekable           :: Handle -> IO Bool
 974 hIsSeekable            = unimp "IO.hIsSeekable"
 975
 976 isIllegalOperation,
 977           isAlreadyExistsError,
 978           isDoesNotExistError,
 979           isAlreadyInUseError,
 980           isFullError,
 981           isEOFError,
 982           isPermissionError,
 983           isUserError        :: IOError -> Bool
 984
 985 isIllegalOperation    = unimp "IO.isIllegalOperation"
 986 isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
 987 isDoesNotExistError   = unimp "IO.isDoesNotExistError"
 988 isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
 989 isFullError           = unimp "IO.isFullError"
 990 isEOFError            = unimp "IO.isEOFError"
 991 isPermissionError     = unimp "IO.isPermissionError"
 992 isUserError           = unimp "IO.isUserError"
 993
 994
 995 ioeGetErrorString :: IOError -> String
 996 ioeGetErrorString = unimp "IO.ioeGetErrorString"
 997 ioeGetHandle      :: IOError -> Maybe Handle
 998 ioeGetHandle      = unimp "IO.ioeGetHandle"
 999 ioeGetFileName    :: IOError -> Maybe FilePath
1000 ioeGetFileName    = unimp "IO.ioeGetFileName"
1001
1002 try       :: IO a -> IO (Either IOError a)
1003 try p      = catch (p >>= (return . Right)) (return . Left)
1004
1005 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
1006 bracket before after m = do
1007         x  <- before
1008         rs <- try (m x)
1009         after x
1010         case rs of
1011            Right r -> return r
1012            Left  e -> ioError e
1013
1014 -- variant of the above where middle computation doesn't want x
1015 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
1016 bracket_ before after m = do
1017          x  <- before
1018          rs <- try m
1019          after x
1020          case rs of
1021             Right r -> return r
1022             Left  e -> ioError e
1023 -- TODO: Hugs/slurpFile
1024 slurpFile = unimp "IO.slurpFile"
1025 \end{code}
1026
1027 #endif /* #ifndef __HUGS__ */