2 % (c) The AQUA Project, Glasgow University, 1994-1996
5 \section[PrelHandle]{Module @PrelHandle@}
7 This module defines Haskell {\em handles} and the basic operations
8 which are supported for them.
11 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
12 #include "cbits/error.h"
14 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
15 module PrelHandle where
18 import PrelAddr ( Addr, nullAddr )
19 import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
20 import PrelRead ( Read )
21 import PrelList ( span )
24 import PrelMaybe ( Maybe(..) )
25 import PrelBounded () -- get at Bounded Int instance.
26 import PrelNum ( toInteger, toBig )
27 import PrelPack ( packString )
28 import PrelWeak ( addForeignFinalizer )
31 #if __CONCURRENT_HASKELL__
35 #ifndef __PARALLEL_HASKELL__
36 import PrelForeign ( makeForeignObj )
39 #endif /* ndef(__HUGS__) */
42 #define cat2(x,y) x/**/y
43 #define CCALL(fun) cat2(prim_,fun)
44 #define __CONCURRENT_HASKELL__
46 #define sizeof_int64 8
48 #define CCALL(fun) _ccall_ fun
49 #define const_BUFSIZ ``BUFSIZ''
50 #define primPackString
53 #ifndef __PARALLEL_HASKELL__
54 #define FILE_OBJECT ForeignObj
56 #define FILE_OBJECT Addr
60 %*********************************************************
62 \subsection{Types @Handle@, @Handle__@}
64 %*********************************************************
66 The @Handle@ and @Handle__@ types are defined in @IOBase@.
69 {-# INLINE newHandle #-}
70 {-# INLINE withHandle #-}
71 {-# INLINE writeHandle #-}
72 newHandle :: Handle__ -> IO Handle
73 withHandle :: Handle -> (Handle__ -> IO a) -> IO a
74 writeHandle :: Handle -> Handle__ -> IO ()
76 #if defined(__CONCURRENT_HASKELL__)
78 -- Use MVars for concurrent Haskell
79 newHandle hc = newMVar hc >>= \ h ->
82 -- withHandle grabs the handle lock, performs
83 -- some operation over it, making sure that we
84 -- unlock & reset the handle state should an
85 -- exception occur while performing said op.
86 withHandle (Handle h) act = do
88 v <- catchNonIO (act h_) (\ ex -> putMVar h h_ >> throw ex)
91 writeHandle (Handle h) hc = putMVar h hc
94 -- Use ordinary MutableVars for non-concurrent Haskell
95 newHandle hc = stToIO (newVar hc >>= \ h ->
98 -- of questionable value to install this exception
99 -- handler, but let's do it in the non-concurrent
100 -- case too, for now.
101 withHandle (Handle h) act = do
102 h_ <- stToIO (readVar h)
103 v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
106 writeHandle (Handle h) hc = stToIO (writeVar h hc)
110 nullFile__ is only used for closed handles, plugging it in as a null
111 file object reference.
114 nullFile__ :: FILE_OBJECT
116 #ifndef __PARALLEL_HASKELL__
117 unsafePerformIO (makeForeignObj nullAddr)
123 mkClosedHandle__ :: Handle__
131 mkErrorHandle__ :: IOError -> Handle__
132 mkErrorHandle__ ioe =
140 %*********************************************************
142 \subsection{Handle Finalizers}
144 %*********************************************************
148 freeStdFileObject :: ForeignObj -> IO ()
149 freeStdFileObject fo = CCALL(freeStdFileObject) fo
151 freeFileObject :: ForeignObj -> IO ()
152 freeFileObject fo = CCALL(freeFileObject) fo
154 foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
155 foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
159 %*********************************************************
161 \subsection[StdHandles]{Standard handles}
163 %*********************************************************
165 Three handles are allocated during program initialisation. The first
166 two manage input or output from the Haskell program's standard input
167 or output channel respectively. The third manages output to the
168 standard error channel. These handles are initially open.
172 stdin, stdout, stderr :: Handle
174 stdout = unsafePerformIO (do
175 rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block
177 0 -> newHandle (mkClosedHandle__)
179 #ifndef __CONCURRENT_HASKELL__
180 fo <- CCALL(openStdFile) (1::Int)
181 (1::Int){-flush on close-}
182 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
184 fo <- CCALL(openStdFile) (1::Int)
185 ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int)
186 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
188 -- NOTE: turn off non-blocking I/O until
189 -- we've got proper support for threadWait{Read,Write}
191 #ifndef __PARALLEL_HASKELL__
192 fo <- makeForeignObj fo
193 addForeignFinalizer fo (freeStdFileObject fo)
197 /* I dont care what the Haskell report says, in an interactive system,
198 * stdout should be unbuffered by default.
202 (bm, bf_size) <- getBMode__ fo
203 mkBuffer__ fo bf_size
205 newHandle (Handle__ fo WriteHandle bm "stdout")
206 _ -> do ioError <- constructError "stdout"
207 newHandle (mkErrorHandle__ ioError)
210 stdin = unsafePerformIO (do
211 rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block
213 0 -> newHandle (mkClosedHandle__)
215 #ifndef __CONCURRENT_HASKELL__
216 fo <- CCALL(openStdFile) (0::Int)
217 (0::Int){-don't flush on close -}
218 (1::Int){-readable-} -- ConcHask: SAFE, won't block
220 fo <- CCALL(openStdFile) (0::Int)
221 ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int)
222 (1::Int){-readable-} -- ConcHask: SAFE, won't block
225 #ifndef __PARALLEL_HASKELL__
226 fo <- makeForeignObj fo
227 addForeignFinalizer fo (freeStdFileObject fo)
229 (bm, bf_size) <- getBMode__ fo
230 mkBuffer__ fo bf_size
231 hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
232 -- when stdin and stdout are both connected to a terminal, ensure
233 -- that anything buffered on stdout is flushed prior to reading from stdin.
235 hConnectTerms stdout hdl
237 _ -> do ioError <- constructError "stdin"
238 newHandle (mkErrorHandle__ ioError)
242 stderr = unsafePerformIO (do
243 rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
245 0 -> newHandle (mkClosedHandle__)
247 #ifndef __CONCURRENT_HASKELL__
248 fo <- CCALL(openStdFile) (2::Int)
249 (1::Int){-flush on close-}
250 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
252 fo <- CCALL(openStdFile) (2::Int)
253 ((1{-flush on close-} {- + 128 don't block on I/O-})::Int)
254 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
257 #ifndef __PARALLEL_HASKELL__
258 fo <- makeForeignObj fo
259 addForeignFinalizer fo (freeStdFileObject fo)
261 hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
262 -- when stderr and stdout are both connected to a terminal, ensure
263 -- that anything buffered on stdout is flushed prior to writing to
265 hConnectTo stdout hdl
268 _ -> do ioError <- constructError "stderr"
269 newHandle (mkErrorHandle__ ioError)
273 %*********************************************************
275 \subsection[OpeningClosing]{Opening and Closing Files}
277 %*********************************************************
280 data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
281 deriving (Eq, Ord, Ix, Enum, Read, Show)
286 deriving (Eq, Read, Show)
288 openFile :: FilePath -> IOMode -> IO Handle
289 openFile fp im = openFileEx fp (TextMode im)
291 openFileEx :: FilePath -> IOModeEx -> IO Handle
294 fo <- CCALL(openFile) (primPackString f) (file_mode::Int)
296 (file_flags::Int) -- ConcHask: SAFE, won't block
297 if fo /= nullAddr then do
298 #ifndef __PARALLEL_HASKELL__
299 fo <- makeForeignObj fo
300 addForeignFinalizer fo (freeFileObject fo)
302 (bm, bf_size) <- getBMode__ fo
303 mkBuffer__ fo bf_size
304 newHandle (Handle__ fo htype bm f)
306 constructErrorAndFailWithInfo "openFile" f
310 BinaryMode bmo -> (bmo, 1)
311 TextMode tmo -> (tmo, 0)
313 #ifndef __CONCURRENT_HASKELL__
314 file_flags = file_flags'
316 -- See comment next to 'stderr' for why we leave
317 -- non-blocking off for now.
318 file_flags = file_flags' {-+ 128 Don't block on I/O-}
321 (file_flags', file_mode) =
326 ReadWriteMode -> (1, 3)
329 ReadMode -> ReadHandle
330 WriteMode -> WriteHandle
331 AppendMode -> AppendHandle
332 ReadWriteMode -> ReadWriteHandle
335 Computation $openFile file mode$ allocates and returns a new, open
336 handle to manage the file {\em file}. It manages input if {\em mode}
337 is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
338 and both input and output if mode is $ReadWriteMode$.
340 If the file does not exist and it is opened for output, it should be
341 created as a new file. If {\em mode} is $WriteMode$ and the file
342 already exists, then it should be truncated to zero length. The
343 handle is positioned at the end of the file if {\em mode} is
344 $AppendMode$, and otherwise at the beginning (in which case its
345 internal position is 0).
347 Implementations should enforce, locally to the Haskell process,
348 multiple-reader single-writer locking on files, which is to say that
349 there may either be many handles on the same file which manage input,
350 or just one handle on the file which manages output. If any open or
351 semi-closed handle is managing a file for output, no new handle can be
352 allocated for that file. If any open or semi-closed handle is
353 managing a file for input, new handles can only be allocated if they
354 do not manage output.
356 Two files are the same if they have the same absolute name. An
357 implementation is free to impose stricter conditions.
360 hClose :: Handle -> IO ()
363 withHandle handle $ \ handle_ -> do
364 case haType__ handle_ of
365 ErrorHandle theError -> do
366 writeHandle handle handle_
369 writeHandle handle handle_
372 rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
373 {- We explicitly close a file object so that we can be told
374 if there were any errors. Note that after @hClose@
375 has been performed, the ForeignObj embedded in the Handle
376 is still lying around in the heap, so care is taken
377 to avoid closing the file object when the ForeignObj
378 is finalized. (we overwrite the file ptr in the underlying
379 FileObject with a NULL as part of closeFile())
383 writeHandle handle (handle_{ haType__ = ClosedHandle,
384 haFO__ = nullFile__ })
386 writeHandle handle handle_
387 constructErrorAndFail "hClose"
391 Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
392 computation finishes, any items buffered for output and not already
393 sent to the operating system are flushed as for $flush$.
395 %*********************************************************
397 \subsection[EOF]{Detecting the End of Input}
399 %*********************************************************
402 For a handle {\em hdl} which attached to a physical file, $hFileSize
403 hdl$ returns the size of {\em hdl} in terms of the number of items
404 which can be read from {\em hdl}.
407 hFileSize :: Handle -> IO Integer
409 withHandle handle $ \ handle_ -> do
410 case haType__ handle_ of
411 ErrorHandle theError -> do
412 writeHandle handle handle_
415 writeHandle handle handle_
416 ioe_closedHandle "hFileSize" handle
417 SemiClosedHandle -> do
418 writeHandle handle handle_
419 ioe_closedHandle "hFileSize" handle
422 mem <- primNewByteArray sizeof_int64
423 rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
424 writeHandle handle handle_
426 result <- primReadInt64Array mem 0
427 return (primInt64ToInteger result)
429 constructErrorAndFail "hFileSize"
432 -- HACK! We build a unique MP_INT of the right shape to hold
433 -- a single unsigned word, and we let the C routine
434 -- change the data bits
436 -- For some reason, this fails to typecheck if converted to a do
438 _casm_ ``%r = 1;'' >>= \(I# hack#) ->
439 case int2Integer# hack# of
441 rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
442 writeHandle handle handle_
443 if rc == (0::Int) then
446 constructErrorAndFail "hFileSize"
450 For a readable handle {\em hdl}, @hIsEOF hdl@ returns
451 @True@ if no further input can be taken from @hdl@ or for a
452 physical file, if the current I/O position is equal to the length of
453 the file. Otherwise, it returns @False@.
456 hIsEOF :: Handle -> IO Bool
458 wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
459 let fo = haFO__ handle_
460 rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
461 writeHandle handle handle_
465 _ -> constructErrorAndFail "hIsEOF"
471 %*********************************************************
473 \subsection[Buffering]{Buffering Operations}
475 %*********************************************************
477 Three kinds of buffering are supported: line-buffering,
478 block-buffering or no-buffering. See @IOBase@ for definition
479 and further explanation of what the type represent.
481 Computation @hSetBuffering hdl mode@ sets the mode of buffering for
482 handle {\em hdl} on subsequent reads and writes.
486 If {\em mode} is @LineBuffering@, line-buffering should be
489 If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
490 should be enabled if possible. The size of the buffer is {\em n} items
491 if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
493 If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
496 If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
497 to @NoBuffering@, then any items in the output buffer are written to
498 the device, and any items in the input buffer are discarded. The
499 default buffering mode when a handle is opened is
500 implementation-dependent and may depend on the object which is
501 attached to that handle.
504 hSetBuffering :: Handle -> BufferMode -> IO ()
506 hSetBuffering handle mode =
508 BlockBuffering (Just n)
510 (IOError (Just handle)
513 ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
515 withHandle handle $ \ handle_ -> do
516 case haType__ handle_ of
517 ErrorHandle theError -> do
518 writeHandle handle handle_
521 writeHandle handle handle_
522 ioe_closedHandle "hSetBuffering" handle
525 - we flush the old buffer regardless of whether
526 the new buffer could fit the contents of the old buffer
528 - allow a handle's buffering to change even if IO has
529 occurred (ANSI C spec. does not allow this, nor did
530 the previous implementation of IO.hSetBuffering).
531 - a non-standard extension is to allow the buffering
532 of semi-closed handles to change [sof 6/98]
534 let fo = haFO__ handle_
535 rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
538 writeHandle handle (handle_{ haBufferMode__ = mode })
540 -- Note: failure to change the buffer size will cause old buffer to be flushed.
541 writeHandle handle handle_
542 constructErrorAndFail "hSetBuffering"
548 BlockBuffering Nothing -> -2
549 BlockBuffering (Just n) -> n
552 The action @hFlush hdl@ causes any items buffered for output
553 in handle {\em hdl} to be sent immediately to the operating
557 hFlush :: Handle -> IO ()
559 wantWriteableHandle "hFlush" handle $ \ handle_ -> do
560 let fo = haFO__ handle_
561 rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
562 writeHandle handle handle_
566 constructErrorAndFail "hFlush"
571 %*********************************************************
573 \subsection[Seeking]{Repositioning Handles}
575 %*********************************************************
580 Handle -- Q: should this be a weak or strong ref. to the handle?
583 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
584 deriving (Eq, Ord, Ix, Enum, Read, Show)
587 Computation @hGetPosn hdl@ returns the current I/O
588 position of {\em hdl} as an abstract position. Computation
589 $hSetPosn p$ sets the position of {\em hdl}
590 to a previously obtained position {\em p}.
593 hGetPosn :: Handle -> IO HandlePosn
595 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
596 posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
597 writeHandle handle handle_
599 return (HandlePosn handle posn)
601 constructErrorAndFail "hGetPosn"
603 hSetPosn :: HandlePosn -> IO ()
604 hSetPosn (HandlePosn handle posn) =
605 wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
606 let fo = haFO__ handle_
607 rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
608 writeHandle handle handle_
612 constructErrorAndFail "hSetPosn"
615 The action @hSeek hdl mode i@ sets the position of handle
616 @hdl@ depending on @mode@. If @mode@ is
618 \item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
619 \item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
620 the current position.
621 \item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
625 Some handles may not be seekable (see @hIsSeekable@), or only support a
626 subset of the possible positioning operations (e.g. it may only be
627 possible to seek to the end of a tape, or to a positive offset from
628 the beginning or current position).
630 It is not possible to set a negative I/O position, or for a physical
631 file, an I/O position beyond the current end-of-file.
634 - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
636 - relative seeking on buffered handles can lead to non-obvious results.
639 hSeek :: Handle -> SeekMode -> Integer -> IO ()
641 hSeek handle mode offset =
642 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
643 let fo = haFO__ handle_
644 rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
646 hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
647 hSeek handle mode (J# s# d#) =
648 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
649 let fo = haFO__ handle_
650 rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
652 writeHandle handle handle_
656 constructErrorAndFail "hSeek"
659 whence = case mode of
665 %*********************************************************
667 \subsection[Query]{Handle Properties}
669 %*********************************************************
671 A number of operations return information about the properties of a
672 handle. Each of these operations returns $True$ if the
673 handle has the specified property, and $False$
676 Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
677 {\em hdl} is not block-buffered. Otherwise it returns
678 $( True, size )$, where {\em size} is $Nothing$ for default buffering, and
679 $( Just n )$ for block-buffering of {\em n} bytes.
682 hIsOpen :: Handle -> IO Bool
684 withHandle handle $ \ handle_ -> do
685 case haType__ handle_ of
686 ErrorHandle theError -> do
687 writeHandle handle handle_
690 writeHandle handle handle_
692 SemiClosedHandle -> do
693 writeHandle handle handle_
696 writeHandle handle handle_
699 hIsClosed :: Handle -> IO Bool
701 withHandle handle $ \ handle_ -> do
702 case haType__ handle_ of
703 ErrorHandle theError -> do
704 writeHandle handle handle_
707 writeHandle handle handle_
710 writeHandle handle handle_
713 {- not defined, nor exported, but mentioned
714 here for documentation purposes:
716 hSemiClosed :: Handle -> IO Bool
720 return (not (ho || hc))
723 hIsReadable :: Handle -> IO Bool
725 withHandle handle $ \ handle_ -> do
726 case haType__ handle_ of
727 ErrorHandle theError -> do
728 writeHandle handle handle_
731 writeHandle handle handle_
732 ioe_closedHandle "hIsReadable" handle
733 SemiClosedHandle -> do
734 writeHandle handle handle_
735 ioe_closedHandle "hIsReadable" handle
737 writeHandle handle handle_
738 return (isReadable htype)
740 isReadable ReadHandle = True
741 isReadable ReadWriteHandle = True
744 hIsWritable :: Handle -> IO Bool
746 withHandle handle $ \ handle_ -> do
747 case haType__ handle_ of
748 ErrorHandle theError -> do
749 writeHandle handle handle_
752 writeHandle handle handle_
753 ioe_closedHandle "hIsWritable" handle
754 SemiClosedHandle -> do
755 writeHandle handle handle_
756 ioe_closedHandle "hIsWritable" handle
758 writeHandle handle handle_
759 return (isWritable htype)
761 isWritable AppendHandle = True
762 isWritable WriteHandle = True
763 isWritable ReadWriteHandle = True
767 #ifndef __PARALLEL_HASKELL__
768 getBMode__ :: ForeignObj -> IO (BufferMode, Int)
770 getBMode__ :: Addr -> IO (BufferMode, Int)
773 rc <- CCALL(getBufferMode) fo -- ConcHask: SAFE, won't block
775 0 -> return (NoBuffering, 0)
776 -1 -> return (LineBuffering, default_buffer_size)
777 -2 -> return (BlockBuffering Nothing, default_buffer_size)
778 -3 -> return (NoBuffering, 0) -- only happens on un-stat()able files.
779 n -> return (BlockBuffering (Just n), n)
781 default_buffer_size :: Int
782 default_buffer_size = (const_BUFSIZ - 1)
785 Querying how a handle buffers its data:
788 hGetBuffering :: Handle -> IO BufferMode
789 hGetBuffering handle =
790 withHandle handle $ \ handle_ -> do
791 case haType__ handle_ of
792 ErrorHandle theError -> do
793 writeHandle handle handle_
796 writeHandle handle handle_
797 ioe_closedHandle "hGetBuffering" handle
800 We're being non-standard here, and allow the buffering
801 of a semi-closed handle to be queried. -- sof 6/98
803 let v = haBufferMode__ handle_
804 writeHandle handle handle_
805 return v -- could be stricter..
810 hIsSeekable :: Handle -> IO Bool
812 withHandle handle $ \ handle_ -> do
813 case haType__ handle_ of
814 ErrorHandle theError -> do
815 writeHandle handle handle_
818 writeHandle handle handle_
819 ioe_closedHandle "hIsSeekable" handle
820 SemiClosedHandle -> do
821 writeHandle handle handle_
822 ioe_closedHandle "hIsSeekable" handle
824 writeHandle handle handle_
827 rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
828 writeHandle handle handle_
832 _ -> constructErrorAndFail "hIsSeekable"
836 %*********************************************************
838 \subsection{Changing echo status}
840 %*********************************************************
842 Non-standard GHC extension is to allow the echoing status
843 of a handles connected to terminals to be reconfigured:
846 hSetEcho :: Handle -> Bool -> IO ()
847 hSetEcho handle on = do
848 isT <- hIsTerminalDevice handle
852 withHandle handle $ \ handle_ -> do
853 case haType__ handle_ of
854 ErrorHandle theError -> do
855 writeHandle handle handle_
858 writeHandle handle handle_
859 ioe_closedHandle "hSetEcho" handle
861 rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block
862 writeHandle handle handle_
865 else constructErrorAndFail "hSetEcho"
867 hGetEcho :: Handle -> IO Bool
869 isT <- hIsTerminalDevice handle
873 withHandle handle $ \ handle_ -> do
874 case haType__ handle_ of
875 ErrorHandle theError -> do
876 writeHandle handle handle_
879 writeHandle handle handle_
880 ioe_closedHandle "hGetEcho" handle
882 rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
883 writeHandle handle handle_
887 _ -> constructErrorAndFail "hSetEcho"
889 hIsTerminalDevice :: Handle -> IO Bool
890 hIsTerminalDevice handle = do
891 withHandle handle $ \ handle_ -> do
892 case haType__ handle_ of
893 ErrorHandle theError -> do
894 writeHandle handle handle_
897 writeHandle handle handle_
898 ioe_closedHandle "hIsTerminalDevice" handle
900 rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
901 writeHandle handle handle_
905 _ -> constructErrorAndFail "hIsTerminalDevice"
909 hConnectTerms :: Handle -> Handle -> IO ()
910 hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
912 hConnectTo :: Handle -> Handle -> IO ()
913 hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
915 hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
916 hConnectHdl_ hW hR is_tty =
917 wantRWHandle "hConnectTo" hW $ \ hW_ -> do
918 wantRWHandle "hConnectTo" hR $ \ hR_ -> do
919 CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
923 #ifndef __PARALLEL_HASKELL__
924 #define FILE_OBJECT ForeignObj
926 #define FILE_OBJECT Addr
929 flushConnectedBuf :: FILE_OBJECT -> IO ()
930 flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
933 As an extension, we also allow characters to be pushed back.
934 Like ANSI C stdio, we guarantee no more than one character of
935 pushback. (For unbuffered channels, the (default) push-back limit is
939 hUngetChar :: Handle -> Char -> IO ()
940 hUngetChar handle c =
941 wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
942 rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
943 writeHandle handle handle_
945 then constructErrorAndFail "hUngetChar"
951 Hoisting files in in one go is sometimes useful, so we support
952 this as an extension:
955 -- in one go, read file into an externally allocated buffer.
956 slurpFile :: FilePath -> IO (Addr, Int)
958 handle <- openFile fname ReadMode
959 sz <- hFileSize handle
960 if sz > toInteger (maxBound::Int) then
961 ioError (userError "slurpFile: file too big")
963 let sz_i = fromInteger sz
964 chunk <- CCALL(allocMemory__) (sz_i::Int)
968 constructErrorAndFail "slurpFile"
970 withHandle handle $ \ handle_ -> do
971 let fo = haFO__ handle_
972 rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
973 writeHandle handle handle_
976 then constructErrorAndFail "slurpFile"
977 else return (chunk, rc)
979 #ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
980 hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
981 hFillBufBA handle buf sz
982 | sz <= 0 = ioError (IOError (Just handle)
985 ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
987 wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
988 let fo = haFO__ handle_
990 rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block.
992 rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
994 writeHandle handle handle_
997 else constructErrorAndFail "hFillBufBA"
1000 hFillBuf :: Handle -> Addr -> Int -> IO Int
1001 hFillBuf handle buf sz
1002 | sz <= 0 = ioError (IOError (Just handle)
1005 ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
1007 wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
1008 let fo = haFO__ handle_
1009 rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
1010 writeHandle handle handle_
1013 else constructErrorAndFail "hFillBuf"
1017 The @hPutBuf hdl buf len@ action writes an already packed sequence of
1018 bytes to the file/channel managed by @hdl@ - non-standard.
1021 hPutBuf :: Handle -> Addr -> Int -> IO ()
1022 hPutBuf handle buf len =
1023 wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
1024 let fo = haFO__ handle_
1025 rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
1026 writeHandle handle handle_
1029 else constructErrorAndFail "hPutBuf"
1031 #ifndef __HUGS__ /* An_ one Hugs doesn't provide */
1032 hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
1033 hPutBufBA handle buf len =
1034 wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
1035 let fo = haFO__ handle_
1036 rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
1037 writeHandle handle handle_
1040 else constructErrorAndFail "hPutBuf"
1044 Sometimes it's useful to get at the file descriptor that
1045 the Handle contains..
1048 getHandleFd :: Handle -> IO Int
1049 getHandleFd handle = do
1050 withHandle handle $ \ handle_ -> do
1051 case (haType__ handle_) of
1052 ErrorHandle theError -> do
1053 writeHandle handle handle_
1056 writeHandle handle handle_
1057 ioe_closedHandle "getHandleFd" handle
1059 fd <- CCALL(getFileFd) (haFO__ handle_)
1060 writeHandle handle handle_
1065 %*********************************************************
1067 \subsection{Miscellaneous}
1069 %*********************************************************
1071 These three functions are meant to get things out of @IOErrors@.
1076 ioeGetFileName :: IOError -> Maybe FilePath
1077 ioeGetErrorString :: IOError -> String
1078 ioeGetHandle :: IOError -> Maybe Handle
1080 ioeGetHandle (IOError h _ _ _) = h
1081 ioeGetErrorString (IOError _ iot _ str) =
1083 EOF -> "end of file"
1086 ioeGetFileName (IOError _ _ _ str) =
1087 case span (/=':') str of
1093 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
1094 PrelMain.mainIO) and report them - topHandler is the exception
1095 handler they should use for this:
1098 -- make sure we handle errors while reporting the error!
1099 -- (e.g. evaluating the string passed to 'error' might generate
1100 -- another error, etc.)
1101 topHandler :: Bool -> Exception -> IO ()
1102 topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
1104 real_handler :: Bool -> Exception -> IO ()
1105 real_handler bombOut ex =
1107 AsyncException StackOverflow -> reportStackOverflow bombOut
1108 ErrorCall s -> reportError bombOut s
1109 other -> reportError bombOut (showsPrec 0 other "\n")
1111 reportStackOverflow :: Bool -> IO ()
1112 reportStackOverflow bombOut = do
1113 (hFlush stdout) `catchException` (\ _ -> return ())
1114 callStackOverflowHook
1120 reportError :: Bool -> String -> IO ()
1121 reportError bombOut str = do
1122 (hFlush stdout) `catchException` (\ _ -> return ())
1123 let bs@(ByteArray (_,len) _) = packString str
1124 writeErrString addrOf_ErrorHdrHook bs len
1130 foreign label "ErrorHdrHook"
1131 addrOf_ErrorHdrHook :: Addr
1133 foreign import ccall "writeErrString__"
1134 writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
1136 foreign import ccall "stackOverflow"
1137 callStackOverflowHook :: IO ()
1139 foreign import ccall "stg_exit"
1140 stg_exit :: Int -> IO ()
1144 A number of operations want to get at a readable or writeable handle, and fail
1148 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1149 wantReadableHandle fun handle act =
1150 withHandle handle $ \ handle_ -> do
1151 case haType__ handle_ of
1152 ErrorHandle theError -> do
1153 writeHandle handle handle_
1156 writeHandle handle handle_
1157 ioe_closedHandle fun handle
1158 SemiClosedHandle -> do
1159 writeHandle handle handle_
1160 ioe_closedHandle fun handle
1162 writeHandle handle handle_
1163 ioError not_readable_error
1165 writeHandle handle handle_
1166 ioError not_readable_error
1169 not_readable_error =
1170 IOError (Just handle) IllegalOperation fun
1171 ("handle is not open for reading")
1173 wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1174 wantWriteableHandle fun handle act =
1175 withHandle handle $ \ handle_ -> do
1176 case haType__ handle_ of
1177 ErrorHandle theError -> do
1178 writeHandle handle handle_
1181 writeHandle handle handle_
1182 ioe_closedHandle fun handle
1183 SemiClosedHandle -> do
1184 writeHandle handle handle_
1185 ioe_closedHandle fun handle
1187 writeHandle handle handle_
1188 ioError not_writeable_error
1191 not_writeable_error =
1192 IOError (Just handle) IllegalOperation fun
1193 ("handle is not open for writing")
1195 wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1196 wantRWHandle fun handle act =
1197 withHandle handle $ \ handle_ -> do
1198 case haType__ handle_ of
1199 ErrorHandle theError -> do
1200 writeHandle handle handle_
1203 writeHandle handle handle_
1204 ioe_closedHandle fun handle
1205 SemiClosedHandle -> do
1206 writeHandle handle handle_
1207 ioe_closedHandle fun handle
1211 IOError (Just handle) IllegalOperation fun
1212 ("handle is not open for reading or writing")
1214 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1215 wantSeekableHandle fun handle act =
1216 withHandle handle $ \ handle_ -> do
1217 case haType__ handle_ of
1218 ErrorHandle theError -> do
1219 writeHandle handle handle_
1222 writeHandle handle handle_
1223 ioe_closedHandle fun handle
1224 SemiClosedHandle -> do
1225 writeHandle handle handle_
1226 ioe_closedHandle fun handle
1228 writeHandle handle handle_
1229 ioError not_seekable_error
1232 not_seekable_error =
1233 IOError (Just handle)
1234 IllegalOperation fun
1235 ("handle is not seekable")
1239 Internal function for creating an @IOError@ representing the
1240 access to a closed file.
1243 ioe_closedHandle :: String -> Handle -> IO a
1244 ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed")
1247 Internal helper functions for Concurrent Haskell implementation
1251 #ifndef __PARALLEL_HASKELL__
1252 mayBlock :: ForeignObj -> IO Int -> IO Int
1254 mayBlock :: Addr -> IO Int -> IO Int
1257 #ifndef notyet /*__CONCURRENT_HASKELL__*/
1258 mayBlock _ act = act
1260 mayBlock fo act = do
1263 -5 -> do -- (possibly blocking) read
1264 fd <- CCALL(getFileFd) fo
1266 CCALL(clearNonBlockingIOFlag__) fo -- force read to happen this time.
1267 mayBlock fo act -- input available, re-try
1268 -6 -> do -- (possibly blocking) write
1269 fd <- CCALL(getFileFd) fo
1271 CCALL(clearNonBlockingIOFlag__) fo -- force write to happen this time.
1272 mayBlock fo act -- output possible
1273 -7 -> do -- (possibly blocking) write on connected handle
1274 fd <- CCALL(getConnFileFd) fo
1276 CCALL(clearConnNonBlockingIOFlag__) fo -- force write to happen this time.
1277 mayBlock fo act -- output possible
1279 CCALL(setNonBlockingIOFlag__) fo -- reset file object.
1280 CCALL(setConnNonBlockingIOFlag__) fo -- reset (connected) file object.
1287 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
1289 -- Hugs does actually have the primops needed to implement these
1290 -- but, like GHC, the primops don't actually do anything...
1291 threadDelay _ = return ()
1292 threadWaitRead _ = return ()
1293 threadWaitWrite _ = return ()
1302 type Exclusive = Int -- really Bool
1305 type OpenStdFlags = Int
1306 type OpenFlags = Int
1307 type Readable = Int -- really Bool
1308 type Flush = Int -- really Bool
1309 type RC = Int -- standard return code
1311 type IOFileAddr = Addr -- as returned from functions
1312 type CString = PrimByteArray
1313 type Bytes = PrimMutableByteArray RealWorld
1315 #ifndef __PARALLEL_HASKELL__
1316 type FILE_OBJ = ForeignObj -- as passed into functions
1318 type FILE_OBJ = Addr
1321 foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
1322 foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int
1323 foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC
1324 foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int
1325 foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int
1326 foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int
1327 foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int
1328 foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int
1329 foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
1330 foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC
1331 foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
1332 foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr
1333 foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
1334 foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
1335 foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
1336 foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
1337 foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
1338 foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
1339 foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
1340 foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
1341 foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
1342 foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
1343 foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
1344 foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
1345 foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC
1346 foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1347 foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC
1348 foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
1349 foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
1350 foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD
1351 foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
1352 foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int
1353 foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
1354 foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD
1355 foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr
1356 foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC
1357 foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1358 foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1359 foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO ()
1360 foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO ()
1361 foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int
1363 foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__" unsafe prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1364 foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1365 foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__" unsafe prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1366 foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__" unsafe prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1368 foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr
1369 foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int
1370 foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int