IO.lhs 32.9 KB
Newer Older
1
%
sof's avatar
sof committed
2
% (c) The AQUA Project, Glasgow University, 1994-1998
3 4 5
%
\section[IO]{Module @IO@}

sof's avatar
sof committed
6 7 8 9
Implementation of the standard Haskell IO interface, see
@http://haskell.org/onlinelibrary/io.html@ for the official
definition.

10
\begin{code}
sof's avatar
sof committed
11
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
12

13
module IO (
sof's avatar
sof committed
14 15
    Handle,		-- abstract, instance of: Eq, Show.
    HandlePosn(..),     -- abstract, instance of: Eq, Show.
16

17 18 19
    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
    BufferMode(NoBuffering,LineBuffering,BlockBuffering),
    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
20

sof's avatar
sof committed
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
    stdin, stdout, stderr,   -- :: Handle

    openFile,		       -- :: FilePath -> IOMode -> IO Handle
    hClose,		       -- :: Handle -> IO ()
    hFileSize,		       -- :: Handle -> IO Integer
    hIsEOF,		       -- :: Handle -> IO Bool
    isEOF,		       -- :: IO Bool

    hSetBuffering,	       -- :: Handle -> BufferMode -> IO ()
    hGetBuffering,	       -- :: Handle -> IO BufferMode
    hFlush,		       -- :: Handle -> IO ()
    hGetPosn,		       -- :: Handle -> IO HandlePosn
    hSetPosn,		       -- :: Handle -> HandlePosn -> IO ()
    hSeek,		       -- :: Handle -> SeekMode -> Integer -> IO ()
    hWaitForInput,	       -- :: Handle -> Int -> IO Bool
    hReady,		       -- :: Handle -> IO Bool
    hGetChar,		       -- :: Handle -> IO Char
    hGetLine,		       -- :: Handle -> IO [Char]
    hLookAhead,		       -- :: Handle -> IO Char
    hGetContents,	       -- :: Handle -> IO [Char]
    hPutChar,		       -- :: Handle -> Char -> IO ()
    hPutStr,		       -- :: Handle -> [Char] -> IO ()
    hPutStrLn,		       -- :: Handle -> [Char] -> IO ()
    hPrint,		       -- :: Show a => Handle -> a -> IO ()
    hIsOpen, hIsClosed,        -- :: Handle -> IO Bool
    hIsReadable, hIsWritable,  -- :: Handle -> IO Bool
    hIsSeekable,               -- :: Handle -> IO Bool

    isAlreadyExistsError, isDoesNotExistError,  -- :: IOError -> Bool
    isAlreadyInUseError, isFullError, 
    isEOFError, isIllegalOperation, 
    isPermissionError, isUserError, 

    ioeGetErrorString,	       -- :: IOError -> String
    ioeGetHandle,	       -- :: IOError -> Maybe Handle
    ioeGetFileName,	       -- :: IOError -> Maybe FilePath

    try,		       -- :: IO a -> IO (Either IOError a)
    bracket,		       -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket_,		       -- :: IO a -> (a -> IO b) -> IO c -> IO c

sof's avatar
sof committed
62 63 64
    -- Non-standard extension (but will hopefully become standard with 1.5) is
    -- to export the Prelude io functions via IO (in addition to exporting them
    -- from the prelude...for now.) 
sof's avatar
sof committed
65 66 67 68 69 70 71 72
    IO,
    FilePath,		       -- :: String
    IOError,
    ioError,		       -- :: IOError -> IO a
    userError,		       -- :: String  -> IOError
    catch,		       -- :: IO a    -> (IOError -> IO a) -> IO a
    interact,		       -- :: (String -> String) -> IO ()

sof's avatar
sof committed
73 74 75 76 77 78 79 80 81 82 83 84 85
    putChar,		       -- :: Char   -> IO ()
    putStr,		       -- :: String -> IO () 
    putStrLn,		       -- :: String -> IO ()
    print,		       -- :: Show a => a -> IO ()
    getChar,		       -- :: IO Char
    getLine,		       -- :: IO String
    getContents,	       -- :: IO String
    readFile,		       -- :: FilePath -> IO String
    writeFile,		       -- :: FilePath -> String -> IO ()
    appendFile,		       -- :: FilePath -> String -> IO ()
    readIO,		       -- :: Read a => String -> IO a
    readLn,		       -- :: Read a => IO a

andy's avatar
andy committed
86
#ifndef __HUGS__
sof's avatar
sof committed
87 88 89
    -- extensions
    hPutBuf,
    hPutBufBA,
90
#endif
sof's avatar
sof committed
91 92
    slurpFile

93
  ) where
94

95
#ifdef __HUGS__
andy's avatar
andy committed
96
import Ix(Ix)
andy's avatar
andy committed
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
import Prelude
import privileged Prelude ( IORef
			  , unsafePerformIO
			  , prelCleanupAfterRunAction
			  , copy_String_to_cstring
			  , primIntToChar
			  , primWriteCharOffAddr
			  , nullAddr
			  , newIORef
			  , writeIORef
			  , readIORef
			  , nh_close
			  , nh_errno
			  , nh_stdin
			  , nh_stdout
			  , nh_stderr
			  , nh_flush
			  , nh_open
			  , nh_free
			  , nh_read
			  , nh_write
			  , nh_filesize
			  , nh_iseof
			  )
			

123 124
#else
--import PrelST
sof's avatar
sof committed
125 126
import PrelBase

127 128
import PrelIOBase
import PrelHandle		-- much of the real stuff is in here
sof's avatar
sof committed
129

sof's avatar
sof committed
130 131 132
import PrelRead         ( readParen, Read(..), reads, lex,
			  readIO 
			)
133
import PrelShow
134
import PrelMaybe	( Either(..), Maybe(..) )
sof's avatar
sof committed
135
import PrelAddr		( Addr(..), nullAddr )
136
import PrelByteArr	( ByteArray )
sof's avatar
sof committed
137
import PrelPack		( unpackNBytesAccST )
sof's avatar
sof committed
138
import PrelException    ( ioError, catch )
139
import PrelConc
140

sof's avatar
sof committed
141
#ifndef __PARALLEL_HASKELL__
sof's avatar
sof committed
142
import PrelForeign  ( ForeignObj )
sof's avatar
sof committed
143 144
#endif

sof's avatar
sof committed
145
import Char		( ord, chr )
146

147
#endif /* ndef __HUGS__ */
148 149
\end{code}

andy's avatar
andy committed
150
#ifndef __HUGS__
151 152 153 154 155 156
%*********************************************************
%*							*
\subsection{Simple input operations}
%*							*
%*********************************************************

sof's avatar
sof committed
157
Computation @hReady hdl@ indicates whether at least
158 159
one item is available for input from handle {\em hdl}.

sof's avatar
sof committed
160
@hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
sof's avatar
sof committed
161 162
before deciding whether the Handle has run dry or not.

sof's avatar
sof committed
163 164 165 166 167
If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
If not, it tries to read from the underlying OS handle. Notice that
for buffered Handles connected to terminals this means waiting until a complete
line is available.

168
\begin{code}
sof's avatar
sof committed
169
hReady :: Handle -> IO Bool
sof's avatar
sof committed
170 171
hReady h = hWaitForInput h 0

sof's avatar
sof committed
172
hWaitForInput :: Handle -> Int -> IO Bool 
173 174
hWaitForInput handle msecs =
    wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
sof's avatar
sof committed
175
    rc       <- inputReady (haFO__ handle_) (msecs::Int)     -- ConcHask: SAFE, won't block
sof's avatar
sof committed
176
    case (rc::Int) of
sof's avatar
sof committed
177 178 179
      0 -> return False
      1 -> return True
      _ -> constructErrorAndFail "hWaitForInput"
180
\end{code}
181

sof's avatar
sof committed
182 183
@hGetChar hdl@ reads the next character from handle @hdl@,
blocking until a character is available.
184

185
\begin{code}
sof's avatar
sof committed
186
hGetChar :: Handle -> IO Char
187 188 189
hGetChar handle = do
  c <- mayBlockRead "hGetChar" handle fileGetc
  return (chr c)
sof's avatar
sof committed
190

sof's avatar
sof committed
191 192 193 194 195
{-
  If EOF is reached before EOL is encountered, ignore the
  EOF and return the partial line. Next attempt at calling
  hGetLine on the handle will yield an EOF IO exception though.
-}
sof's avatar
sof committed
196
hGetLine :: Handle -> IO String
sof's avatar
sof committed
197
hGetLine h = do
sof's avatar
sof committed
198
  c <- hGetChar h
sof's avatar
sof committed
199 200
  if c == '\n' then
     return ""
sof's avatar
sof committed
201
   else do
sof's avatar
sof committed
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
    l <- getRest
    return (c:l)
 where
  getRest = do
    c <- 
      catch 
        (hGetChar h)
        (\ err -> do
          if isEOFError err then
	     return '\n'
	   else
	     ioError err)
    if c == '\n' then
       return ""
     else do
       s <- getRest
       return (c:s)
sof's avatar
sof committed
219

220
\end{code}
221

sof's avatar
sof committed
222 223
@hLookahead hdl@ returns the next character from handle @hdl@
without removing it from the input buffer, blocking until a
224
character is available.
225

226
\begin{code}
sof's avatar
sof committed
227
hLookAhead :: Handle -> IO Char
228 229 230
hLookAhead handle = do
  rc <- mayBlockRead "hLookAhead" handle fileLookAhead
  return (chr rc)
231 232 233 234 235 236 237 238
\end{code}


%*********************************************************
%*							*
\subsection{Getting the entire contents of a handle}
%*							*
%*********************************************************
239

sof's avatar
sof committed
240 241 242
@hGetContents hdl@ returns the list of characters corresponding
to the unread portion of the channel or file managed by @hdl@,
which is made semi-closed.
243

244
\begin{code}
sof's avatar
sof committed
245
hGetContents :: Handle -> IO String
246
hGetContents handle = 
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276
	-- can't use wantReadableHandle here, because we want to side effect
	-- the handle.
    withHandle handle $ \ handle_ -> do
    case haType__ handle_ of 
      ErrorHandle theError -> ioError theError
      ClosedHandle 	   -> ioe_closedHandle "hGetContents" handle
      SemiClosedHandle 	   -> ioe_closedHandle "hGetContents" handle
      AppendHandle 	   -> ioError not_readable_error
      WriteHandle 	   -> ioError not_readable_error
      _ -> do
    	  {- 
    	    To avoid introducing an extra layer of buffering here,
    	    we provide three lazy read methods, based on character,
    	    line, and block buffering.
    	  -}
   	let handle_' = handle_{ haType__ = SemiClosedHandle }
    	case (haBufferMode__ handle_) of
    	 LineBuffering    -> do
    	    str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
    	    return (handle_', str)
    	 BlockBuffering _ -> do
    	    str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
    	    return (handle_', str)
    	 NoBuffering      -> do
    	    str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
    	    return (handle_', str)
  where
   not_readable_error = 
	   IOError (Just handle) IllegalOperation "hGetContents"
		   ("handle is not open for reading")
277
\end{code}
278

sof's avatar
sof committed
279 280 281
Note that someone may close the semi-closed handle (or change its buffering), 
so each these lazy read functions are pulled on, they have to check whether
the handle has indeed been closed.
282

283
\begin{code}
sof's avatar
sof committed
284
#ifndef __PARALLEL_HASKELL__
sof's avatar
sof committed
285 286 287
lazyReadBlock :: Handle -> ForeignObj -> IO String
lazyReadLine  :: Handle -> ForeignObj -> IO String
lazyReadChar  :: Handle -> ForeignObj -> IO String
288
#else
sof's avatar
sof committed
289 290 291
lazyReadBlock :: Handle -> Addr -> IO String
lazyReadLine  :: Handle -> Addr -> IO String
lazyReadChar  :: Handle -> Addr -> IO String
292
#endif
sof's avatar
sof committed
293 294

lazyReadBlock handle fo = do
sof's avatar
sof committed
295 296
   buf   <- getBufStart fo 0
   bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
297
   case (bytes::Int) of
sof's avatar
sof committed
298 299 300
     -3 -> -- buffering has been turned off, use lazyReadChar instead
           lazyReadChar handle fo
     -2 -> return ""
301 302
     -1 -> -- an error occurred, close the handle
	  withHandle handle $ \ handle_ -> do
sof's avatar
sof committed
303
          closeFile (haFO__ handle_) 0{-don't bother flushing-}  -- ConcHask: SAFE, won't block.
304 305 306
	  return (handle_ { haType__    = ClosedHandle,
			    haFO__      = nullFile__ }, 
		  "")
sof's avatar
sof committed
307 308 309 310 311
     _ -> do
      more <- unsafeInterleaveIO (lazyReadBlock handle fo)
      stToIO (unpackNBytesAccST buf bytes more)

lazyReadLine handle fo = do
sof's avatar
sof committed
312
     bytes <- mayBlock fo (readLine fo)   -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
313
     case (bytes::Int) of
sof's avatar
sof committed
314 315 316
       -3 -> -- buffering has been turned off, use lazyReadChar instead
             lazyReadChar handle fo
       -2 -> return "" -- handle closed by someone else, stop reading.
317 318
       -1 -> -- an error occurred, close the handle
  	     withHandle handle $ \ handle_ -> do
sof's avatar
sof committed
319
             closeFile (haFO__ handle_) 0{- don't bother flushing-}  -- ConcHask: SAFE, won't block
320 321 322
	     return (handle_ { haType__    = ClosedHandle,
			       haFO__      = nullFile__ },
		     "")
sof's avatar
sof committed
323 324
       _ -> do
          more <- unsafeInterleaveIO (lazyReadLine handle fo)
sof's avatar
sof committed
325
          buf  <- getBufStart fo bytes  -- ConcHask: won't block
sof's avatar
sof committed
326 327 328
	  stToIO (unpackNBytesAccST buf bytes more)

lazyReadChar handle fo = do
sof's avatar
sof committed
329
    char <- mayBlock fo (readChar fo)   -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
330
    case (char::Int) of
sof's avatar
sof committed
331 332 333 334 335 336
      -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
	    lazyReadBlock handle fo
	    
      -3 -> -- buffering is now line-buffered, use lazyReadLine instead
	    lazyReadLine handle fo
      -2 -> return ""
337 338
      -1 -> -- error, silently close handle.
 	 withHandle handle $ \ handle_ -> do
sof's avatar
sof committed
339
         closeFile (haFO__ handle_) 0{-don't bother flusing-}  -- ConcHask: SAFE, won't block
340 341 342
	 return (handle_{ haType__  = ClosedHandle,
			  haFO__    = nullFile__ },
		 "")
sof's avatar
sof committed
343 344 345
      _ -> do
	 more <- unsafeInterleaveIO (lazyReadChar handle fo)
         return (chr char : more)
346

347 348 349 350 351 352 353 354
\end{code}


%*********************************************************
%*							*
\subsection{Simple output functions}
%*							*
%*********************************************************
355

sof's avatar
sof committed
356 357 358
@hPutChar hdl ch@ writes the character @ch@ to the file
or channel managed by @hdl@.  Characters may be buffered if
buffering is enabled for @hdl@
359

360
\begin{code}
sof's avatar
sof committed
361
hPutChar :: Handle -> Char -> IO ()
362 363
hPutChar handle c = 
    wantWriteableHandle "hPutChar" handle $ \ handle_  -> do
sof's avatar
sof committed
364
    let fo = haFO__ handle_
sof's avatar
sof committed
365
    flushConnectedBuf fo
sof's avatar
sof committed
366
    rc       <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
367 368 369
    if rc == 0
     then return ()
     else constructErrorAndFail "hPutChar"
sof's avatar
sof committed
370

371
\end{code}
372

sof's avatar
sof committed
373 374
@hPutStr hdl s@ writes the string @s@ to the file or
channel managed by @hdl@, buffering the output if needs be.
375

376
\begin{code}
sof's avatar
sof committed
377
hPutStr :: Handle -> String -> IO ()
378 379
hPutStr handle str = 
    wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
sof's avatar
sof committed
380
    let fo = haFO__ handle_
sof's avatar
sof committed
381
    flushConnectedBuf fo
sof's avatar
sof committed
382 383
    case haBufferMode__ handle_ of
       LineBuffering -> do
sof's avatar
sof committed
384 385 386
	    buf <- getWriteableBuf fo
	    pos <- getBufWPtr fo
	    bsz <- getBufSize fo
sof's avatar
sof committed
387 388
	    writeLines fo buf bsz pos str
       BlockBuffering _ -> do
sof's avatar
sof committed
389 390 391
	    buf <- getWriteableBuf fo
	    pos <- getBufWPtr fo
	    bsz <- getBufSize fo
sof's avatar
sof committed
392 393 394 395 396 397 398 399 400 401
            writeBlocks fo buf bsz pos str
       NoBuffering -> do
	    writeChars fo str
\end{code}

Going across the border between Haskell and C is relatively costly,
so for block writes we pack the character strings on the Haskell-side
before passing the external write routine a pointer to the buffer.

\begin{code}
402 403 404 405 406 407
#ifdef __HUGS__

#ifdef __CONCURRENT_HASKELL__
/* See comment in shoveString below for explanation */
#warning delayed update of buffer disnae work with killThread
#endif
408

409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
#ifndef __PARALLEL_HASKELL__
writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
#endif
writeLines obj buf bufLen initPos s =
  let
   shoveString :: Int -> [Char] -> IO ()
   shoveString n ls = 
     case ls of
      [] ->   
	  {-
	    At the end of a buffer write, update the buffer position
	    in the underlying file object, so that if the handle
	    is subsequently dropped by the program, the whole
	    buffer will be properly flushed.

	    There's one case where this delayed up-date of the buffer
	    position can go wrong: if a thread is killed, it might be
	    in the middle of filling up a buffer, with the result that
	    the partial buffer update is lost upon finalisation. Not
	    that killing of threads is supported at the moment.

	  -}
sof's avatar
sof committed
433
	  setBufWPtr obj n
434 435 436 437 438 439

      (x:xs) -> do
        primWriteCharOffAddr buf n x
          {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
	if n == bufLen || x == '\n'
	 then do
sof's avatar
sof committed
440
	   rc <-  mayBlock obj (writeFileObject obj (n + 1))  -- ConcHask: UNSAFE, may block.
441 442 443 444 445 446 447 448
	   if rc == 0 
	    then shoveString 0 xs
	    else constructErrorAndFail "writeLines"
         else
	   shoveString (n + 1) xs
  in
  shoveString initPos s
#else /* ndef __HUGS__ */
sof's avatar
sof committed
449
#ifndef __PARALLEL_HASKELL__
sof's avatar
sof committed
450
writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
451
#else
sof's avatar
sof committed
452
writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
453
#endif
sof's avatar
sof committed
454
writeLines obj buf (I# bufLen) (I# initPos#) s =
sof's avatar
sof committed
455 456
  let
   write_char :: Addr -> Int# -> Char# -> IO ()
sof's avatar
sof committed
457
   write_char (A# buf#) n# c# =
sof's avatar
sof committed
458
      IO $ \ s# ->
sof's avatar
sof committed
459
      case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
sof's avatar
sof committed
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477

   shoveString :: Int# -> [Char] -> IO ()
   shoveString n ls = 
     case ls of
      [] ->   
	  {-
	    At the end of a buffer write, update the buffer position
	    in the underlying file object, so that if the handle
	    is subsequently dropped by the program, the whole
	    buffer will be properly flushed.

	    There's one case where this delayed up-date of the buffer
	    position can go wrong: if a thread is killed, it might be
	    in the middle of filling up a buffer, with the result that
	    the partial buffer update is lost upon finalisation. Not
	    that killing of threads is supported at the moment.

	  -}
sof's avatar
sof committed
478
	  setBufWPtr obj (I# n)
sof's avatar
sof committed
479 480 481 482 483 484

      ((C# x):xs) -> do
        write_char buf n x
          {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
	if n ==# bufLen || x `eqChar#` '\n'#
	 then do
sof's avatar
sof committed
485
	   rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))  -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
486 487 488 489 490 491 492
	   if rc == 0 
	    then shoveString 0# xs
	    else constructErrorAndFail "writeLines"
         else
	   shoveString (n +# 1#) xs
  in
  shoveString initPos# s
493
#endif /* ndef __HUGS__ */
494

495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
#ifdef __HUGS__
#ifndef __PARALLEL_HASKELL__
writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
#endif
writeBlocks obj buf bufLen initPos s =
  let
   shoveString :: Int -> [Char] -> IO ()
   shoveString n ls = 
     case ls of
      [] ->   
	  {-
	    At the end of a buffer write, update the buffer position
	    in the underlying file object, so that if the handle
	    is subsequently dropped by the program, the whole
	    buffer will be properly flushed.

	    There's one case where this delayed up-date of the buffer
	    position can go wrong: if a thread is killed, it might be
	    in the middle of filling up a buffer, with the result that
	    the partial buffer update is lost upon finalisation. However,
	    by the time killThread is supported, Haskell finalisers are also
	    likely to be in, which means the 'IOFileObject' hack can go
	    alltogether.

	  -}
sof's avatar
sof committed
522
	  setBufWPtr obj n
523 524 525 526 527

      (x:xs) -> do
        primWriteCharOffAddr buf n x
	if n == bufLen
	 then do
sof's avatar
sof committed
528
	   rc <-  mayBlock obj (writeFileObject obj (n + 1))   -- ConcHask: UNSAFE, may block.
529 530 531 532 533 534 535 536
	   if rc == 0 
            then shoveString 0 xs
	    else constructErrorAndFail "writeChunks"
         else
	   shoveString (n + 1) xs
  in
  shoveString initPos s
#else /* ndef __HUGS__ */
sof's avatar
sof committed
537
#ifndef __PARALLEL_HASKELL__
sof's avatar
sof committed
538
writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
539
#else
sof's avatar
sof committed
540
writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
541
#endif
sof's avatar
sof committed
542
writeBlocks obj buf (I# bufLen) (I# initPos#) s =
sof's avatar
sof committed
543
  let
sof's avatar
sof committed
544
   write_char :: Addr -> Int# -> Char# -> IO ()
sof's avatar
sof committed
545
   write_char (A# buf#) n# c# =
sof's avatar
sof committed
546
      IO $ \ s# ->
sof's avatar
sof committed
547
      case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
sof's avatar
sof committed
548

sof's avatar
sof committed
549
   shoveString :: Int# -> [Char] -> IO ()
sof's avatar
sof committed
550 551 552
   shoveString n ls = 
     case ls of
      [] ->   
sof's avatar
sof committed
553 554 555 556 557 558 559 560 561 562 563 564 565 566 567
	  {-
	    At the end of a buffer write, update the buffer position
	    in the underlying file object, so that if the handle
	    is subsequently dropped by the program, the whole
	    buffer will be properly flushed.

	    There's one case where this delayed up-date of the buffer
	    position can go wrong: if a thread is killed, it might be
	    in the middle of filling up a buffer, with the result that
	    the partial buffer update is lost upon finalisation. However,
	    by the time killThread is supported, Haskell finalisers are also
	    likely to be in, which means the 'IOFileObject' hack can go
	    alltogether.

	  -}
sof's avatar
sof committed
568
	  setBufWPtr obj (I# n)
sof's avatar
sof committed
569 570

      ((C# x):xs) -> do
sof's avatar
sof committed
571 572
        write_char buf n x
	if n ==# bufLen
sof's avatar
sof committed
573
	 then do
sof's avatar
sof committed
574
	   rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))   -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
575 576
	   if rc == 0 
	    then shoveString 0# xs
sof's avatar
sof committed
577
	    else constructErrorAndFail "writeChunks"
sof's avatar
sof committed
578 579 580
         else
	   shoveString (n +# 1#) xs
  in
sof's avatar
sof committed
581
  shoveString initPos# s
582
#endif /* ndef __HUGS__ */
583

sof's avatar
sof committed
584
#ifndef __PARALLEL_HASKELL__
sof's avatar
sof committed
585
writeChars :: ForeignObj -> String -> IO ()
586
#else
sof's avatar
sof committed
587
writeChars :: Addr -> String -> IO ()
588
#endif
sof's avatar
sof committed
589
writeChars _fo ""    = return ()
sof's avatar
sof committed
590
writeChars fo (c:cs) = do
sof's avatar
sof committed
591
  rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
sof's avatar
sof committed
592
  if rc == 0 
sof's avatar
sof committed
593 594
   then writeChars fo cs
   else constructErrorAndFail "writeChars"
sof's avatar
sof committed
595

596
\end{code}
597

sof's avatar
sof committed
598 599
Computation @hPrint hdl t@ writes the string representation of {\em t}
given by the @shows@ function to the file or channel managed by {\em
600
hdl}.
601

sof's avatar
sof committed
602
[ Seem to have disappeared from the 1.4 interface  - SOF 2/97 ]
sof's avatar
sof committed
603

604
\begin{code}
sof's avatar
sof committed
605
hPrint :: Show a => Handle -> a -> IO ()
606
hPrint hdl = hPutStrLn hdl . show
607
\end{code}
sof's avatar
sof committed
608 609 610 611 612

Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
the handle \tr{hdl}, adding a newline at the end.

\begin{code}
sof's avatar
sof committed
613
hPutStrLn :: Handle -> String -> IO ()
sof's avatar
sof committed
614 615 616 617 618
hPutStrLn hndl str = do
 hPutStr  hndl str
 hPutChar hndl '\n'

\end{code}
sof's avatar
sof committed
619 620 621 622 623 624 625 626


%*********************************************************
%*							*
\subsection{Try and bracket}
%*							*
%*********************************************************

sof's avatar
sof committed
627
The construct @try comp@ exposes errors which occur within a
sof's avatar
sof committed
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
computation, and which are not fully handled.  It always succeeds.

\begin{code}
try            :: IO a -> IO (Either IOError a)
try f          =  catch (do r <- f
                            return (Right r))
                        (return . Left)

bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket before after m = do
        x  <- before
        rs <- try (m x)
        after x
        case rs of
           Right r -> return r
sof's avatar
sof committed
643
           Left  e -> ioError e
sof's avatar
sof committed
644 645 646 647 648 649 650 651 652

-- variant of the above where middle computation doesn't want x
bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
bracket_ before after m = do
         x  <- before
         rs <- try m
         after x
         case rs of
            Right r -> return r
sof's avatar
sof committed
653
            Left  e -> ioError e
sof's avatar
sof committed
654
\end{code}
sof's avatar
sof committed
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711

%*********************************************************
%*							 *
\subsection{Standard IO}
%*							 *
%*********************************************************

The Prelude has from Day 1 provided a collection of common
IO functions. We define these here, but let the Prelude
export them.

\begin{code}
putChar         :: Char -> IO ()
putChar c       =  hPutChar stdout c

putStr          :: String -> IO ()
putStr s        =  hPutStr stdout s

putStrLn        :: String -> IO ()
putStrLn s      =  do putStr s
                      putChar '\n'

print           :: Show a => a -> IO ()
print x         =  putStrLn (show x)

getChar         :: IO Char
getChar         =  hGetChar stdin

getLine         :: IO String
getLine         =  hGetLine stdin
            
getContents     :: IO String
getContents     =  hGetContents stdin

interact        ::  (String -> String) -> IO ()
interact f      =   do s <- getContents
                       putStr (f s)

readFile        :: FilePath -> IO String
readFile name	=  openFile name ReadMode >>= hGetContents

writeFile       :: FilePath -> String -> IO ()
writeFile name str = do
    hdl <- openFile name WriteMode
    hPutStr hdl str
    hClose hdl

appendFile      :: FilePath -> String -> IO ()
appendFile name str = do
    hdl <- openFile name AppendMode
    hPutStr hdl str
    hClose hdl

readLn          :: Read a => IO a
readLn          =  do l <- getLine
                      r <- readIO l
                      return r
712 713


sof's avatar
sof committed
714
\end{code}
andy's avatar
andy committed
715

716 717
#else /* __HUGS__ */

andy's avatar
andy committed
718
\begin{code}
andy's avatar
andy committed
719
import Ix(Ix)
720
import Monad(when)
andy's avatar
andy committed
721

andy's avatar
andy committed
722
unimp :: String -> a
723
unimp s = error ("IO library: function not implemented: " ++ s)
andy's avatar
andy committed
724

andy's avatar
andy committed
725 726 727
type FILE_STAR = Addr
type Ptr       = Addr
nULL           = nullAddr
andy's avatar
andy committed
728 729 730

data Handle 
   = Handle { name     :: FilePath,
731 732
              file     :: FILE_STAR,         -- C handle
              mut      :: IORef Handle_Mut,  -- open/closed/semiclosed
andy's avatar
andy committed
733
              mode     :: IOMode,
734
              seekable :: Bool
andy's avatar
andy committed
735 736
            }

737 738 739
data Handle_Mut
   = Handle_Mut { state :: HState 
                }
740
     deriving Show
741 742 743 744 745 746 747 748 749 750

set_state :: Handle -> HState -> IO ()
set_state hdl new_state
   = writeIORef (mut hdl) (Handle_Mut { state = new_state })
get_state :: Handle -> IO HState
get_state hdl
   = readIORef (mut hdl) >>= \m -> return (state m)

mkErr :: Handle -> String -> IO a
mkErr h msg
751 752 753
   = do mut <- readIORef (mut h)
        when (state mut /= HClosed) 
             (nh_close (file h) >> set_state h HClosed)
754 755 756 757 758 759
        dummy <- nh_errno
        ioError (IOError msg)

stdin
   = Handle {
        name = "stdin",
andy's avatar
andy committed
760 761
        file = unsafePerformIO nh_stdin,
        mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
762 763 764 765 766 767
        mode = ReadMode
     }

stdout
   = Handle {
        name = "stdout",
andy's avatar
andy committed
768 769
        file = unsafePerformIO nh_stdout,
        mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
770 771 772 773 774 775
        mode = WriteMode
     }

stderr
   = Handle {
        name = "stderr",
andy's avatar
andy committed
776 777
        file = unsafePerformIO nh_stderr,
        mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
778 779 780 781
        mode = WriteMode
     }


andy's avatar
andy committed
782 783 784 785
instance Eq Handle where
   h1 == h2   = file h1 == file h2

instance Show Handle where
786
   showsPrec _ h = showString ("`" ++ name h ++ "'")
andy's avatar
andy committed
787 788 789 790 791 792 793 794 795 796

data HandlePosn
   = HandlePosn 
     deriving (Eq, Show)


data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
                    deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)

data BufferMode  =  NoBuffering | LineBuffering 
andy's avatar
andy committed
797
                 |  BlockBuffering (Maybe Int)
andy's avatar
andy committed
798 799 800 801 802 803
                    deriving (Eq, Ord, Read, Show)

data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
                    deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)

data HState = HOpen | HSemiClosed | HClosed
804 805 806 807 808 809 810 811 812 813 814 815 816 817 818
              deriving (Show, Eq)


-- A global variable holding a list of all open handles.
-- Each handle is present as many times as it has been opened.
-- Any given file is allowed to have _either_ one writeable handle
-- or many readable handles in this list.  The list is used to
-- enforce single-writer multiple reader semantics.  It also 
-- provides a list of handles for System.exitWith to flush and
-- close.  In order not to have to put all this stuff in the
-- Prelude, System.exitWith merely runs prelExitWithAction,
-- which is originally Nothing, but which we set to Just ...
-- once handles appear in the list.

allHandles :: IORef [Handle]
andy's avatar
andy committed
819
allHandles  = unsafePerformIO (newIORef [])
820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864

elemWriterHandles :: FilePath -> IO Bool
elemAllHandles    :: FilePath -> IO Bool
addHandle         :: Handle -> IO ()
delHandle         :: Handle -> IO ()
cleanupHandles    :: IO ()

cleanupHandles
   = do hdls <- readIORef allHandles
        mapM_ cleanupHandle hdls
     where
        cleanupHandle h
           | mode h == ReadMode
           = nh_close (file h) 
             >> nh_errno >>= \_ -> return ()
           | otherwise
           = nh_flush (file h) >> nh_close (file h) 
             >> nh_errno >>= \_ -> return ()

elemWriterHandles fname
   = do hdls <- readIORef allHandles
        let hdls_w = filter ((/= ReadMode).mode) hdls
        return (fname `elem` (map name hdls_w))

elemAllHandles fname
   = do hdls <- readIORef allHandles
        return (fname `elem` (map name hdls))

addHandle hdl
   = do cleanup_action <- readIORef prelCleanupAfterRunAction
        case cleanup_action of
           Nothing 
              -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles)
           Just xx
              -> return ()
        hdls <- readIORef allHandles
        writeIORef allHandles (hdl : hdls)

delHandle hdl
   = do hdls <- readIORef allHandles
        let hdls' = takeWhile (/= hdl) hdls 
                    ++ drop 1 (dropWhile (/= hdl) hdls)
        writeIORef allHandles hdls'


andy's avatar
andy committed
865 866 867

openFile :: FilePath -> IOMode -> IO Handle
openFile f mode
868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891

   | null f
   =  (ioError.IOError) "openFile: empty file name"

   | mode == ReadMode
   = do not_ok <- elemWriterHandles f
        if    not_ok 
         then (ioError.IOError) 
                 ("openFile: `" ++ f ++ "' in " ++ show mode 
                  ++ ": is already open for writing")
         else openFile_main f mode

   | mode /= ReadMode
   = do not_ok <- elemAllHandles f
        if    not_ok 
         then (ioError.IOError) 
                 ("openFile: `" ++ f ++ "' in " ++ show mode 
                  ++ ": is already open for reading or writing")
         else openFile_main f mode

   | otherwise
   = openFile_main f mode

openFile_main f mode
andy's avatar
andy committed
892 893 894 895
   = copy_String_to_cstring f >>= \nameptr ->
     nh_open nameptr (mode2num mode) >>= \fh ->
     nh_free nameptr >>
     if   fh == nULL
896 897
     then (ioError.IOError)
             ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
898 899 900 901 902
     else do r   <- newIORef (Handle_Mut { state = HOpen })
             let hdl = Handle { name = f, file = fh, 
                                mut  = r, mode = mode }
             addHandle hdl
             return hdl
andy's avatar
andy committed
903 904 905 906 907
     where
        mode2num :: IOMode -> Int
        mode2num ReadMode   = 0
        mode2num WriteMode  = 1
        mode2num AppendMode = 2
908 909 910 911
        mode2num ReadWriteMode
           = error
                ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")

andy's avatar
andy committed
912 913
hClose :: Handle -> IO ()
hClose h
914 915 916 917 918 919
   = do mut <- readIORef (mut h)
        if    state mut == HClosed
         then mkErr h
                 ("hClose on closed handle " ++ show h)
         else 
         do set_state h HClosed
920
            delHandle h
921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946
            nh_close (file h)
            err <- nh_errno
            if    err == 0 
             then return ()
             else mkErr h
                     ("hClose: error closing " ++ name h)

hGetContents :: Handle -> IO String
hGetContents h
   | mode h /= ReadMode
   = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
   | otherwise 
   = do mut <- readIORef (mut h)
        if    state mut /= HOpen
         then mkErr h
                 ("hGetContents on closed/semiclosed handle " ++ show h)
         else
         do set_state h HSemiClosed
            read_all (file h)
            where
               read_all f 
                  = nh_read f >>= \ci ->
                    if   ci == -1
                    then return []
                    else read_all f >>= \rest -> 
                         return ((primIntToChar ci):rest)
andy's avatar
andy committed
947

948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981
hPutStr :: Handle -> String -> IO ()
hPutStr h s
   | mode h == ReadMode
   = mkErr h ("hPutStr on ReadMode handle " ++ show h)
   | otherwise
   = do mut <- readIORef (mut h)
        if    state mut /= HOpen
         then mkErr h
                 ("hPutStr on closed/semiclosed handle " ++ show h)
         else write_all (file h) s
              where
                 write_all f []
                    = return ()
                 write_all f (c:cs)
                    = nh_write f c >> write_all f cs

hFileSize :: Handle -> IO Integer
hFileSize h
   = do sz <- nh_filesize (file h)
        er <- nh_errno
        if    er == 0
         then return (fromIntegral sz)
         else mkErr h ("hFileSize on " ++ show h)

hIsEOF :: Handle -> IO Bool
hIsEOF h
   = do iseof <- nh_iseof (file h)
        er    <- nh_errno
        if    er == 0
         then return (iseof /= 0)
         else mkErr h ("hIsEOF on " ++ show h)

isEOF :: IO Bool
isEOF = hIsEOF stdin
andy's avatar
andy committed
982 983 984 985 986 987 988

hSetBuffering         :: Handle  -> BufferMode -> IO ()
hSetBuffering          = unimp "IO.hSetBuffering"
hGetBuffering         :: Handle  -> IO BufferMode
hGetBuffering          = unimp "IO.hGetBuffering"

hFlush :: Handle -> IO ()
989 990 991 992 993 994
hFlush h
   = do mut <- readIORef (mut h)
        if    state mut /= HOpen
         then mkErr h
                 ("hFlush on closed/semiclosed file " ++ name h)
         else nh_flush (file h)
andy's avatar
andy committed
995 996 997 998 999 1000 1001 1002 1003 1004

hGetPosn              :: Handle -> IO HandlePosn
hGetPosn               = unimp "IO.hGetPosn"
hSetPosn              :: HandlePosn -> IO ()
hSetPosn               = unimp "IO.hSetPosn"
hSeek                 :: Handle -> SeekMode -> Integer -> IO () 
hSeek                  = unimp "IO.hSeek"
hWaitForInput	      :: Handle -> Int -> IO Bool
hWaitForInput          = unimp "hWaitForInput"
hReady                :: Handle -> IO Bool 
1005
hReady h	       = unimp "hReady" -- hWaitForInput h 0
andy's avatar
andy committed
1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031

hGetChar    :: Handle -> IO Char
hGetChar h
   = nh_read (file h) >>= \ci ->
     return (primIntToChar ci)

hGetLine              :: Handle -> IO String
hGetLine h             = do c <- hGetChar h
                            if c=='\n' then return ""
                              else do cs <- hGetLine h
                                      return (c:cs)

hLookAhead            :: Handle -> IO Char
hLookAhead             = unimp "IO.hLookAhead"


hPutChar              :: Handle -> Char -> IO ()
hPutChar h c           = hPutStr h [c]

hPutStrLn             :: Handle -> String -> IO ()
hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }

hPrint                :: Show a => Handle -> a -> IO ()
hPrint h               = hPutStrLn h . show

hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
1032 1033
hIsOpen h              = do { s <- get_state h; return (s == HOpen) }
hIsClosed h            = do { s <- get_state h; return (s == HClosed) }
andy's avatar
andy committed
1034
hIsReadable h          = return (mode h == ReadMode)
1035
hIsWritable h          = return (mode h `elem` [WriteMode, AppendMode])
andy's avatar
andy committed
1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059

hIsSeekable           :: Handle -> IO Bool
hIsSeekable            = unimp "IO.hIsSeekable"

isIllegalOperation, 
	  isAlreadyExistsError, 
	  isDoesNotExistError, 
          isAlreadyInUseError,   
	  isFullError,     
          isEOFError, 
	  isPermissionError,
          isUserError        :: IOError -> Bool

isIllegalOperation    = unimp "IO.isIllegalOperation"
isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
isDoesNotExistError   = unimp "IO.isDoesNotExistError"
isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
isFullError           = unimp "IO.isFullError"
isEOFError            = unimp "IO.isEOFError"
isPermissionError     = unimp "IO.isPermissionError"
isUserError           = unimp "IO.isUserError"


ioeGetErrorString :: IOError -> String
1060
ioeGetErrorString = unimp "IO.ioeGetErrorString"
andy's avatar
andy committed
1061
ioeGetHandle      :: IOError -> Maybe Handle
1062
ioeGetHandle      = unimp "IO.ioeGetHandle"
andy's avatar
andy committed
1063
ioeGetFileName    :: IOError -> Maybe FilePath
1064
ioeGetFileName    = unimp "IO.ioeGetFileName"
andy's avatar
andy committed
1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086

try       :: IO a -> IO (Either IOError a)
try p      = catch (p >>= (return . Right)) (return . Left)

bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket before after m = do
        x  <- before
        rs <- try (m x)
        after x
        case rs of
           Right r -> return r
           Left  e -> ioError e

-- variant of the above where middle computation doesn't want x
bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
bracket_ before after m = do
         x  <- before
         rs <- try m
         after x
         case rs of
            Right r -> return r
            Left  e -> ioError e
1087

andy's avatar
andy committed
1088
-- TODO: Hugs/slurpFile
1089
slurpFile = unimp "IO.slurpFile"
andy's avatar
andy committed
1090
\end{code}
1091 1092

#endif /* #ifndef __HUGS__ */