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(..) )
28 import PrelAddr ( Addr, nullAddr )
29 import PrelNum ( toInteger, toBig )
30 import PrelPack ( packString )
31 import PrelWeak ( addForeignFinalizer )
34 #if __CONCURRENT_HASKELL__
38 #ifndef __PARALLEL_HASKELL__
39 import PrelForeign ( makeForeignObj )
42 #endif /* ndef(__HUGS__) */
45 #define cat2(x,y) x##y
46 #define CCALL(fun) cat2(prim_,fun)
47 #define __CONCURRENT_HASKELL__
49 #define sizeof_int64 8
51 #define CCALL(fun) _ccall_ fun
52 #define const_BUFSIZ ``BUFSIZ''
53 #define primPackString
56 #ifndef __PARALLEL_HASKELL__
57 #define FILE_OBJECT ForeignObj
59 #define FILE_OBJECT Addr
63 %*********************************************************
65 \subsection{Types @Handle@, @Handle__@}
67 %*********************************************************
69 The @Handle@ and @Handle__@ types are defined in @IOBase@.
72 {-# INLINE newHandle #-}
73 {-# INLINE withHandle #-}
74 {-# INLINE writeHandle #-}
75 newHandle :: Handle__ -> IO Handle
76 withHandle :: Handle -> (Handle__ -> IO a) -> IO a
77 writeHandle :: Handle -> Handle__ -> IO ()
79 #if defined(__CONCURRENT_HASKELL__)
81 -- Use MVars for concurrent Haskell
82 newHandle hc = newMVar hc >>= \ h ->
85 -- withHandle grabs the handle lock, performs
86 -- some operation over it, making sure that we
87 -- unlock & reset the handle state should an
88 -- exception occur while performing said op.
89 withHandle (Handle h) act = do
91 v <- catchNonIO (act h_) (\ ex -> putMVar h h_ >> throw ex)
94 writeHandle (Handle h) hc = putMVar h hc
97 -- Use ordinary MutableVars for non-concurrent Haskell
98 newHandle hc = stToIO (newVar hc >>= \ h ->
101 -- of questionable value to install this exception
102 -- handler, but let's do it in the non-concurrent
103 -- case too, for now.
104 withHandle (Handle h) act = do
105 h_ <- stToIO (readVar h)
106 v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
109 writeHandle (Handle h) hc = stToIO (writeVar h hc)
113 nullFile__ is only used for closed handles, plugging it in as a null
114 file object reference.
117 nullFile__ :: FILE_OBJECT
119 #ifndef __PARALLEL_HASKELL__
120 unsafePerformIO (makeForeignObj nullAddr)
126 mkClosedHandle__ :: Handle__
134 mkErrorHandle__ :: IOError -> Handle__
135 mkErrorHandle__ ioe =
143 %*********************************************************
145 \subsection{Handle Finalizers}
147 %*********************************************************
151 freeStdFileObject :: ForeignObj -> IO ()
152 freeStdFileObject fo = CCALL(freeStdFileObject) fo
154 freeFileObject :: ForeignObj -> IO ()
155 freeFileObject fo = CCALL(freeFileObject) fo
157 foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
158 foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
162 %*********************************************************
164 \subsection[StdHandles]{Standard handles}
166 %*********************************************************
168 Three handles are allocated during program initialisation. The first
169 two manage input or output from the Haskell program's standard input
170 or output channel respectively. The third manages output to the
171 standard error channel. These handles are initially open.
175 stdin, stdout, stderr :: Handle
177 stdout = unsafePerformIO (do
178 rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block
180 0 -> newHandle (mkClosedHandle__)
182 #ifndef __CONCURRENT_HASKELL__
183 fo <- CCALL(openStdFile) (1::Int)
184 (1::Int){-flush on close-}
185 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
187 fo <- CCALL(openStdFile) (1::Int)
188 ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int)
189 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
191 -- NOTE: turn off non-blocking I/O until
192 -- we've got proper support for threadWait{Read,Write}
194 #ifndef __PARALLEL_HASKELL__
195 fo <- makeForeignObj fo
196 addForeignFinalizer fo (freeStdFileObject fo)
200 /* I dont care what the Haskell report says, in an interactive system,
201 * stdout should be unbuffered by default.
205 (bm, bf_size) <- getBMode__ fo
206 mkBuffer__ fo bf_size
208 newHandle (Handle__ fo WriteHandle bm "stdout")
209 _ -> do ioError <- constructError "stdout"
210 newHandle (mkErrorHandle__ ioError)
213 stdin = unsafePerformIO (do
214 rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block
216 0 -> newHandle (mkClosedHandle__)
218 #ifndef __CONCURRENT_HASKELL__
219 fo <- CCALL(openStdFile) (0::Int)
220 (0::Int){-don't flush on close -}
221 (1::Int){-readable-} -- ConcHask: SAFE, won't block
223 fo <- CCALL(openStdFile) (0::Int)
224 ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int)
225 (1::Int){-readable-} -- ConcHask: SAFE, won't block
228 #ifndef __PARALLEL_HASKELL__
229 fo <- makeForeignObj fo
230 addForeignFinalizer fo (freeStdFileObject fo)
232 (bm, bf_size) <- getBMode__ fo
233 mkBuffer__ fo bf_size
234 hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
235 -- when stdin and stdout are both connected to a terminal, ensure
236 -- that anything buffered on stdout is flushed prior to reading from stdin.
238 hConnectTerms stdout hdl
240 _ -> do ioError <- constructError "stdin"
241 newHandle (mkErrorHandle__ ioError)
245 stderr = unsafePerformIO (do
246 rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
248 0 -> newHandle (mkClosedHandle__)
250 #ifndef __CONCURRENT_HASKELL__
251 fo <- CCALL(openStdFile) (2::Int)
252 (1::Int){-flush on close-}
253 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
255 fo <- CCALL(openStdFile) (2::Int)
256 ((1{-flush on close-} {- + 128 don't block on I/O-})::Int)
257 (0::Int){-writeable-} -- ConcHask: SAFE, won't block
260 #ifndef __PARALLEL_HASKELL__
261 fo <- makeForeignObj fo
262 addForeignFinalizer fo (freeStdFileObject fo)
264 hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
265 -- when stderr and stdout are both connected to a terminal, ensure
266 -- that anything buffered on stdout is flushed prior to writing to
268 hConnectTo stdout hdl
271 _ -> do ioError <- constructError "stderr"
272 newHandle (mkErrorHandle__ ioError)
276 %*********************************************************
278 \subsection[OpeningClosing]{Opening and Closing Files}
280 %*********************************************************
283 data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
284 deriving (Eq, Ord, Ix, Enum, Read, Show)
289 deriving (Eq, Read, Show)
291 openFile :: FilePath -> IOMode -> IO Handle
292 openFile fp im = openFileEx fp (TextMode im)
294 openFileEx :: FilePath -> IOModeEx -> IO Handle
297 fo <- CCALL(openFile) (primPackString f) (file_mode::Int)
299 (file_flags::Int) -- ConcHask: SAFE, won't block
300 if fo /= nullAddr then do
301 #ifndef __PARALLEL_HASKELL__
302 fo <- makeForeignObj fo
303 addForeignFinalizer fo (freeFileObject fo)
305 (bm, bf_size) <- getBMode__ fo
306 mkBuffer__ fo bf_size
307 newHandle (Handle__ fo htype bm f)
309 constructErrorAndFailWithInfo "openFile" f
313 BinaryMode bmo -> (bmo, 1)
314 TextMode tmo -> (tmo, 0)
316 #ifndef __CONCURRENT_HASKELL__
317 file_flags = file_flags'
319 -- See comment next to 'stderr' for why we leave
320 -- non-blocking off for now.
321 file_flags = file_flags' {-+ 128 Don't block on I/O-}
324 (file_flags', file_mode) =
329 ReadWriteMode -> (1, 3)
332 ReadMode -> ReadHandle
333 WriteMode -> WriteHandle
334 AppendMode -> AppendHandle
335 ReadWriteMode -> ReadWriteHandle
338 Computation $openFile file mode$ allocates and returns a new, open
339 handle to manage the file {\em file}. It manages input if {\em mode}
340 is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
341 and both input and output if mode is $ReadWriteMode$.
343 If the file does not exist and it is opened for output, it should be
344 created as a new file. If {\em mode} is $WriteMode$ and the file
345 already exists, then it should be truncated to zero length. The
346 handle is positioned at the end of the file if {\em mode} is
347 $AppendMode$, and otherwise at the beginning (in which case its
348 internal position is 0).
350 Implementations should enforce, locally to the Haskell process,
351 multiple-reader single-writer locking on files, which is to say that
352 there may either be many handles on the same file which manage input,
353 or just one handle on the file which manages output. If any open or
354 semi-closed handle is managing a file for output, no new handle can be
355 allocated for that file. If any open or semi-closed handle is
356 managing a file for input, new handles can only be allocated if they
357 do not manage output.
359 Two files are the same if they have the same absolute name. An
360 implementation is free to impose stricter conditions.
363 hClose :: Handle -> IO ()
366 withHandle handle $ \ handle_ -> do
367 case haType__ handle_ of
368 ErrorHandle theError -> do
369 writeHandle handle handle_
372 writeHandle handle handle_
375 rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
376 {- We explicitly close a file object so that we can be told
377 if there were any errors. Note that after @hClose@
378 has been performed, the ForeignObj embedded in the Handle
379 is still lying around in the heap, so care is taken
380 to avoid closing the file object when the ForeignObj
381 is finalized. (we overwrite the file ptr in the underlying
382 FileObject with a NULL as part of closeFile())
386 writeHandle handle (handle_{ haType__ = ClosedHandle,
387 haFO__ = nullFile__ })
389 writeHandle handle handle_
390 constructErrorAndFail "hClose"
394 Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
395 computation finishes, any items buffered for output and not already
396 sent to the operating system are flushed as for $flush$.
398 %*********************************************************
400 \subsection[EOF]{Detecting the End of Input}
402 %*********************************************************
405 For a handle {\em hdl} which attached to a physical file, $hFileSize
406 hdl$ returns the size of {\em hdl} in terms of the number of items
407 which can be read from {\em hdl}.
410 hFileSize :: Handle -> IO Integer
412 withHandle handle $ \ handle_ -> do
413 case haType__ handle_ of
414 ErrorHandle theError -> do
415 writeHandle handle handle_
418 writeHandle handle handle_
419 ioe_closedHandle "hFileSize" handle
420 SemiClosedHandle -> do
421 writeHandle handle handle_
422 ioe_closedHandle "hFileSize" handle
425 mem <- primNewByteArray sizeof_int64
426 rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
427 writeHandle handle handle_
429 result <- primReadInt64Array mem 0
430 return (primInt64ToInteger result)
432 constructErrorAndFail "hFileSize"
435 -- HACK! We build a unique MP_INT of the right shape to hold
436 -- a single unsigned word, and we let the C routine
437 -- change the data bits
439 -- For some reason, this fails to typecheck if converted to a do
441 _casm_ ``%r = 1;'' >>= \(I# hack#) ->
442 case int2Integer# hack# of
444 rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
445 writeHandle handle handle_
446 if rc == (0::Int) then
449 constructErrorAndFail "hFileSize"
453 For a readable handle {\em hdl}, @hIsEOF hdl@ returns
454 @True@ if no further input can be taken from @hdl@ or for a
455 physical file, if the current I/O position is equal to the length of
456 the file. Otherwise, it returns @False@.
459 hIsEOF :: Handle -> IO Bool
461 wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
462 let fo = haFO__ handle_
463 rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
464 writeHandle handle handle_
468 _ -> constructErrorAndFail "hIsEOF"
474 %*********************************************************
476 \subsection[Buffering]{Buffering Operations}
478 %*********************************************************
480 Three kinds of buffering are supported: line-buffering,
481 block-buffering or no-buffering. See @IOBase@ for definition
482 and further explanation of what the type represent.
484 Computation @hSetBuffering hdl mode@ sets the mode of buffering for
485 handle {\em hdl} on subsequent reads and writes.
489 If {\em mode} is @LineBuffering@, line-buffering should be
492 If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
493 should be enabled if possible. The size of the buffer is {\em n} items
494 if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
496 If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
499 If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
500 to @NoBuffering@, then any items in the output buffer are written to
501 the device, and any items in the input buffer are discarded. The
502 default buffering mode when a handle is opened is
503 implementation-dependent and may depend on the object which is
504 attached to that handle.
507 hSetBuffering :: Handle -> BufferMode -> IO ()
509 hSetBuffering handle mode =
511 BlockBuffering (Just n)
513 (IOError (Just handle)
516 ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
518 withHandle handle $ \ handle_ -> do
519 case haType__ handle_ of
520 ErrorHandle theError -> do
521 writeHandle handle handle_
524 writeHandle handle handle_
525 ioe_closedHandle "hSetBuffering" handle
528 - we flush the old buffer regardless of whether
529 the new buffer could fit the contents of the old buffer
531 - allow a handle's buffering to change even if IO has
532 occurred (ANSI C spec. does not allow this, nor did
533 the previous implementation of IO.hSetBuffering).
534 - a non-standard extension is to allow the buffering
535 of semi-closed handles to change [sof 6/98]
537 let fo = haFO__ handle_
538 rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
541 writeHandle handle (handle_{ haBufferMode__ = mode })
543 -- Note: failure to change the buffer size will cause old buffer to be flushed.
544 writeHandle handle handle_
545 constructErrorAndFail "hSetBuffering"
551 BlockBuffering Nothing -> -2
552 BlockBuffering (Just n) -> n
555 The action @hFlush hdl@ causes any items buffered for output
556 in handle {\em hdl} to be sent immediately to the operating
560 hFlush :: Handle -> IO ()
562 wantWriteableHandle "hFlush" handle $ \ handle_ -> do
563 let fo = haFO__ handle_
564 rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
565 writeHandle handle handle_
569 constructErrorAndFail "hFlush"
574 %*********************************************************
576 \subsection[Seeking]{Repositioning Handles}
578 %*********************************************************
583 Handle -- Q: should this be a weak or strong ref. to the handle?
586 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
587 deriving (Eq, Ord, Ix, Enum, Read, Show)
590 Computation @hGetPosn hdl@ returns the current I/O
591 position of {\em hdl} as an abstract position. Computation
592 $hSetPosn p$ sets the position of {\em hdl}
593 to a previously obtained position {\em p}.
596 hGetPosn :: Handle -> IO HandlePosn
598 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
599 posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
600 writeHandle handle handle_
602 return (HandlePosn handle posn)
604 constructErrorAndFail "hGetPosn"
606 hSetPosn :: HandlePosn -> IO ()
607 hSetPosn (HandlePosn handle posn) =
608 wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
609 let fo = haFO__ handle_
610 rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
611 writeHandle handle handle_
615 constructErrorAndFail "hSetPosn"
618 The action @hSeek hdl mode i@ sets the position of handle
619 @hdl@ depending on @mode@. If @mode@ is
621 \item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
622 \item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
623 the current position.
624 \item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
628 Some handles may not be seekable (see @hIsSeekable@), or only support a
629 subset of the possible positioning operations (e.g. it may only be
630 possible to seek to the end of a tape, or to a positive offset from
631 the beginning or current position).
633 It is not possible to set a negative I/O position, or for a physical
634 file, an I/O position beyond the current end-of-file.
637 - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
639 - relative seeking on buffered handles can lead to non-obvious results.
642 hSeek :: Handle -> SeekMode -> Integer -> IO ()
644 hSeek handle mode offset =
645 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
646 let fo = haFO__ handle_
647 rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
649 hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
650 hSeek handle mode (J# s# d#) =
651 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
652 let fo = haFO__ handle_
653 rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
655 writeHandle handle handle_
659 constructErrorAndFail "hSeek"
662 whence = case mode of
668 %*********************************************************
670 \subsection[Query]{Handle Properties}
672 %*********************************************************
674 A number of operations return information about the properties of a
675 handle. Each of these operations returns $True$ if the
676 handle has the specified property, and $False$
679 Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
680 {\em hdl} is not block-buffered. Otherwise it returns
681 $( True, size )$, where {\em size} is $Nothing$ for default buffering, and
682 $( Just n )$ for block-buffering of {\em n} bytes.
685 hIsOpen :: Handle -> IO Bool
687 withHandle handle $ \ handle_ -> do
688 case haType__ handle_ of
689 ErrorHandle theError -> do
690 writeHandle handle handle_
693 writeHandle handle handle_
695 SemiClosedHandle -> do
696 writeHandle handle handle_
699 writeHandle handle handle_
702 hIsClosed :: Handle -> IO Bool
704 withHandle handle $ \ handle_ -> do
705 case haType__ handle_ of
706 ErrorHandle theError -> do
707 writeHandle handle handle_
710 writeHandle handle handle_
713 writeHandle handle handle_
716 {- not defined, nor exported, but mentioned
717 here for documentation purposes:
719 hSemiClosed :: Handle -> IO Bool
723 return (not (ho || hc))
726 hIsReadable :: Handle -> IO Bool
728 withHandle handle $ \ handle_ -> do
729 case haType__ handle_ of
730 ErrorHandle theError -> do
731 writeHandle handle handle_
734 writeHandle handle handle_
735 ioe_closedHandle "hIsReadable" handle
736 SemiClosedHandle -> do
737 writeHandle handle handle_
738 ioe_closedHandle "hIsReadable" handle
740 writeHandle handle handle_
741 return (isReadable htype)
743 isReadable ReadHandle = True
744 isReadable ReadWriteHandle = True
747 hIsWritable :: Handle -> IO Bool
749 withHandle handle $ \ handle_ -> do
750 case haType__ handle_ of
751 ErrorHandle theError -> do
752 writeHandle handle handle_
755 writeHandle handle handle_
756 ioe_closedHandle "hIsWritable" handle
757 SemiClosedHandle -> do
758 writeHandle handle handle_
759 ioe_closedHandle "hIsWritable" handle
761 writeHandle handle handle_
762 return (isWritable htype)
764 isWritable AppendHandle = True
765 isWritable WriteHandle = True
766 isWritable ReadWriteHandle = True
770 #ifndef __PARALLEL_HASKELL__
771 getBMode__ :: ForeignObj -> IO (BufferMode, Int)
773 getBMode__ :: Addr -> IO (BufferMode, Int)
776 rc <- CCALL(getBufferMode) fo -- ConcHask: SAFE, won't block
778 0 -> return (NoBuffering, 0)
779 -1 -> return (LineBuffering, default_buffer_size)
780 -2 -> return (BlockBuffering Nothing, default_buffer_size)
781 -3 -> return (NoBuffering, 0) -- only happens on un-stat()able files.
782 n -> return (BlockBuffering (Just n), n)
784 default_buffer_size :: Int
785 default_buffer_size = (const_BUFSIZ - 1)
788 Querying how a handle buffers its data:
791 hGetBuffering :: Handle -> IO BufferMode
792 hGetBuffering handle =
793 withHandle handle $ \ handle_ -> do
794 case haType__ handle_ of
795 ErrorHandle theError -> do
796 writeHandle handle handle_
799 writeHandle handle handle_
800 ioe_closedHandle "hGetBuffering" handle
803 We're being non-standard here, and allow the buffering
804 of a semi-closed handle to be queried. -- sof 6/98
806 let v = haBufferMode__ handle_
807 writeHandle handle handle_
808 return v -- could be stricter..
813 hIsSeekable :: Handle -> IO Bool
815 withHandle handle $ \ handle_ -> do
816 case haType__ handle_ of
817 ErrorHandle theError -> do
818 writeHandle handle handle_
821 writeHandle handle handle_
822 ioe_closedHandle "hIsSeekable" handle
823 SemiClosedHandle -> do
824 writeHandle handle handle_
825 ioe_closedHandle "hIsSeekable" handle
827 writeHandle handle handle_
830 rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
831 writeHandle handle handle_
835 _ -> constructErrorAndFail "hIsSeekable"
839 %*********************************************************
841 \subsection{Changing echo status}
843 %*********************************************************
845 Non-standard GHC extension is to allow the echoing status
846 of a handles connected to terminals to be reconfigured:
849 hSetEcho :: Handle -> Bool -> IO ()
850 hSetEcho handle on = do
851 isT <- hIsTerminalDevice handle
855 withHandle handle $ \ handle_ -> do
856 case haType__ handle_ of
857 ErrorHandle theError -> do
858 writeHandle handle handle_
861 writeHandle handle handle_
862 ioe_closedHandle "hSetEcho" handle
864 rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block
865 writeHandle handle handle_
868 else constructErrorAndFail "hSetEcho"
870 hGetEcho :: Handle -> IO Bool
872 isT <- hIsTerminalDevice handle
876 withHandle handle $ \ handle_ -> do
877 case haType__ handle_ of
878 ErrorHandle theError -> do
879 writeHandle handle handle_
882 writeHandle handle handle_
883 ioe_closedHandle "hGetEcho" handle
885 rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
886 writeHandle handle handle_
890 _ -> constructErrorAndFail "hSetEcho"
892 hIsTerminalDevice :: Handle -> IO Bool
893 hIsTerminalDevice handle = do
894 withHandle handle $ \ handle_ -> do
895 case haType__ handle_ of
896 ErrorHandle theError -> do
897 writeHandle handle handle_
900 writeHandle handle handle_
901 ioe_closedHandle "hIsTerminalDevice" handle
903 rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
904 writeHandle handle handle_
908 _ -> constructErrorAndFail "hIsTerminalDevice"
912 hConnectTerms :: Handle -> Handle -> IO ()
913 hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
915 hConnectTo :: Handle -> Handle -> IO ()
916 hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
918 hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
919 hConnectHdl_ hW hR is_tty =
920 wantRWHandle "hConnectTo" hW $ \ hW_ ->
921 wantRWHandle "hConnectTo" hR $ \ hR_ -> do
922 CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
926 #ifndef __PARALLEL_HASKELL__
927 #define FILE_OBJECT ForeignObj
929 #define FILE_OBJECT Addr
932 flushConnectedBuf :: FILE_OBJECT -> IO ()
933 flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
936 As an extension, we also allow characters to be pushed back.
937 Like ANSI C stdio, we guarantee no more than one character of
938 pushback. (For unbuffered channels, the (default) push-back limit is
942 hUngetChar :: Handle -> Char -> IO ()
943 hUngetChar handle c =
944 wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
945 rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
946 writeHandle handle handle_
948 then constructErrorAndFail "hUngetChar"
954 Hoisting files in in one go is sometimes useful, so we support
955 this as an extension:
958 -- in one go, read file into an externally allocated buffer.
959 slurpFile :: FilePath -> IO (Addr, Int)
961 handle <- openFile fname ReadMode
962 sz <- hFileSize handle
963 if sz > toInteger (maxBound::Int) then
964 ioError (userError "slurpFile: file too big")
966 let sz_i = fromInteger sz
967 chunk <- CCALL(allocMemory__) (sz_i::Int)
971 constructErrorAndFail "slurpFile"
973 withHandle handle $ \ handle_ -> do
974 let fo = haFO__ handle_
975 rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
976 writeHandle handle handle_
979 then constructErrorAndFail "slurpFile"
980 else return (chunk, rc)
982 #ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
983 hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
984 hFillBufBA handle buf sz
985 | sz <= 0 = ioError (IOError (Just handle)
988 ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
990 wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
991 let fo = haFO__ handle_
993 rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block.
995 rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
997 writeHandle handle handle_
1000 else constructErrorAndFail "hFillBufBA"
1003 hFillBuf :: Handle -> Addr -> Int -> IO Int
1004 hFillBuf handle buf sz
1005 | sz <= 0 = ioError (IOError (Just handle)
1008 ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
1010 wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
1011 let fo = haFO__ handle_
1012 rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
1013 writeHandle handle handle_
1016 else constructErrorAndFail "hFillBuf"
1020 The @hPutBuf hdl buf len@ action writes an already packed sequence of
1021 bytes to the file/channel managed by @hdl@ - non-standard.
1024 hPutBuf :: Handle -> Addr -> Int -> IO ()
1025 hPutBuf handle buf len =
1026 wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
1027 let fo = haFO__ handle_
1028 rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
1029 writeHandle handle handle_
1032 else constructErrorAndFail "hPutBuf"
1034 #ifndef __HUGS__ /* An_ one Hugs doesn't provide */
1035 hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
1036 hPutBufBA handle buf len =
1037 wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
1038 let fo = haFO__ handle_
1039 rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
1040 writeHandle handle handle_
1043 else constructErrorAndFail "hPutBuf"
1047 Sometimes it's useful to get at the file descriptor that
1048 the Handle contains..
1051 getHandleFd :: Handle -> IO Int
1052 getHandleFd handle =
1053 withHandle handle $ \ handle_ -> do
1054 case (haType__ handle_) of
1055 ErrorHandle theError -> do
1056 writeHandle handle handle_
1059 writeHandle handle handle_
1060 ioe_closedHandle "getHandleFd" handle
1062 fd <- CCALL(getFileFd) (haFO__ handle_)
1063 writeHandle handle handle_
1068 %*********************************************************
1070 \subsection{Miscellaneous}
1072 %*********************************************************
1074 These three functions are meant to get things out of @IOErrors@.
1079 ioeGetFileName :: IOError -> Maybe FilePath
1080 ioeGetErrorString :: IOError -> String
1081 ioeGetHandle :: IOError -> Maybe Handle
1083 ioeGetHandle (IOError h _ _ _) = h
1084 ioeGetErrorString (IOError _ iot _ str) =
1086 EOF -> "end of file"
1089 ioeGetFileName (IOError _ _ _ str) =
1090 case span (/=':') str of
1096 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
1097 PrelMain.mainIO) and report them - topHandler is the exception
1098 handler they should use for this:
1101 -- make sure we handle errors while reporting the error!
1102 -- (e.g. evaluating the string passed to 'error' might generate
1103 -- another error, etc.)
1104 topHandler :: Bool -> Exception -> IO ()
1105 topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
1107 real_handler :: Bool -> Exception -> IO ()
1108 real_handler bombOut ex =
1110 AsyncException StackOverflow -> reportStackOverflow bombOut
1111 ErrorCall s -> reportError bombOut s
1112 other -> reportError bombOut (showsPrec 0 other "\n")
1114 reportStackOverflow :: Bool -> IO ()
1115 reportStackOverflow bombOut = do
1116 (hFlush stdout) `catchException` (\ _ -> return ())
1117 callStackOverflowHook
1123 reportError :: Bool -> String -> IO ()
1124 reportError bombOut str = do
1125 (hFlush stdout) `catchException` (\ _ -> return ())
1126 let bs@(ByteArray (_,len) _) = packString str
1127 writeErrString addrOf_ErrorHdrHook bs len
1133 foreign label "ErrorHdrHook"
1134 addrOf_ErrorHdrHook :: Addr
1136 foreign import ccall "writeErrString__"
1137 writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
1139 foreign import ccall "stackOverflow"
1140 callStackOverflowHook :: IO ()
1142 foreign import ccall "stg_exit"
1143 stg_exit :: Int -> IO ()
1147 A number of operations want to get at a readable or writeable handle, and fail
1151 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1152 wantReadableHandle fun handle act =
1153 withHandle handle $ \ handle_ -> do
1154 case haType__ handle_ of
1155 ErrorHandle theError -> do
1156 writeHandle handle handle_
1159 writeHandle handle handle_
1160 ioe_closedHandle fun handle
1161 SemiClosedHandle -> do
1162 writeHandle handle handle_
1163 ioe_closedHandle fun handle
1165 writeHandle handle handle_
1166 ioError not_readable_error
1168 writeHandle handle handle_
1169 ioError not_readable_error
1172 not_readable_error =
1173 IOError (Just handle) IllegalOperation fun
1174 ("handle is not open for reading")
1176 wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1177 wantWriteableHandle fun handle act =
1178 withHandle handle $ \ handle_ -> do
1179 case haType__ handle_ of
1180 ErrorHandle theError -> do
1181 writeHandle handle handle_
1184 writeHandle handle handle_
1185 ioe_closedHandle fun handle
1186 SemiClosedHandle -> do
1187 writeHandle handle handle_
1188 ioe_closedHandle fun handle
1190 writeHandle handle handle_
1191 ioError not_writeable_error
1194 not_writeable_error =
1195 IOError (Just handle) IllegalOperation fun
1196 ("handle is not open for writing")
1198 wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1199 wantRWHandle fun handle act =
1200 withHandle handle $ \ handle_ -> do
1201 case haType__ handle_ of
1202 ErrorHandle theError -> do
1203 writeHandle handle handle_
1206 writeHandle handle handle_
1207 ioe_closedHandle fun handle
1208 SemiClosedHandle -> do
1209 writeHandle handle handle_
1210 ioe_closedHandle fun handle
1214 IOError (Just handle) IllegalOperation fun
1215 ("handle is not open for reading or writing")
1217 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
1218 wantSeekableHandle fun handle act =
1219 withHandle handle $ \ handle_ -> do
1220 case haType__ handle_ of
1221 ErrorHandle theError -> do
1222 writeHandle handle handle_
1225 writeHandle handle handle_
1226 ioe_closedHandle fun handle
1227 SemiClosedHandle -> do
1228 writeHandle handle handle_
1229 ioe_closedHandle fun handle
1231 writeHandle handle handle_
1232 ioError not_seekable_error
1235 not_seekable_error =
1236 IOError (Just handle)
1237 IllegalOperation fun
1238 ("handle is not seekable")
1242 Internal function for creating an @IOError@ representing the
1243 access to a closed file.
1246 ioe_closedHandle :: String -> Handle -> IO a
1247 ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed")
1250 Internal helper functions for Concurrent Haskell implementation
1254 #ifndef __PARALLEL_HASKELL__
1255 mayBlock :: ForeignObj -> IO Int -> IO Int
1257 mayBlock :: Addr -> IO Int -> IO Int
1260 #ifndef notyet /*__CONCURRENT_HASKELL__*/
1261 mayBlock _ act = act
1263 mayBlock fo act = do
1266 -5 -> do -- (possibly blocking) read
1267 fd <- CCALL(getFileFd) fo
1269 CCALL(clearNonBlockingIOFlag__) fo -- force read to happen this time.
1270 mayBlock fo act -- input available, re-try
1271 -6 -> do -- (possibly blocking) write
1272 fd <- CCALL(getFileFd) fo
1274 CCALL(clearNonBlockingIOFlag__) fo -- force write to happen this time.
1275 mayBlock fo act -- output possible
1276 -7 -> do -- (possibly blocking) write on connected handle
1277 fd <- CCALL(getConnFileFd) fo
1279 CCALL(clearConnNonBlockingIOFlag__) fo -- force write to happen this time.
1280 mayBlock fo act -- output possible
1282 CCALL(setNonBlockingIOFlag__) fo -- reset file object.
1283 CCALL(setConnNonBlockingIOFlag__) fo -- reset (connected) file object.
1290 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
1292 -- Hugs does actually have the primops needed to implement these
1293 -- but, like GHC, the primops don't actually do anything...
1294 threadDelay _ = return ()
1295 threadWaitRead _ = return ()
1296 threadWaitWrite _ = return ()
1305 type Exclusive = Int -- really Bool
1308 type OpenStdFlags = Int
1309 type OpenFlags = Int
1310 type Readable = Int -- really Bool
1311 type Flush = Int -- really Bool
1312 type RC = Int -- standard return code
1314 type IOFileAddr = Addr -- as returned from functions
1315 type CString = PrimByteArray
1316 type Bytes = PrimMutableByteArray RealWorld
1318 #ifndef __PARALLEL_HASKELL__
1319 type FILE_OBJ = ForeignObj -- as passed into functions
1321 type FILE_OBJ = Addr
1324 foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
1325 foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int
1326 foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC
1327 foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int
1328 foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int
1329 foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int
1330 foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int
1331 foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int
1332 foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
1333 foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC
1334 foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
1335 foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr
1336 foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
1337 foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
1338 foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
1339 foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
1340 foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
1341 foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
1342 foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
1343 foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
1344 foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
1345 foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
1346 foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
1347 foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
1348 foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC
1349 foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1350 foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC
1351 foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
1352 foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
1353 foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD
1354 foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
1355 foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int
1356 foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
1357 foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD
1358 foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr
1359 foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC
1360 foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1361 foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1362 foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO ()
1363 foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO ()
1364 foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int
1366 foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__" unsafe prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1367 foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1368 foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__" unsafe prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1369 foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__" unsafe prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1371 foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr
1372 foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int
1373 foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int