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
 740 \begin{code}
 741 unimp :: String -> a
 742 unimp s = error ("function not implemented: " ++ s)
 743
 744 type FILE_STAR = Int
 745 type Ptr       = Int
 746 nULL = 0 :: Int
 747
 748 data Handle
 749    = Handle { name     :: FilePath,
 750               file     :: FILE_STAR,    -- C handle
 751               state    :: HState,       -- open/closed/semiclosed
 752               mode     :: IOMode,
 753               --seekable :: Bool,
 754               bmode    :: BufferMode,
 755               buff     :: Ptr,
 756               buffSize :: Int
 757             }
 758
 759 instance Eq Handle where
 760    h1 == h2   = file h1 == file h2
 761
 762 instance Show Handle where
 763    showsPrec _ h = showString ("<<handle " ++ name h ++ "=" ++ show (file h) ++ ">>")
 764
 765 data HandlePosn
 766    = HandlePosn
 767      deriving (Eq, Show)
 768
 769
 770 data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
 771                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 772
 773 data BufferMode  =  NoBuffering | LineBuffering
 774                  |  BlockBuffering
 775                     deriving (Eq, Ord, Read, Show)
 776
 777 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 778                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 779
 780 data HState = HOpen | HSemiClosed | HClosed
 781               deriving Eq
 782
 783 stdin  = Handle "stdin"  (primRunST nh_stdin)  HOpen ReadMode  NoBuffering   nULL 0
 784 stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0
 785 stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering   nULL 0
 786
 787 openFile :: FilePath -> IOMode -> IO Handle
 788 openFile f mode
 789    = copy_String_to_cstring f >>= \nameptr ->
 790      nh_open nameptr (mode2num mode) >>= \fh ->
 791      nh_free nameptr >>
 792      if   fh == nULL
 793      then (ioError.IOError) ("openFile: can't open " ++ f ++ " in " ++ show mode)
 794      else return (Handle f fh HOpen mode BlockBuffering nULL 0)
 795      where
 796         mode2num :: IOMode -> Int
 797         mode2num ReadMode   = 0
 798         mode2num WriteMode  = 1
 799         mode2num AppendMode = 2
 800
 801 hClose :: Handle -> IO ()
 802 hClose h
 803    | not (state h == HOpen)
 804    = (ioError.IOError) ("hClose on non-open handle " ++ show h)
 805    | otherwise
 806    = nh_close (file h) >>
 807      nh_errno >>= \err ->
 808      if   err == 0
 809      then return ()
 810      else (ioError.IOError) ("hClose: error closing " ++ name h)
 811
 812 hFileSize             :: Handle -> IO Integer
 813 hFileSize              = unimp "IO.hFileSize"
 814 hIsEOF                :: Handle -> IO Bool
 815 hIsEOF                 = unimp "IO.hIsEOF"
 816 isEOF                 :: IO Bool
 817 isEOF                  = hIsEOF stdin
 818
 819 hSetBuffering         :: Handle  -> BufferMode -> IO ()
 820 hSetBuffering          = unimp "IO.hSetBuffering"
 821 hGetBuffering         :: Handle  -> IO BufferMode
 822 hGetBuffering          = unimp "IO.hGetBuffering"
 823
 824 hFlush :: Handle -> IO ()
 825 hFlush h
 826    = if   state h /= HOpen
 827      then (ioError.IOError) ("hFlush on closed/semiclosed file " ++ name h)
 828      else nh_flush (file h)
 829
 830 hGetPosn              :: Handle -> IO HandlePosn
 831 hGetPosn               = unimp "IO.hGetPosn"
 832 hSetPosn              :: HandlePosn -> IO ()
 833 hSetPosn               = unimp "IO.hSetPosn"
 834 hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
 835 hSeek                  = unimp "IO.hSeek"
 836 hWaitForInput         :: Handle -> Int -> IO Bool
 837 hWaitForInput          = unimp "hWaitForInput"
 838 hReady                :: Handle -> IO Bool
 839 hReady h               = hWaitForInput h 0
 840
 841 hGetChar    :: Handle -> IO Char
 842 hGetChar h
 843    = nh_read (file h) >>= \ci ->
 844      return (primIntToChar ci)
 845
 846 hGetLine              :: Handle -> IO String
 847 hGetLine h             = do c <- hGetChar h
 848                             if c=='\n' then return ""
 849                               else do cs <- hGetLine h
 850                                       return (c:cs)
 851
 852 hLookAhead            :: Handle -> IO Char
 853 hLookAhead             = unimp "IO.hLookAhead"
 854
 855 hGetContents :: Handle -> IO String
 856 hGetContents h
 857    | not (state h == HOpen && mode h == ReadMode)
 858    = (ioError.IOError) ("hGetContents on invalid handle " ++ show h)
 859    | otherwise
 860    = read_all (file h)
 861      where
 862         read_all f
 863            = unsafeInterleaveIO (
 864              nh_read f >>= \ci ->
 865              if   ci == -1
 866              then hClose h >> return []
 867              else read_all f >>= \rest ->
 868                   return ((primIntToChar ci):rest)
 869              )
 870
 871 hPutStr :: Handle -> String -> IO ()
 872 hPutStr h s
 873    | not (state h == HOpen && mode h /= ReadMode)
 874    = (ioError.IOError) ("hPutStr on invalid handle " ++ show h)
 875    | otherwise
 876    = write_all (file h) s
 877      where
 878         write_all f []
 879            = return ()
 880         write_all f (c:cs)
 881            = nh_write f (primCharToInt c) >>
 882              write_all f cs
 883
 884 hPutChar              :: Handle -> Char -> IO ()
 885 hPutChar h c           = hPutStr h [c]
 886
 887 hPutStrLn             :: Handle -> String -> IO ()
 888 hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
 889
 890 hPrint                :: Show a => Handle -> a -> IO ()
 891 hPrint h               = hPutStrLn h . show
 892
 893 hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
 894 hIsOpen h              = return (state h == HOpen)
 895 hIsClosed h            = return (state h == HClosed)
 896 hIsReadable h          = return (mode h == ReadMode)
 897 hIsWritable h          = return (mode h == WriteMode)
 898
 899 hIsSeekable           :: Handle -> IO Bool
 900 hIsSeekable            = unimp "IO.hIsSeekable"
 901
 902 isIllegalOperation,
 903           isAlreadyExistsError,
 904           isDoesNotExistError,
 905           isAlreadyInUseError,
 906           isFullError,
 907           isEOFError,
 908           isPermissionError,
 909           isUserError        :: IOError -> Bool
 910
 911 isIllegalOperation    = unimp "IO.isIllegalOperation"
 912 isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
 913 isDoesNotExistError   = unimp "IO.isDoesNotExistError"
 914 isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
 915 isFullError           = unimp "IO.isFullError"
 916 isEOFError            = unimp "IO.isEOFError"
 917 isPermissionError     = unimp "IO.isPermissionError"
 918 isUserError           = unimp "IO.isUserError"
 919
 920
 921 ioeGetErrorString :: IOError -> String
 922 ioeGetErrorString = unimp "ioeGetErrorString"
 923 ioeGetHandle      :: IOError -> Maybe Handle
 924 ioeGetHandle      = unimp "ioeGetHandle"
 925 ioeGetFileName    :: IOError -> Maybe FilePath
 926 ioeGetFileName    = unimp "ioeGetFileName"
 927
 928 try       :: IO a -> IO (Either IOError a)
 929 try p      = catch (p >>= (return . Right)) (return . Left)
 930
 931 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 932 bracket before after m = do
 933         x  <- before
 934         rs <- try (m x)
 935         after x
 936         case rs of
 937            Right r -> return r
 938            Left  e -> ioError e
 939
 940 -- variant of the above where middle computation doesn't want x
 941 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 942 bracket_ before after m = do
 943          x  <- before
 944          rs <- try m
 945          after x
 946          case rs of
 947             Right r -> return r
 948             Left  e -> ioError e
 949
 950 -- TODO: Hugs/slurbFile
 951 slurpFile = unimp "slurpFile"
 952 \end{code}
 953 #endif