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